#| -*- Mode:LISP; ReadTable:CL; Fonts:(cptfontb); Base:10 -*-

JOSEPHUS.LISP

  By:	Keith M. Corbett
	Data Structures & Algorithms, Weds. 4:30 pm

  For:  Homework Problem 1

This is a Lisp implementation of the Pascal program example
demonstrated in "Data Structures Using Pascal". This helps to
prove why we sometimes sacrifice performance for sake of legibility...

|#

(eval-when (compile) (load "keith;pascal-macros")) ;Need iteration macros

;;;
;;; TNODE -- node structure, contains slots:
;;;
;;;	node-name 	- node label, for pretty printing
;;;	node-count	- count of descendants
;;;
;;; JOSEPHUS is implemented via an array structure which is used to
;;; create an "almost complete binary tree"...
;;;

(DefStruct (tnode)
  (node-name nil)
  (node-count 0))

;;;
;;; Tree/node utility functions
;;;

(DefMacro i-th(tree n)
  "Access the i-th array element, a node.
  Translates Pascal's 1-based array order to Lisp's 0-based order."
  `(aref ,tree (sub1 ,n)))

(DefMacro node_count (tree i)
  "Return descendant count of i-th node."
  `(node-count (i-th ,tree ,i)))

(DefMacro node_name (tree i)
  "Return node label of i-th node."
  `(node-name (i-th ,tree ,i)))

(DeFun dump-tree (tree)
  "Pretty-print a node tree."
  (Do-For (i 1 (length tree))
	 (format t "~%~s) ~s" i (i-th tree i)))
  (format t "~%"))

(defun next-power-of-2 (n)
  "Calculate next power of 2 >= n."
  (let(
       (next-2 1)
      )
    (while
      (lessp next-2 n)
        (setq next-2 (times next-2 2)))))

;;;
;;; Main function
;;;

(DeFun josephus (n k &aux last-one)

  "Demonstrate circular removal (by binary tree array) algorithm for a given n, k.

  Usage: (josephus <n> <k>), where 1 <= n <= 26, and k is any integer.

  For example, (josephus 13 9) calculates and returns the item that remains
  after removing every 9'th element of a 13-element list."

  (cond
    ((not (typep n 'integer)) (format t "~%N must be an integer!~%"))
    ((not (typep n 'integer)) (format t "~%K must be an integer!~%"))
    ((lessp n 1)         (format t "~%N must be >= 1!~%"))
    ((lessp k 1)         (format t "~%K must be >= 1!~%"))
    ((greaterp n 26)     (format t "~%N must be <= 26!~%"))
    (t
     (let*(

;;; name list

	   (names (firstn n '(a b c d e f g h i j k l m n o p q r s t u v w x y z)))

;;; number of nodes needed (array dimensions), = n*2 -1

	   (n-nodes (the integer (sub1 (times n 2))))

;;; node tree array

	   (tree (the array (make-array n-nodes :element-type 'tnode)))

;;; calculate 2**j, where j is desired height of tree;
;;; the j'th element of array is where the first name goes.

	   (twotomax (the integer (next-power-of-2 n)))

	 )

;;; confirm what we're doing in writing

	  (format t "~%Remove every ~d~a" k
		  (case k
		    (1 "st")
		    (2 "nd")
		    (3 "rd")
		    (t "th")))
	  (format t " element from ~s~%" names)

;;; construct 'almost complete binary tree'

	  (do-for (inx 1 n-nodes)
	    (setf (i-th tree inx) (make-tnode)))

	  (do-for (i twotomax n-nodes)
	    (setf (node_name tree i) (car names))
	    (setf (node_count tree i) 1)
	    (setq names (cdr names)))

	  (do-for (i n (sub1 twotomax))
	    (setf (node_name tree i) (car names))
	    (setf (node_count tree i) 1)
	    (setq names (cdr names)))

	  (do-for-downto (i (sub1 n) 1)
	    (setf (node_count tree i)
		  (plus
		    (node_count tree (times i 2))
		    (node_count tree (add1 (times i 2))))))

	  (dump-tree tree)

;;; start calculations here...
	  
	  (let*(
		(p (the integer 1))
		(remains (the integer
			      (add1
				(mod
				  (sub1 k)
				  (node_count tree 1)))))
	       )

	    (while
	      (neq (node_count tree 1) 1)
	        (while
		  (greaterp (node_count tree p) 1)
		    (setq p (times p 2))
		    (when (greaterp remains (node_count tree p))
		      (setq remains
			    (difference remains (node_count tree p)))
		      (incf p)))

;;; a-ha, got one - print eliminated name.

		(format t "Eliminated ~a.~%" (node_name tree p))
		
		(let(
		     (q (the integer p))
		    )
		  (while
		    (not (zerop q))

		      (decf (node_count tree q))

		      (if (= 1 (node_count tree q))
			(if
			  (= 1 (node_count tree (times q 2)))
			    (setf (node_name tree q)
				  (node_name tree (times q 2)))
			  (setf (node_name tree q)
				(node_name tree (add1 (times q 2))))))
		      
		      (setq q (quotient q 2))))

		(setq remains k)
		(unless (oddp p) (incf p))

		(while
		  (and
		    (greaterp remains (node_count tree p))
		    (neq p 1))

		  (decf remains (node_count tree p))

		  (while
		    (and (oddp p) (neq p 1))
		      (setq p (quotient p 2)))

		  (if (neq p 1) (incf p)))	;End while

		(if
		  (= p 1)
		    (setq remains (add1 (mod (sub1 remains) (node_count tree p)))))

		)	    ;End while root count <> 1

	    (setq last-one (node_name tree 1))

	 )
	  ;End long LET
			      
	  (format t "~%Only ~a remains.~%" last-one)

	  last-one)				;End long LET -- return final value?

						;End JOSEPHUS
     )))