1 ;;; hanoi.el --- towers of hanoi in Emacs
3 ;; Author: Damon Anton Permezel
7 ; Author (a) 1985, Damon Anton Permezel
8 ; This is in the public domain
9 ; since he distributed it without copyright notice in 1985.
11 ; Support for horizontal poles, large numbers of rings, real-time,
12 ; faces, defcustom, and Towers of Unix added in 1999 by Alakazam
13 ; Petrofsky <Alakazam@Petrofsky.Berkeley.CA.US>.
17 ;; Solves the Towers of Hanoi puzzle while-U-wait.
19 ;; The puzzle: Start with N rings, decreasing in sizes from bottom to
20 ;; top, stacked around a post. There are two other posts. Your mission,
21 ;; should you choose to accept it, is to shift the pile, stacked in its
22 ;; original order, to another post.
24 ;; The challenge is to do it in the fewest possible moves. Each move
25 ;; shifts one ring to a different post. But there's a rule; you can
26 ;; only stack a ring on top of a larger one.
28 ;; The simplest nontrivial version of this puzzle is N = 3. Solution
29 ;; time rises as 2**N, and programs to solve it have long been considered
30 ;; classic introductory exercises in the use of recursion.
32 ;; The puzzle is called `Towers of Hanoi' because an early popular
33 ;; presentation wove a fanciful legend around it. According to this
34 ;; myth (uttered long before the Vietnam War), there is a Buddhist
35 ;; monastery at Hanoi which contains a large room with three time-worn
36 ;; posts in it surrounded by 21 golden discs. Monks, acting out the
37 ;; command of an ancient prophecy, have been moving these disks, in
38 ;; accordance with the rules of the puzzle, once every day since the
39 ;; monastery was founded over a thousand years ago. They are said to
40 ;; believe that when the last move of the puzzle is completed, the
41 ;; world will end in a clap of thunder. Fortunately, they are nowhere
42 ;; even close to being done...
44 ;; 1999 addition: The `Towers of Unix' command (hanoi-unix) stems from
45 ;; the never-disproven legend of a Eunuch monastery at Princeton that
46 ;; contains a large air-conditioned room with three time-worn posts in
47 ;; it surrounded by 32 silicon discs. Nimble monks, acting out the
48 ;; command of an ancient prophecy, have been moving these disks, in
49 ;; accordance with the rules of the puzzle, once every second since
50 ;; the monastery was founded almost a billion seconds ago. They are
51 ;; said to believe that when the last move of the puzzle is completed,
52 ;; the world will reboot in a clap of thunder. Actually, because the
53 ;; bottom disc is blocked by the "Do not feed the monks" sign, it is
54 ;; believed the End will come at the time that disc is to be moved...
61 (defvar baseward-step
)
63 (defvar fly-row-start
)
69 "The Towers of Hanoi."
72 (defcustom hanoi-horizontal-flag nil
73 "*If non-nil, hanoi poles are oriented horizontally."
74 :group
'hanoi
:type
'boolean
)
76 (defcustom hanoi-move-period
1.0
77 "*Time, in seconds, for each pole-to-pole move of a ring.
78 If nil, move rings as fast as possible while displaying all
79 intermediate positions."
80 :group
'hanoi
:type
'(restricted-sexp :match-alternatives
(numberp 'nil
)))
82 (defcustom hanoi-use-faces nil
83 "*If nil, all hanoi-*-face variables are ignored."
84 :group
'hanoi
:type
'boolean
)
86 (defcustom hanoi-pole-face
'highlight
87 "*Face for poles. Ignored if hanoi-use-faces is nil."
88 :group
'hanoi
:type
'face
)
90 (defcustom hanoi-base-face
'highlight
91 "*Face for base. Ignored if hanoi-use-faces is nil."
92 :group
'hanoi
:type
'face
)
94 (defcustom hanoi-even-ring-face
'region
95 "*Face for even-numbered rings. Ignored if hanoi-use-faces is nil."
96 :group
'hanoi
:type
'face
)
98 (defcustom hanoi-odd-ring-face
'secondary-selection
99 "*Face for odd-numbered rings. Ignored if hanoi-use-faces is nil."
100 :group
'hanoi
:type
'face
)
104 ;;; hanoi - user callable Towers of Hanoi
107 (defun hanoi (nrings)
108 "Towers of Hanoi diversion. Use NRINGS rings."
110 (list (if (null current-prefix-arg
)
112 (prefix-numeric-value current-prefix-arg
))))
114 (error "Negative number of rings"))
115 (hanoi-internal nrings
(make-list nrings
0) (hanoi-current-time-float)))
119 "Towers of Hanoi, UNIX doomsday version.
120 Displays 32-ring towers that have been progressing at one move per
121 second since 1970-01-01 00:00:00 GMT.
123 Repent before ring 31 moves."
125 (let* ((start (ftruncate (hanoi-current-time-float)))
126 (bits (loop repeat
32
127 for x
= (/ start
(expt 2.0 31)) then
(* x
2.0)
128 collect
(truncate (mod x
2.0))))
129 (hanoi-move-period 1.0))
130 (hanoi-internal 32 bits start
)))
133 (defun hanoi-unix-64 ()
134 "Like hanoi-unix, but pretend to have a 64-bit clock.
135 This is, necessarily (as of emacs 20.3), a crock. When the
136 current-time interface is made s2G-compliant, hanoi.el will need
139 (let* ((start (ftruncate (hanoi-current-time-float)))
140 (bits (loop repeat
64
141 for x
= (/ start
(expt 2.0 63)) then
(* x
2.0)
142 collect
(truncate (mod x
2.0))))
143 (hanoi-move-period 1.0))
144 (hanoi-internal 64 bits start
)))
146 (defun hanoi-internal (nrings bits start-time
)
147 "Towers of Hanoi internal interface. Use NRINGS rings.
148 Start after n steps, where BITS is a big-endian list of the bits of n.
149 BITS must be of length nrings. Start at START-TIME."
150 (switch-to-buffer "*Hanoi*")
151 (buffer-disable-undo (current-buffer))
154 (;; These lines can cause emacs to crash if you ask for too
155 ;; many rings. If you uncomment them, on most systems you
156 ;; can get 10,000+ rings.
157 ;;(max-specpdl-size (max max-specpdl-size (* nrings 15)))
158 ;;(max-lisp-eval-depth (max max-lisp-eval-depth (+ nrings 20)))
159 (vert (not hanoi-horizontal-flag
))
160 (pole-width (length (format "%d" (max 0 (1- nrings
)))))
161 (pole-char (if vert ?\| ?\-
))
162 (base-char (if vert ?\
= ?\|
))
163 (base-len (max (+ 8 (* pole-width
3))
164 (1- (if vert
(window-width) (window-height)))))
165 (max-ring-diameter (/ (- base-len
2) 3))
166 (pole1-coord (/ max-ring-diameter
2))
167 (pole2-coord (/ base-len
2))
168 (pole3-coord (- base-len
(/ (1+ max-ring-diameter
) 2)))
169 (pole-coords (list pole1-coord pole2-coord pole3-coord
))
170 ;; Number of lines displayed below the bottom-most rings.
172 (min 3 (max 0 (- (1- (if vert
(window-height) (window-width)))
175 ;; These variables will be set according to hanoi-horizontal-flag:
177 ;; line-offset is the number of characters per line in the buffer.
179 ;; fly-row-start is the buffer position of the leftmost or
180 ;; uppermost position in the fly row.
182 ;; Adding fly-step to a buffer position moves you one step
183 ;; along the fly row in the direction from pole1 to pole2.
185 ;; Adding baseward-step to a buffer position moves you one step
189 (setq buffer-read-only nil
)
191 (setq truncate-lines t
)
192 (if hanoi-horizontal-flag
194 (setq line-offset
(+ base-lines nrings
3))
195 (setq fly-row-start
(1- line-offset
))
196 (setq fly-step line-offset
)
197 (setq baseward-step -
1)
198 (loop repeat base-len do
199 (unless (zerop base-lines
)
200 (insert-char ?\
(1- base-lines
))
202 (hanoi-put-face (1- (point)) (point) hanoi-base-face
))
203 (insert-char ?\
(+ 2 nrings
))
206 (loop for coord in pole-coords do
207 (loop for row from
(- coord
(/ pole-width
2))
208 for start
= (+ (* row line-offset
) base-lines
1)
210 (subst-char-in-region start
(+ start nrings
1)
212 (hanoi-put-face start
(+ start nrings
1)
215 (setq line-offset
(1+ base-len
))
217 (setq baseward-step line-offset
)
218 (let ((extra-lines (- (1- (window-height)) (+ nrings
2) base-lines
)))
219 (insert-char ?
\n (max 0 extra-lines
))
220 (setq fly-row-start
(point))
221 (insert-char ?\ base-len
)
223 (loop repeat
(1+ nrings
)
225 (loop with line
= (make-string base-len ?\
)
226 for coord in pole-coords
227 for start
= (- coord
(/ pole-width
2))
228 for end
= (+ start pole-width
) do
229 (hanoi-put-face start end hanoi-pole-face line
)
230 (loop for i from start below end do
231 (aset line i pole-char
))
233 do
(insert pole-line ?
\n))
234 (insert-char base-char base-len
)
235 (hanoi-put-face (- (point) base-len
) (point) hanoi-base-face
)
236 (set-window-start (selected-window)
238 (max 0 (- extra-lines
)))))))
241 (;; each pole is a pair of buffer positions:
242 ;; the car is the position of the top ring currently on the pole,
243 ;; (or the base of the pole if it is empty).
244 ;; the cdr is in the fly-row just above the pole.
245 (poles (loop for coord in pole-coords
246 for fly-pos
= (+ fly-row-start
(* fly-step coord
))
247 for base
= (+ fly-pos
(* baseward-step
(+ 2 nrings
)))
248 collect
(cons base fly-pos
)))
249 ;; compute the string for each ring and make the list of
250 ;; ring pairs. Each ring pair is initially (str . diameter).
251 ;; Once placed in buffer it is changed to (center-pos . diameter).
254 ;; radii are measured from the edge of the pole out.
255 ;; So diameter = 2 * radius + pole-width. When
256 ;; there's room, we make each ring's radius =
257 ;; pole-number + 1. If there isn't room, we step
258 ;; evenly from the max radius down to 1.
259 with max-radius
= (min nrings
260 (/ (- max-ring-diameter pole-width
) 2))
261 for n from
(1- nrings
) downto
0
262 for radius
= (1+ (/ (* n max-radius
) nrings
))
263 for diameter
= (+ pole-width
(* 2 radius
))
264 with format-str
= (format "%%0%dd" pole-width
)
265 for str
= (concat (if vert
"<" "^")
266 (make-string (1- radius
) (if vert ?\- ?\|
))
267 (format format-str n
)
268 (make-string (1- radius
) (if vert ?\- ?\|
))
271 (if (eq (logand n
1) 1) ; oddp would require cl at runtime
272 hanoi-odd-ring-face hanoi-even-ring-face
)
273 do
(hanoi-put-face 0 (length str
) face str
)
274 collect
(cons str diameter
)))
275 ;; Disable display of line and column numbers, for speed.
276 (line-number-mode nil
) (column-number-mode nil
))
278 (hanoi-n bits rings
(car poles
) (cadr poles
) (caddr poles
)
281 (setq buffer-read-only t
)
282 (force-mode-line-update)))
284 (defun hanoi-current-time-float ()
285 "Return values from current-time combined into a single float."
286 (destructuring-bind (high low micros
) (current-time)
287 (+ (* high
65536.0) low
(/ micros
1000000.0))))
289 (defun hanoi-put-face (start end value
&optional object
)
290 "If hanoi-use-faces is non-nil, call put-text-property for face property."
292 (put-text-property start end
'face value object
)))
295 ;;; Functions with a start-time argument (hanoi-0, hanoi-n, and
296 ;;; hanoi-move-ring) start working at start-time and return the ending
297 ;;; time. If hanoi-move-period is nil, start-time is ignored and the
298 ;;; return value is junk.
301 ;;; hanoi-0 - work horse of hanoi
302 (defun hanoi-0 (rings from to work start-time
)
305 (hanoi-0 (cdr rings
) work to from
306 (hanoi-move-ring (car rings
) from to
307 (hanoi-0 (cdr rings
) from work to start-time
)))))
309 ;; start after n moves, where BITS is a big-endian list of the bits of n.
310 ;; BITS must be of same length as rings.
311 (defun hanoi-n (bits rings from to work start-time
)
313 ;; All rings have been placed in starting positions. Update display.
317 (hanoi-insert-ring (car rings
) from
)
318 (hanoi-0 (cdr rings
) work to from
319 (hanoi-move-ring (car rings
) from to
320 (hanoi-n (cdr bits
) (cdr rings
) from work to
323 (hanoi-insert-ring (car rings
) to
)
324 (hanoi-n (cdr bits
) (cdr rings
) work to from start-time
))))
326 ;; put never-before-placed RING on POLE and update their cars.
327 (defun hanoi-insert-ring (ring pole
)
328 (decf (car pole
) baseward-step
)
329 (let ((str (car ring
))
330 (start (- (car pole
) (* (/ (cdr ring
) 2) fly-step
))))
331 (setcar ring
(car pole
))
332 (loop for pos upfrom start by fly-step
333 for i below
(cdr ring
) do
334 (subst-char-in-region pos
(1+ pos
) (char-after pos
) (aref str i
))
335 (set-text-properties pos
(1+ pos
) (text-properties-at i str
)))
336 (hanoi-goto-char (car pole
))))
338 ;; like goto-char, but if position is outside the window, then move to
339 ;; corresponding position in the first row displayed.
340 (defun hanoi-goto-char (pos)
341 (goto-char (if (or hanoi-horizontal-flag
(<= (window-start) pos
))
343 (+ (window-start) (%
(- pos fly-row-start
) baseward-step
)))))
345 ;; do one pole-to-pole move and update the ring and pole pairs.
346 (defun hanoi-move-ring (ring from to start-time
)
347 (incf (car from
) baseward-step
)
348 (decf (car to
) baseward-step
)
349 (let* ;; We move flywards-steps steps up the pole to the fly row,
350 ;; then fly fly-steps steps across the fly row, then go
351 ;; baseward-steps steps down the new pole.
352 ((flyward-steps (/ (- (car ring
) (cdr from
)) baseward-step
))
353 (fly-steps (abs (/ (- (cdr to
) (cdr from
)) fly-step
)))
354 (directed-fly-step (/ (- (cdr to
) (cdr from
)) fly-steps
))
355 (baseward-steps (/ (- (car to
) (cdr to
)) baseward-step
))
356 (total-steps (+ flyward-steps fly-steps baseward-steps
))
357 ;; A step is a character cell. A tick is a time-unit. To
358 ;; make horizontal and vertical motion appear roughly the
359 ;; same speed, we allow one tick per horizontal step and two
360 ;; ticks per vertical step.
361 (ticks-per-pole-step (if hanoi-horizontal-flag
1 2))
362 (ticks-per-fly-step (if hanoi-horizontal-flag
2 1))
363 (flyward-ticks (* ticks-per-pole-step flyward-steps
))
364 (fly-ticks (* ticks-per-fly-step fly-steps
))
365 (baseward-ticks (* ticks-per-pole-step baseward-steps
))
366 (total-ticks (+ flyward-ticks fly-ticks baseward-ticks
))
368 ;; Return the buffer position of the ring after TICK ticks.
371 ((<= tick flyward-ticks
)
374 (- flyward-steps
(/ tick ticks-per-pole-step
)))))
375 ((<= tick
(+ flyward-ticks fly-ticks
))
378 (/ (- tick flyward-ticks
) ticks-per-fly-step
))))
382 (/ (- tick flyward-ticks fly-ticks
)
383 ticks-per-pole-step
))))))))
384 (if hanoi-move-period
385 (loop for elapsed
= (- (hanoi-current-time-float) start-time
)
386 while
(< elapsed hanoi-move-period
)
387 with tick-period
= (/ (float hanoi-move-period
) total-ticks
)
388 for tick
= (ceiling (/ elapsed tick-period
)) do
389 (hanoi-ring-to-pos ring
(funcall tick-to-pos tick
))
390 (hanoi-sit-for (- (* tick tick-period
) elapsed
)))
391 (loop for tick from
1 to total-ticks by
2 do
392 (hanoi-ring-to-pos ring
(funcall tick-to-pos tick
))
394 ;; Always make last move to keep pole and ring data consistent
395 (hanoi-ring-to-pos ring
(car to
))
396 (if hanoi-move-period
(+ start-time hanoi-move-period
))))
398 ;; update display and pause, quitting with a pithy comment if the user
400 (defun hanoi-sit-for (seconds)
402 (if (input-pending-p)
403 (signal 'quit
'("I can tell you've had enough"))))
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
)
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
))))
439 (hanoi-goto-char pos
))
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
))))
449 ;;; hanoi.el ends here