;;; ---------------------------------------------------------------------------
;;; TowerHanoi.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; TOWER OF HANOI, BUILT AND SOLVED IN 3D
;;;
;;; PURPOSE
;;;   Builds the puzzle as real geometry - a base, three posts and a stack of
;;;   discs - and then solves it in front of you, one move at a time.
;;;
;;;   The rules, unchanged since Lucas set the puzzle in 1883:
;;;     1. Only one disc moves at a time.
;;;     2. No disc may rest on a smaller one.
;;;
;;;   The legend has monks moving sixty-four discs, the world ending when they
;;;   finish. The arithmetic is the interesting part: n discs take 2^n - 1 moves,
;;;   so ten discs is a thousand moves and twenty is a million. Sixty-four, at
;;;   one move a second, is about 585 billion years. The legend is safe.
;;;
;;; HOW THE SOLVER WORKS
;;;   To move n discs from A to C: move the top n-1 to B, move the bottom one to
;;;   C, then move the n-1 from B to C. Three lines, and it is optimal - no
;;;   shorter solution exists. Recursion rarely looks better than this.
;;;
;;; WHAT WAS FIXED
;;;   - The layers were set up with (command "layer" "new" "..." "colour" 7 ...)
;;;     and later (command "colour" a a). AutoCAD's option word is Color, not
;;;     Colour, so every one of those failed and the discs came out monochrome
;;;     at best.
;;;   - Discs were removed with (command "erase" <point> "") - an ERASE by
;;;     picking a computed screen coordinate. Anything else near that point went
;;;     instead. Discs are now created with ENTMAKE, held by entity name, and
;;;     MOVED rather than erased and redrawn, which is both correct and much
;;;     faster.
;;;   - Tidying up between runs was done by erasing the last N objects drawn,
;;;     N being remembered in a global from the previous run. If you had drawn
;;;     anything in between, that is what got erased. The puzzle now knows its
;;;     own objects and removes exactly those.
;;;   - Every variable was global, including single letters a, b, d, i, l and r.
;;;   - BLIPMODE, CMDECHO and FILLMODE were set and never put back.
;;;
;;;   HANOI       - build the puzzle
;;;   HANOISOLVE  - solve it, one move at a time
;;; ---------------------------------------------------------------------------

;;; ---------------------------------------------------------------------------
;;; STATE
;;;
;;; The puzzle is built by one command and solved by another, so what they share
;;; has to outlive both. Each post is a list of discs, smallest first, and each
;;; disc is (radius . entity-name).
;;; ---------------------------------------------------------------------------

(setq *Hanoi:Posts* nil    ; three lists of discs, top of stack first
      *Hanoi:Geom*  nil    ; (baseZ  spacing  postY  (x1 x2 x3))
      *Hanoi:Built* nil    ; every object drawn, so it can be cleared
      *Hanoi:Moves* 0)

(setq Hanoi:DISCTHICK  1.0
      Hanoi:SMALLEST   1.5
      Hanoi:INCREMENT  1.0
      Hanoi:POSTDIA    1.0
      Hanoi:BASETHICK  1.0
      Hanoi:AIRSPACE   0.1)

;;; Layer per disc, cycling through six colours so neighbouring discs differ.
(defun Hanoi:DiscLayer ( i / name )
    (setq name (strcat "Hanoi-Disc" (itoa (1+ (rem i 6)))))
    (if (not (tblsearch "LAYER" name))
        (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbLayerTableRecord") (cons 2 name)
                       '(70 . 0) (cons 62 (1+ (rem i 6))) '(6 . "Continuous"))))
    name
)

(defun Hanoi:Layer ( name colour )
    (if (not (tblsearch "LAYER" name))
        (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbLayerTableRecord") (cons 2 name)
                       '(70 . 0) (cons 62 colour) '(6 . "Continuous"))))
    name
)

;;; A circle with thickness - which in AutoCAD is a cylinder. The centre's Z
;;; sets the bottom, the thickness sets the height.
(defun Hanoi:Cylinder ( x y z rad thick layer )
    (entmake (list '(0 . "CIRCLE") (cons 8 layer)
                   (cons 10 (list x y z)) (cons 40 rad) (cons 39 thick)))
    (entlast)
)

