(DEFMACRO DO-FOR ((VAR LOWER UPPER RESULTFORM) &BODY BODY)

  "Iterate BODY with VAR bound to successive integers from LOWER's to UPPER's value, inclusive.
This is a Pascal-style FOR loop, based heavily on the standard macro DOTIMES.
LOWER and UPPER are evaluated only once.  When it is reached, RESULTFORM is executed and returned.
RETURN and GO can be used inside the BODY."

  (IF (FIXNUMP UPPER)
      `(DO ((,VAR ,LOWER (1+ ,VAR)))
	   ((> ,VAR ,UPPER) ,RESULTFORM)
	 . ,BODY)
    (LET ((ITERATION-VAR (GENSYM)))
      `(DO ((,VAR ,LOWER (1+ ,VAR))
	    (,ITERATION-VAR ,UPPER))
	   ((> ,VAR ,ITERATION-VAR) ,RESULTFORM)
	 . ,BODY))))

(DEFMACRO DO-FOR-DOWNTO ((VAR LOWER UPPER RESULTFORM) &BODY BODY)

  "Iterate BODY with VAR bound to successive integers from LOWER's to UPPER's value, inclusive.
This is a Pascal-style FOR loop, based heavily on the standard macro DOTIMES.
LOWER and UPPER are evaluated only once.  When it is reached, RESULTFORM is executed and returned.
RETURN and GO can be used inside the BODY."

  (IF (FIXNUMP UPPER)
      `(DO ((,VAR ,LOWER (1- ,VAR)))
	   ((< ,VAR ,UPPER) ,RESULTFORM)
	 . ,BODY)
    (LET ((ITERATION-VAR (GENSYM)))
      `(DO ((,VAR ,LOWER (1- ,VAR))
	    (,ITERATION-VAR ,UPPER))
	   ((< ,VAR ,ITERATION-VAR) ,RESULTFORM)
	  ,@BODY))))

(DEFMACRO WHILE (PRED &REST BODY)

"(WHILE pred { form1 form2 ... } ) => (DO ((NOT pred)) (PROGN form1 form2 ...))
  WHILE loops repeatedly, evaluating the predicate 'pred' -- if the result is non-NIL,
  the body 'forms' are executed, and then back to the predicate, and so on.
  Normally the value returned is the last 'form' in the body.

RETURN and GO can be used to force an exit and return values from the loop."

  `(DO ($WHILE$) ((NOT ,PRED) $WHILE$) 
    (SETQ $WHILE$
          (PROGN . ,BODY))))

(DefStruct (tnode :named
	   (:print "#<Node: name=~s count=~s>"
		   (node-name tnode) (node-count tnode)))
	    (node-name nil)
	    (node-count 0))



(DefMacro i-th(tree n)
  `(aref ,tree (sub1 ,n)))

(DefMacro root(tree)
  `(i-th ,tree 1))

(DefMacro node_count (tree i)
  `(node-count (i-th ,tree ,i)))

(DefMacro node_name (tree i)
  `(node-name (i-th ,tree ,i)))

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

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

  (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*(

	  (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)))

;;;
;;;miscellaneous node "pointers"
;;;					
	  (n-nodes  (the integer (sub1 (times n 2))))
	  (twotomax (the integer 1))
	  (p	(the integer 0))
	  (q	(the integer 0))

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

	 )

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

	  (do-for (inx 1 n-nodes)
	    (setf (i-th tree inx) (make-tnode)))
	  
	  (setq twotomax 1)
	  (while
	    (lessp twotomax n)		;finding a power of 2 >n
	      (setq twotomax (times twotomax 2)))

	  (print 'loop-1-assign-names-and-counts-upper)
	  (do-for (i twotomax n-nodes)
	    (setf (node_name tree i) (car names))
	    (setf (node_count tree i) 1)
	    (setq names (cdr names)))

	  (print 'loop-2-assign-names-and-counts-lower)
	  (do-for (i n (sub1 twotomax))
	    (setf (node_name tree i) (car names))
	    (setf (node_count tree i) 1)
	    (setq names (cdr names)))

	  (print 'loop-1-init-remaining-countsp)
	  (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))))))
	  
	  (let*(
		(p (the integer 1))
		(remains (the integer
			      (add1
				(mod
				  (sub1 n)
				  (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)))

		(format t "~%Eliminated ~a.~%" (node_name tree p))

		(let(
		     (q (the integer p))
		    )
		  (while
		    (not (zerop q))
		      (if (= 1 (decf (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 n)
		(unless (oddp n) (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
     )))