1;;; hanoi.el --- towers of hanoi in Emacs 2 3;; Author: Damon Anton Permezel 4;; Maintainer: FSF 5;; Keywords: games 6 7; Author (a) 1985, Damon Anton Permezel 8; This is in the public domain 9; since he distributed it without copyright notice in 1985. 10;; This file is part of GNU Emacs. 11; 12; Support for horizontal poles, large numbers of rings, real-time, 13; faces, defcustom, and Towers of Unix added in 1999 by Alakazam 14; Petrofsky <Alakazam@Petrofsky.Berkeley.CA.US>. 15 16;;; Commentary: 17 18;; Solves the Towers of Hanoi puzzle while-U-wait. 19;; 20;; The puzzle: Start with N rings, decreasing in sizes from bottom to 21;; top, stacked around a post. There are two other posts. Your mission, 22;; should you choose to accept it, is to shift the pile, stacked in its 23;; original order, to another post. 24;; 25;; The challenge is to do it in the fewest possible moves. Each move 26;; shifts one ring to a different post. But there's a rule; you can 27;; only stack a ring on top of a larger one. 28;; 29;; The simplest nontrivial version of this puzzle is N = 3. Solution 30;; time rises as 2**N, and programs to solve it have long been considered 31;; classic introductory exercises in the use of recursion. 32;; 33;; The puzzle is called `Towers of Hanoi' because an early popular 34;; presentation wove a fanciful legend around it. According to this 35;; myth (uttered long before the Vietnam War), there is a Buddhist 36;; monastery at Hanoi which contains a large room with three time-worn 37;; posts in it surrounded by 21 golden discs. Monks, acting out the 38;; command of an ancient prophecy, have been moving these disks, in 39;; accordance with the rules of the puzzle, once every day since the 40;; monastery was founded over a thousand years ago. They are said to 41;; believe that when the last move of the puzzle is completed, the 42;; world will end in a clap of thunder. Fortunately, they are nowhere 43;; even close to being done... 44;; 45;; 1999 addition: The `Towers of Unix' command (hanoi-unix) stems from 46;; the never-disproven legend of a Eunuch monastery at Princeton that 47;; contains a large air-conditioned room with three time-worn posts in 48;; it surrounded by 32 silicon discs. Nimble monks, acting out the 49;; command of an ancient prophecy, have been moving these disks, in 50;; accordance with the rules of the puzzle, once every second since 51;; the monastery was founded almost a billion seconds ago. They are 52;; said to believe that when the last move of the puzzle is completed, 53;; the world will reboot in a clap of thunder. Actually, because the 54;; bottom disc is blocked by the "Do not feed the monks" sign, it is 55;; believed the End will come at the time that disc is to be moved... 56 57;;; Code: 58 59(eval-when-compile 60 (require 'cl) 61 ;; dynamic bondage: 62 (defvar baseward-step) 63 (defvar fly-step) 64 (defvar fly-row-start) 65 (defvar pole-width) 66 (defvar pole-char) 67 (defvar line-offset)) 68 69(defgroup hanoi nil 70 "The Towers of Hanoi." 71 :group 'games) 72 73(defcustom hanoi-horizontal-flag nil 74 "*If non-nil, hanoi poles are oriented horizontally." 75 :group 'hanoi :type 'boolean) 76 77(defcustom hanoi-move-period 1.0 78 "*Time, in seconds, for each pole-to-pole move of a ring. 79If nil, move rings as fast as possible while displaying all 80intermediate positions." 81 :group 'hanoi :type '(restricted-sexp :match-alternatives (numberp 'nil))) 82 83(defcustom hanoi-use-faces nil 84 "*If nil, all hanoi-*-face variables are ignored." 85 :group 'hanoi :type 'boolean) 86 87(defcustom hanoi-pole-face 'highlight 88 "*Face for poles. Ignored if hanoi-use-faces is nil." 89 :group 'hanoi :type 'face) 90 91(defcustom hanoi-base-face 'highlight 92 "*Face for base. Ignored if hanoi-use-faces is nil." 93 :group 'hanoi :type 'face) 94 95(defcustom hanoi-even-ring-face 'region 96 "*Face for even-numbered rings. Ignored if hanoi-use-faces is nil." 97 :group 'hanoi :type 'face) 98 99(defcustom hanoi-odd-ring-face 'secondary-selection 100 "*Face for odd-numbered rings. Ignored if hanoi-use-faces is nil." 101 :group 'hanoi :type 'face) 102 103 104;;; 105;;; hanoi - user callable Towers of Hanoi 106;;; 107;;;###autoload 108(defun hanoi (nrings) 109 "Towers of Hanoi diversion. Use NRINGS rings." 110 (interactive 111 (list (if (null current-prefix-arg) 112 3 113 (prefix-numeric-value current-prefix-arg)))) 114 (if (< nrings 0) 115 (error "Negative number of rings")) 116 (hanoi-internal nrings (make-list nrings 0) (hanoi-current-time-float))) 117 118;;;###autoload 119(defun hanoi-unix () 120 "Towers of Hanoi, UNIX doomsday version. 121Displays 32-ring towers that have been progressing at one move per 122second since 1970-01-01 00:00:00 GMT. 123 124Repent before ring 31 moves." 125 (interactive) 126 (let* ((start (ftruncate (hanoi-current-time-float))) 127 (bits (loop repeat 32 128 for x = (/ start (expt 2.0 31)) then (* x 2.0) 129 collect (truncate (mod x 2.0)))) 130 (hanoi-move-period 1.0)) 131 (hanoi-internal 32 bits start))) 132 133;;;###autoload 134(defun hanoi-unix-64 () 135 "Like hanoi-unix, but pretend to have a 64-bit clock. 136This is, necessarily (as of Emacs 20.3), a crock. When the 137current-time interface is made s2G-compliant, hanoi.el will need 138to be updated." 139 (interactive) 140 (let* ((start (ftruncate (hanoi-current-time-float))) 141 (bits (loop repeat 64 142 for x = (/ start (expt 2.0 63)) then (* x 2.0) 143 collect (truncate (mod x 2.0)))) 144 (hanoi-move-period 1.0)) 145 (hanoi-internal 64 bits start))) 146 147(defun hanoi-internal (nrings bits start-time) 148 "Towers of Hanoi internal interface. Use NRINGS rings. 149Start after n steps, where BITS is a big-endian list of the bits of n. 150BITS must be of length nrings. Start at START-TIME." 151 (switch-to-buffer "*Hanoi*") 152 (buffer-disable-undo (current-buffer)) 153 (unwind-protect 154 (let* 155 (;; These lines can cause Emacs to crash if you ask for too 156 ;; many rings. If you uncomment them, on most systems you 157 ;; can get 10,000+ rings. 158 ;;(max-specpdl-size (max max-specpdl-size (* nrings 15))) 159 ;;(max-lisp-eval-depth (max max-lisp-eval-depth (+ nrings 20))) 160 (vert (not hanoi-horizontal-flag)) 161 (pole-width (length (format "%d" (max 0 (1- nrings))))) 162 (pole-char (if vert ?\| ?\-)) 163 (base-char (if vert ?\= ?\|)) 164 (base-len (max (+ 8 (* pole-width 3)) 165 (1- (if vert (window-width) (window-height))))) 166 (max-ring-diameter (/ (- base-len 2) 3)) 167 (pole1-coord (/ max-ring-diameter 2)) 168 (pole2-coord (/ base-len 2)) 169 (pole3-coord (- base-len (/ (1+ max-ring-diameter) 2))) 170 (pole-coords (list pole1-coord pole2-coord pole3-coord)) 171 ;; Number of lines displayed below the bottom-most rings. 172 (base-lines 173 (min 3 (max 0 (- (1- (if vert (window-height) (window-width))) 174 (+ 2 nrings))))) 175 176 ;; These variables will be set according to hanoi-horizontal-flag: 177 178 ;; line-offset is the number of characters per line in the buffer. 179 line-offset 180 ;; fly-row-start is the buffer position of the leftmost or 181 ;; uppermost position in the fly row. 182 fly-row-start 183 ;; Adding fly-step to a buffer position moves you one step 184 ;; along the fly row in the direction from pole1 to pole2. 185 fly-step 186 ;; Adding baseward-step to a buffer position moves you one step 187 ;; toward the base. 188 baseward-step 189 ) 190 (setq buffer-read-only nil) 191 (erase-buffer) 192 (setq truncate-lines t) 193 (if hanoi-horizontal-flag 194 (progn 195 (setq line-offset (+ base-lines nrings 3)) 196 (setq fly-row-start (1- line-offset)) 197 (setq fly-step line-offset) 198 (setq baseward-step -1) 199 (loop repeat base-len do 200 (unless (zerop base-lines) 201 (insert-char ?\ (1- base-lines)) 202 (insert base-char) 203 (hanoi-put-face (1- (point)) (point) hanoi-base-face)) 204 (insert-char ?\ (+ 2 nrings)) 205 (insert ?\n)) 206 (delete-char -1) 207 (loop for coord in pole-coords do 208 (loop for row from (- coord (/ pole-width 2)) 209 for start = (+ (* row line-offset) base-lines 1) 210 repeat pole-width do 211 (subst-char-in-region start (+ start nrings 1) 212 ?\ pole-char) 213 (hanoi-put-face start (+ start nrings 1) 214 hanoi-pole-face)))) 215 ;; vertical 216 (setq line-offset (1+ base-len)) 217 (setq fly-step 1) 218 (setq baseward-step line-offset) 219 (let ((extra-lines (- (1- (window-height)) (+ nrings 2) base-lines))) 220 (insert-char ?\n (max 0 extra-lines)) 221 (setq fly-row-start (point)) 222 (insert-char ?\ base-len) 223 (insert ?\n) 224 (loop repeat (1+ nrings) 225 with pole-line = 226 (loop with line = (make-string base-len ?\ ) 227 for coord in pole-coords 228 for start = (- coord (/ pole-width 2)) 229 for end = (+ start pole-width) do 230 (hanoi-put-face start end hanoi-pole-face line) 231 (loop for i from start below end do 232 (aset line i pole-char)) 233 finally return line) 234 do (insert pole-line ?\n)) 235 (insert-char base-char base-len) 236 (hanoi-put-face (- (point) base-len) (point) hanoi-base-face) 237 (set-window-start (selected-window) 238 (1+ (* baseward-step 239 (max 0 (- extra-lines))))))) 240 241 (let 242 (;; each pole is a pair of buffer positions: 243 ;; the car is the position of the top ring currently on the pole, 244 ;; (or the base of the pole if it is empty). 245 ;; the cdr is in the fly-row just above the pole. 246 (poles (loop for coord in pole-coords 247 for fly-pos = (+ fly-row-start (* fly-step coord)) 248 for base = (+ fly-pos (* baseward-step (+ 2 nrings))) 249 collect (cons base fly-pos))) 250 ;; compute the string for each ring and make the list of 251 ;; ring pairs. Each ring pair is initially (str . diameter). 252 ;; Once placed in buffer it is changed to (center-pos . diameter). 253 (rings 254 (loop 255 ;; radii are measured from the edge of the pole out. 256 ;; So diameter = 2 * radius + pole-width. When 257 ;; there's room, we make each ring's radius = 258 ;; pole-number + 1. If there isn't room, we step 259 ;; evenly from the max radius down to 1. 260 with max-radius = (min nrings 261 (/ (- max-ring-diameter pole-width) 2)) 262 for n from (1- nrings) downto 0 263 for radius = (1+ (/ (* n max-radius) nrings)) 264 for diameter = (+ pole-width (* 2 radius)) 265 with format-str = (format "%%0%dd" pole-width) 266 for str = (concat (if vert "<" "^") 267 (make-string (1- radius) (if vert ?\- ?\|)) 268 (format format-str n) 269 (make-string (1- radius) (if vert ?\- ?\|)) 270 (if vert ">" "v")) 271 for face = 272 (if (eq (logand n 1) 1) ; oddp would require cl at runtime 273 hanoi-odd-ring-face hanoi-even-ring-face) 274 do (hanoi-put-face 0 (length str) face str) 275 collect (cons str diameter))) 276 ;; Disable display of line and column numbers, for speed. 277 (line-number-mode nil) (column-number-mode nil)) 278 ;; do it! 279 (hanoi-n bits rings (car poles) (cadr poles) (caddr poles) 280 start-time)) 281 (message "Done")) 282 (setq buffer-read-only t) 283 (force-mode-line-update))) 284 285(defun hanoi-current-time-float () 286 "Return values from current-time combined into a single float." 287 (destructuring-bind (high low micros) (current-time) 288 (+ (* high 65536.0) low (/ micros 1000000.0)))) 289 290(defun hanoi-put-face (start end value &optional object) 291 "If hanoi-use-faces is non-nil, call put-text-property for face property." 292 (if hanoi-use-faces 293 (put-text-property start end 'face value object))) 294 295 296;;; Functions with a start-time argument (hanoi-0, hanoi-n, and 297;;; hanoi-move-ring) start working at start-time and return the ending 298;;; time. If hanoi-move-period is nil, start-time is ignored and the 299;;; return value is junk. 300 301;;; 302;;; hanoi-0 - work horse of hanoi 303(defun hanoi-0 (rings from to work start-time) 304 (if (null rings) 305 start-time 306 (hanoi-0 (cdr rings) work to from 307 (hanoi-move-ring (car rings) from to 308 (hanoi-0 (cdr rings) from work to start-time))))) 309 310;; start after n moves, where BITS is a big-endian list of the bits of n. 311;; BITS must be of same length as rings. 312(defun hanoi-n (bits rings from to work start-time) 313 (cond ((null rings) 314 ;; All rings have been placed in starting positions. Update display. 315 (hanoi-sit-for 0) 316 start-time) 317 ((zerop (car bits)) 318 (hanoi-insert-ring (car rings) from) 319 (hanoi-0 (cdr rings) work to from 320 (hanoi-move-ring (car rings) from to 321 (hanoi-n (cdr bits) (cdr rings) from work to 322 start-time)))) 323 (t 324 (hanoi-insert-ring (car rings) to) 325 (hanoi-n (cdr bits) (cdr rings) work to from start-time)))) 326 327;; put never-before-placed RING on POLE and update their cars. 328(defun hanoi-insert-ring (ring pole) 329 (decf (car pole) baseward-step) 330 (let ((str (car ring)) 331 (start (- (car pole) (* (/ (cdr ring) 2) fly-step)))) 332 (setcar ring (car pole)) 333 (loop for pos upfrom start by fly-step 334 for i below (cdr ring) do 335 (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) 336 (set-text-properties pos (1+ pos) (text-properties-at i str))) 337 (hanoi-goto-char (car pole)))) 338 339;; like goto-char, but if position is outside the window, then move to 340;; corresponding position in the first row displayed. 341(defun hanoi-goto-char (pos) 342 (goto-char (if (or hanoi-horizontal-flag (<= (window-start) pos)) 343 pos 344 (+ (window-start) (% (- pos fly-row-start) baseward-step))))) 345 346;; do one pole-to-pole move and update the ring and pole pairs. 347(defun hanoi-move-ring (ring from to start-time) 348 (incf (car from) baseward-step) 349 (decf (car to) baseward-step) 350 (let* ;; We move flywards-steps steps up the pole to the fly row, 351 ;; then fly fly-steps steps across the fly row, then go 352 ;; baseward-steps steps down the new pole. 353 ((flyward-steps (/ (- (car ring) (cdr from)) baseward-step)) 354 (fly-steps (abs (/ (- (cdr to) (cdr from)) fly-step))) 355 (directed-fly-step (/ (- (cdr to) (cdr from)) fly-steps)) 356 (baseward-steps (/ (- (car to) (cdr to)) baseward-step)) 357 (total-steps (+ flyward-steps fly-steps baseward-steps)) 358 ;; A step is a character cell. A tick is a time-unit. To 359 ;; make horizontal and vertical motion appear roughly the 360 ;; same speed, we allow one tick per horizontal step and two 361 ;; ticks per vertical step. 362 (ticks-per-pole-step (if hanoi-horizontal-flag 1 2)) 363 (ticks-per-fly-step (if hanoi-horizontal-flag 2 1)) 364 (flyward-ticks (* ticks-per-pole-step flyward-steps)) 365 (fly-ticks (* ticks-per-fly-step fly-steps)) 366 (baseward-ticks (* ticks-per-pole-step baseward-steps)) 367 (total-ticks (+ flyward-ticks fly-ticks baseward-ticks)) 368 (tick-to-pos 369 ;; Return the buffer position of the ring after TICK ticks. 370 (lambda (tick) 371 (cond 372 ((<= tick flyward-ticks) 373 (+ (cdr from) 374 (* baseward-step 375 (- flyward-steps (/ tick ticks-per-pole-step))))) 376 ((<= tick (+ flyward-ticks fly-ticks)) 377 (+ (cdr from) 378 (* directed-fly-step 379 (/ (- tick flyward-ticks) ticks-per-fly-step)))) 380 (t 381 (+ (cdr to) 382 (* baseward-step 383 (/ (- tick flyward-ticks fly-ticks) 384 ticks-per-pole-step)))))))) 385 (if hanoi-move-period 386 (loop for elapsed = (- (hanoi-current-time-float) start-time) 387 while (< elapsed hanoi-move-period) 388 with tick-period = (/ (float hanoi-move-period) total-ticks) 389 for tick = (ceiling (/ elapsed tick-period)) do 390 (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) 391 (hanoi-sit-for (- (* tick tick-period) elapsed))) 392 (loop for tick from 1 to total-ticks by 2 do 393 (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) 394 (hanoi-sit-for 0))) 395 ;; Always make last move to keep pole and ring data consistent 396 (hanoi-ring-to-pos ring (car to)) 397 (if hanoi-move-period (+ start-time hanoi-move-period)))) 398 399;; update display and pause, quitting with a pithy comment if the user 400;; hits a key. 401(defun hanoi-sit-for (seconds) 402 (unless (sit-for seconds) 403 (signal 'quit '("I can tell you've had enough")))) 404 405;; move ring to a given buffer position and update ring's car. 406(defun hanoi-ring-to-pos (ring pos) 407 (unless (= (car ring) pos) 408 (let* ((start (- (car ring) (* (/ (cdr ring) 2) fly-step))) 409 (new-start (- pos (- (car ring) start)))) 410 (if hanoi-horizontal-flag 411 (loop for i below (cdr ring) 412 for j = (if (< new-start start) i (- (cdr ring) i 1)) 413 for old-pos = (+ start (* j fly-step)) 414 for new-pos = (+ new-start (* j fly-step)) do 415 (transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos))) 416 (let ((end (+ start (cdr ring))) 417 (new-end (+ new-start (cdr ring)))) 418 (if (< (abs (- new-start start)) (- end start)) 419 ;; Overlap. Adjust bounds 420 (if (< start new-start) 421 (setq new-start end) 422 (setq new-end start))) 423 (transpose-regions start end new-start new-end t)))) 424 ;; If moved on or off a pole, redraw pole chars. 425 (unless (eq (hanoi-pos-on-tower-p (car ring)) (hanoi-pos-on-tower-p pos)) 426 (let* ((pole-start (- (car ring) (* fly-step (/ pole-width 2)))) 427 (pole-end (+ pole-start (* fly-step pole-width))) 428 (on-pole (hanoi-pos-on-tower-p (car ring))) 429 (new-char (if on-pole pole-char ?\ )) 430 (curr-char (if on-pole ?\ pole-char)) 431 (face (if on-pole hanoi-pole-face nil))) 432 (if hanoi-horizontal-flag 433 (loop for pos from pole-start below pole-end by line-offset do 434 (subst-char-in-region pos (1+ pos) curr-char new-char) 435 (hanoi-put-face pos (1+ pos) face)) 436 (subst-char-in-region pole-start pole-end curr-char new-char) 437 (hanoi-put-face pole-start pole-end face)))) 438 (setcar ring pos)) 439 (hanoi-goto-char pos)) 440 441;; Check if a buffer position lies on a tower (vis. in the fly row). 442(defun hanoi-pos-on-tower-p (pos) 443 (if hanoi-horizontal-flag 444 (/= (% pos fly-step) fly-row-start) 445 (>= pos (+ fly-row-start baseward-step)))) 446 447(provide 'hanoi) 448 449;;; arch-tag: 7a901659-4346-495c-8883-14cbf540610c 450;;; hanoi.el ends here 451