;;; ---------------------------------------------------------------------------
;;; MOVING A DISC
;;;
;;; The whole solver rests on this. Take the top disc off one post and put it on
;;; another, which means editing the entity's centre point and moving the record
;;; between the two lists.
;;; ---------------------------------------------------------------------------

(defun Hanoi:MoveDisc ( from to / src dst disc data z )
    (setq src  (nth (1- from) *Hanoi:Posts*)
          dst  (nth (1- to)   *Hanoi:Posts*)
          disc (car src))

    (if (null disc)
        (princ (strcat "\n** No disc on post " (itoa from) ". **"))
        (progn
            ;; The new height is set by how many discs are already waiting.
            (setq z (+ (car *Hanoi:Geom*)
                       (* (length dst) (cadr *Hanoi:Geom*)))
                  data (entget (cdr disc)))

            (entmod (subst (cons 10 (list (nth (1- to) (cadddr *Hanoi:Geom*))
                                          (caddr *Hanoi:Geom*)
                                          z))
                           (assoc 10 data) data))

            ;; Update the two stacks.
            (setq *Hanoi:Posts*
                (mapcar
                    '(lambda ( p i )
                        (cond ((= i from) (cdr p))
                              ((= i to)   (cons disc p))
                              (t p)))
                    *Hanoi:Posts* '(1 2 3)))

            (setq *Hanoi:Moves* (1+ *Hanoi:Moves*))
            (redraw (cdr disc))))
    (princ)
)

;;; The solver. To shift N discs from one post to another, first shift the N-1
;;; above onto the post you are not using, then the bottom disc across, then the
;;; N-1 back on top of it.
(defun Hanoi:Transfer ( from to spare n )
    (if (= n 1)
        (Hanoi:MoveDisc from to)
        (progn
            (Hanoi:Transfer from spare to (1- n))
            (Hanoi:MoveDisc from to)
            (Hanoi:Transfer spare to from (1- n))))
)

;;; ---------------------------------------------------------------------------
;;; BUILDING
;;; ---------------------------------------------------------------------------

(defun c:HANOI ( / *error* vars vals n org lring spacing baseW baseD
                   postX postY z rad i lay e )

    (setq vars '("CMDECHO" "BLIPMODE" "FILLMODE" "CLAYER" "OSMODE")
          vals (mapcar 'getvar vars))

    (defun Hanoi:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (Hanoi:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** HANOI error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setvar "BLIPMODE" 0)
    (setvar "OSMODE" 0)
    ;; AutoCAD 2015 and later refuse (command) inside an *error* handler unless
    ;; the routine says up front that it will use one.
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    ;; Clear a previous puzzle - by entity name, not by guessing.
    (if *Hanoi:Built*
        (progn
            (foreach ent *Hanoi:Built*
                (if (and ent (entget ent)) (entdel ent)))
            (setq *Hanoi:Built* nil)))

    (initget 6)
    (setq n (getint "\nHow many discs <5>: "))
    (if (null n) (setq n 5))
    (if (> n 14)
        (progn (princ "\n  Fourteen is plenty - that is already 16383 moves.")
               (setq n 14)))

    (setq org (getpoint "\nWhere to build it: "))

    (if (null org)
        (princ "\nCancelled.")
        (progn
            ;; Flattened to Z zero. The puzzle is built upward from the picked
            ;; point, and letting it start at some arbitrary height only makes
            ;; the base and the posts disagree about where the floor is.
            (setq org (list (car org) (cadr org) 0.0))

            (setq lring   (+ Hanoi:SMALLEST (* n Hanoi:INCREMENT))
                  spacing (+ Hanoi:DISCTHICK Hanoi:AIRSPACE)
                  postY   (+ (car (cdr org)) Hanoi:POSTDIA (/ lring 2.0))
                  baseW   (+ (* 3.0 (+ Hanoi:POSTDIA lring)) Hanoi:POSTDIA)
                  baseD   (+ lring (* Hanoi:POSTDIA 2.0))
                  postX   (list (+ (car org) Hanoi:POSTDIA (/ lring 2.0))
                                (+ (car org) Hanoi:POSTDIA (/ lring 2.0)
                                   (+ Hanoi:POSTDIA lring))
                                (+ (car org) Hanoi:POSTDIA (/ lring 2.0)
                                   (* 2.0 (+ Hanoi:POSTDIA lring))))
                  z       (+ Hanoi:BASETHICK Hanoi:AIRSPACE))

            ;; --- the base ---------------------------------------------------
            (setq lay (Hanoi:Layer "Hanoi-Base" 7))
            (entmake (list '(0 . "SOLID") (cons 8 lay)
                           (cons 39 Hanoi:BASETHICK)
                           (cons 10 (list (car org) (cadr org) 0.0))
                           (cons 11 (list (+ (car org) baseW) (cadr org) 0.0))
                           (cons 12 (list (car org) (+ (cadr org) baseD) 0.0))
                           (cons 13 (list (+ (car org) baseW)
                                          (+ (cadr org) baseD) 0.0))))
            (setq *Hanoi:Built* (list (entlast)))

            ;; --- the three posts --------------------------------------------
            (setq lay (Hanoi:Layer "Hanoi-Post" 8))
            (foreach x postX
                (setq e (Hanoi:Cylinder x postY Hanoi:BASETHICK
                            (/ Hanoi:POSTDIA 2.0)
                            (* spacing (1+ n)) lay)
                      *Hanoi:Built* (cons e *Hanoi:Built*)))

            ;; --- the discs, largest at the bottom ---------------------------
            ;; Built bottom up, so the list ends with the smallest at its head -
            ;; which is what the solver expects.
            (setq rad (/ lring 2.0) i 0 *Hanoi:Posts* (list nil nil nil))
            (while (< i n)
                (setq lay (Hanoi:DiscLayer i)
                      e   (Hanoi:Cylinder (car postX) postY (+ z (* i spacing))
                                          rad Hanoi:DISCTHICK lay))
                (setq *Hanoi:Posts* (list (cons (cons rad e) (car *Hanoi:Posts*))
                                          nil nil)
                      *Hanoi:Built* (cons e *Hanoi:Built*)
                      rad (- rad (/ Hanoi:INCREMENT 2.0))
                      i   (1+ i)))

            (setq *Hanoi:Geom* (list z spacing postY postX)
                  *Hanoi:Moves* 0)

            (command "_.ZOOM" "_Extents")
            (princ (strcat "\n" (itoa n) " discs built. The solution takes "
                           (itoa (1- (fix (expt 2.0 n)))) " moves."
                           "\nType HANOISOLVE to watch it."))
        )
    )

    (Hanoi:Restore)
    (princ)
)

;;; ---------------------------------------------------------------------------
;;; SOLVING
;;; ---------------------------------------------------------------------------

(defun c:HANOISOLVE ( / *error* vars vals n )

    (setq vars '("CMDECHO" "BLIPMODE")
          vals (mapcar 'getvar vars))

    (defun Hanoi:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl))) (command "_.UNDO" "_End"))
        (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        (princ)
    )

    (defun *error* ( msg )
        (Hanoi:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** HANOISOLVE error: " msg " **")))
        (princ)
    )

    (setvar "CMDECHO" 0)
    (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
    (command "_.UNDO" "_Begin")

    (if (null *Hanoi:Posts*)
        (princ "\nNothing built yet - run HANOI first.")
        (progn
            (setq n (length (car *Hanoi:Posts*)))
            (if (zerop n)
                (princ "\nThe first post is empty - run HANOI to set it up again.")
                (progn
                    (setq *Hanoi:Moves* 0)
                    (princ (strcat "\nSolving " (itoa n) " discs - "
                                   (itoa (1- (fix (expt 2.0 n)))) " moves."))
                    (Hanoi:Transfer 1 3 2 n)
                    (command "_.REGEN")
                    (princ (strcat "\nDone in " (itoa *Hanoi:Moves*)
                                   " moves, which is the fewest possible.")))))
    )

    (Hanoi:Restore)
    (princ)
)

(princ)