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.
10 ;; This file is part of GNU Emacs.
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>.
18 ;; Solves the Towers of Hanoi puzzle while-U-wait.
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.
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.
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.
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...
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...
62 (defvar baseward-step
)
64 (defvar fly-row-start
)
70 "The Towers of Hanoi."
73 (defcustom hanoi-horizontal-flag nil
74 "*If non-nil, hanoi poles are oriented horizontally."
75 :group
'hanoi
:type
'boolean
)
77 (defcustom hanoi-move-period
1.0
78 "*Time, in seconds, for each pole-to-pole move of a ring.
79 If nil, move rings as fast as possible while displaying all
80 intermediate positions."
81 :group
'hanoi
:type
'(restricted-sexp :match-alternatives
(numberp 'nil
)))
83 (defcustom hanoi-use-faces nil
84 "*If nil, all hanoi-*-face variables are ignored."
85 :group
'hanoi
:type
'boolean
)
87 (defcustom hanoi-pole-face
'highlight
88 "*Face for poles. Ignored if hanoi-use-faces is nil."
89 :group
'hanoi
:type
'face
)
91 (defcustom hanoi-base-face
'highlight
92 "*Face for base. Ignored if hanoi-use-faces is nil."
93 :group
'hanoi
:type
'face
)
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
)
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
)
105 ;;; hanoi - user callable Towers of Hanoi
108 (defcommand hanoi
((nrings)
110 "Towers of Hanoi diversion. Use NRINGS rings."
111 (setf nrings
(max 3 nrings
))
113 ;; (error "Negative number of rings"))
114 (hanoi-internal nrings
(make-list nrings
:initial-element
0) (hanoi-current-time-float)))
117 (defcommand hanoi-unix
()
118 "Towers of Hanoi, UNIX doomsday version.
119 Displays 32-ring towers that have been progressing at one move per
120 second since 1970-01-01 00:00:00 GMT.
122 Repent before ring 31 moves."
123 (let* ((start (ftruncate (hanoi-current-time-float)))
124 (bits (loop repeat
32
125 for x
= (/ start
(expt 2.0 31)) then
(* x
2.0)
126 collect
(truncate (mod x
2.0))))
127 (hanoi-move-period 1.0))
128 (hanoi-internal 32 bits start
)))
131 (defcommand hanoi-unix-64
()
132 "Like hanoi-unix, but pretend to have a 64-bit clock.
133 This is, necessarily (as of emacs 20.3), a crock. When the
134 current-time interface is made s2G-compliant, hanoi.el will need
136 (let* ((start (ftruncate (hanoi-current-time-float)))
137 (bits (loop repeat
64
138 for x
= (/ start
(expt 2.0 63)) then
(* x
2.0)
139 collect
(truncate (mod x
2.0))))
140 (hanoi-move-period 1.0))
141 (hanoi-internal 64 bits start
)))
143 (defun hanoi-internal (nrings bits start-time
)
144 "Towers of Hanoi internal interface. Use NRINGS rings.
145 Start after n steps, where BITS is a big-endian list of the bits of n.
146 BITS must be of length nrings. Start at START-TIME."
147 (switch-to-buffer "*Hanoi*")
148 (buffer-disable-undo (current-buffer))
151 (;; These lines can cause emacs to crash if you ask for too
152 ;; many rings. If you uncomment them, on most systems you
153 ;; can get 10,000+ rings.
154 ;;(max-specpdl-size (max max-specpdl-size (* nrings 15)))
155 ;;(max-lisp-eval-depth (max max-lisp-eval-depth (+ nrings 20)))
156 (vert (not hanoi-horizontal-flag
))
157 (pole-width (length (format nil
"~d" (max 0 (1- nrings
)))))
158 (pole-char (if vert
#\|
#\-
))
159 (base-char (if vert
#\
= #\|
))
160 (base-len (max (+ 8 (* pole-width
3))
161 (1- (if vert
(window-width) (window-height)))))
162 (max-ring-diameter (truncate (- base-len
2) 3))
163 (pole1-coord (truncate max-ring-diameter
2))
164 (pole2-coord (truncate base-len
2))
165 (pole3-coord (- base-len
(truncate (1+ max-ring-diameter
) 2)))
166 (pole-coords (list pole1-coord pole2-coord pole3-coord
))
167 ;; Number of lines displayed below the bottom-most rings.
169 (min 3 (max 0 (- (1- (if vert
(window-height) (window-width)))
172 ;; These variables will be set according to hanoi-horizontal-flag:
174 ;; line-offset is the number of characters per line in the buffer.
176 ;; fly-row-start is the buffer position of the leftmost or
177 ;; uppermost position in the fly row.
179 ;; Adding fly-step to a buffer position moves you one step
180 ;; along the fly row in the direction from pole1 to pole2.
182 ;; Adding baseward-step to a buffer position moves you one step
186 (setf (buffer-read-only) nil
)
188 (setq truncate-lines t
)
189 (el:if hanoi-horizontal-flag
191 (setq line-offset
(+ base-lines nrings
3))
192 (setq fly-row-start
(1- line-offset
))
193 (setq fly-step line-offset
)
194 (setq baseward-step -
1)
195 (loop repeat base-len do
196 (unless (zerop base-lines
)
197 (insert-char #\Space
(1- base-lines
))
199 (hanoi-put-face (1- (point)) (point) hanoi-base-face
))
200 (insert-char #\Space
(+ 2 nrings
))
203 (loop for coord in pole-coords do
204 (loop for row from
(- coord
(truncate pole-width
2))
205 for start
= (+ (* row line-offset
) base-lines
1)
207 (subst-char-in-region start
(+ start nrings
1)
209 (hanoi-put-face start
(+ start nrings
1)
212 (setq line-offset
(1+ base-len
))
214 (setq baseward-step line-offset
)
215 (let ((extra-lines (- (1- (window-height)) (+ nrings
2) base-lines
)))
216 (insert-char #\Newline
(max 0 extra-lines
))
217 (setq fly-row-start
(point))
218 (insert-char #\Space base-len
)
220 (loop repeat
(1+ nrings
)
222 (loop with line
= (make-string base-len
:initial-element
#\Space
)
223 for coord in pole-coords
224 for start
= (- coord
(truncate pole-width
2))
225 for end
= (+ start pole-width
) do
226 (hanoi-put-face start end hanoi-pole-face line
)
227 (loop for i from start below end do
228 (aset line i pole-char
))
229 finally
(return line
))
230 do
(insert pole-line
#\Newline
))
231 (insert-char base-char base-len
)
232 (hanoi-put-face (- (point) base-len
) (point) hanoi-base-face
)
233 (set-window-start (selected-window)
235 (max 0 (- extra-lines
)))))))
238 (;; each pole is a pair of buffer positions:
239 ;; the car is the position of the top ring currently on the pole,
240 ;; (or the base of the pole if it is empty).
241 ;; the cdr is in the fly-row just above the pole.
242 (poles (loop for coord in pole-coords
243 for fly-pos
= (+ fly-row-start
(* fly-step coord
))
244 for base
= (+ fly-pos
(* baseward-step
(+ 2 nrings
)))
245 collect
(cons base fly-pos
)))
246 ;; compute the string for each ring and make the list of
247 ;; ring pairs. Each ring pair is initially (str . diameter).
248 ;; Once placed in buffer it is changed to (center-pos . diameter).
251 ;; radii are measured from the edge of the pole out.
252 ;; So diameter = 2 * radius + pole-width. When
253 ;; there's room, we make each ring's radius =
254 ;; pole-number + 1. If there isn't room, we step
255 ;; evenly from the max radius down to 1.
256 with max-radius
= (min nrings
257 (truncate (- max-ring-diameter pole-width
) 2))
258 for n from
(1- nrings
) downto
0
259 for radius
= (1+ (truncate (* n max-radius
) nrings
))
260 for diameter
= (+ pole-width
(* 2 radius
))
261 with format-str
= (format nil
"~~~d,'0d" pole-width
)
262 for str
= (concat (if vert
"<" "^")
263 (make-string (1- radius
) :initial-element
(if vert
#\-
#\|
))
264 (format nil format-str n
)
265 (make-string (1- radius
) :initial-element
(if vert
#\-
#\|
))
268 (if (eq (logand n
1) 1) ; oddp would require cl at runtime
269 hanoi-odd-ring-face hanoi-even-ring-face
)
270 do
(hanoi-put-face 0 (length str
) face str
)
271 collect
(cons str diameter
)))
272 ;; Disable display of line and column numbers, for speed.
273 (line-number-mode nil
) (column-number-mode nil
))
275 (hanoi-n bits rings
(car poles
) (cadr poles
) (caddr poles
)
278 (setf (buffer-read-only) t
)
279 (force-mode-line-update)))
281 (defun hanoi-current-time-float ()
282 "Return values from current-time combined into a single float."
283 (+ (get-universal-time)
284 (/ (get-internal-real-time)
285 internal-time-units-per-second
)))
287 (defun hanoi-put-face (start end value
&optional object
)
288 "If hanoi-use-faces is non-nil, call put-text-property for face property."
290 (put-text-property start end
'face value object
)))
293 ;;; Functions with a start-time argument (hanoi-0, hanoi-n, and
294 ;;; hanoi-move-ring) start working at start-time and return the ending
295 ;;; time. If hanoi-move-period is nil, start-time is ignored and the
296 ;;; return value is junk.
299 ;;; hanoi-0 - work horse of hanoi
300 (defun hanoi-0 (rings from to work start-time
)
303 (hanoi-0 (cdr rings
) work to from
304 (hanoi-move-ring (car rings
) from to
305 (hanoi-0 (cdr rings
) from work to start-time
)))))
307 ;; start after n moves, where BITS is a big-endian list of the bits of n.
308 ;; BITS must be of same length as rings.
309 (defun hanoi-n (bits rings from to work start-time
)
311 ;; All rings have been placed in starting positions. Update display.
315 (hanoi-insert-ring (car rings
) from
)
316 (hanoi-0 (cdr rings
) work to from
317 (hanoi-move-ring (car rings
) from to
318 (hanoi-n (cdr bits
) (cdr rings
) from work to
321 (hanoi-insert-ring (car rings
) to
)
322 (hanoi-n (cdr bits
) (cdr rings
) work to from start-time
))))
324 ;; put never-before-placed RING on POLE and update their cars.
325 (defun hanoi-insert-ring (ring pole
)
326 (decf (car pole
) baseward-step
)
327 (let ((str (car ring
))
328 (start (- (car pole
) (* (truncate (cdr ring
) 2) fly-step
))))
329 (setcar ring
(car pole
))
330 (loop for pos upfrom start by fly-step
331 for i below
(cdr ring
) do
332 (subst-char-in-region pos
(1+ pos
) (char-after pos
) (aref str i
))
333 (set-text-properties pos
(1+ pos
) (text-properties-at i str
)))
334 (hanoi-goto-char (car pole
))))
336 ;; like goto-char, but if position is outside the window, then move to
337 ;; corresponding position in the first row displayed.
338 (defun hanoi-goto-char (pos)
339 (goto-char (if (or hanoi-horizontal-flag
(<= (window-start) pos
))
341 (+ (window-start) (%
(- pos fly-row-start
) baseward-step
)))))
343 ;; do one pole-to-pole move and update the ring and pole pairs.
344 (defun hanoi-move-ring (ring from to start-time
)
345 (incf (car from
) baseward-step
)
346 (decf (car to
) baseward-step
)
347 (let* ;; We move flywards-steps steps up the pole to the fly row,
348 ;; then fly fly-steps steps across the fly row, then go
349 ;; baseward-steps steps down the new pole.
350 ((flyward-steps (/ (- (car ring
) (cdr from
)) baseward-step
))
351 (fly-steps (abs (/ (- (cdr to
) (cdr from
)) fly-step
)))
352 (directed-fly-step (/ (- (cdr to
) (cdr from
)) fly-steps
))
353 (baseward-steps (/ (- (car to
) (cdr to
)) baseward-step
))
354 (total-steps (+ flyward-steps fly-steps baseward-steps
))
355 ;; A step is a character cell. A tick is a time-unit. To
356 ;; make horizontal and vertical motion appear roughly the
357 ;; same speed, we allow one tick per horizontal step and two
358 ;; ticks per vertical step.
359 (ticks-per-pole-step (if hanoi-horizontal-flag
1 2))
360 (ticks-per-fly-step (if hanoi-horizontal-flag
2 1))
361 (flyward-ticks (* ticks-per-pole-step flyward-steps
))
362 (fly-ticks (* ticks-per-fly-step fly-steps
))
363 (baseward-ticks (* ticks-per-pole-step baseward-steps
))
364 (total-ticks (+ flyward-ticks fly-ticks baseward-ticks
))
366 ;; Return the buffer position of the ring after TICK ticks.
369 ((<= tick flyward-ticks
)
372 (- flyward-steps
(truncate tick ticks-per-pole-step
)))))
373 ((<= tick
(+ flyward-ticks fly-ticks
))
376 (truncate (- tick flyward-ticks
) ticks-per-fly-step
))))
380 (truncate (- tick flyward-ticks fly-ticks
)
381 ticks-per-pole-step
))))))))
382 (declare (ignore total-steps
))
383 (if hanoi-move-period
384 (loop for elapsed
= (- (hanoi-current-time-float) start-time
)
385 while
(< elapsed hanoi-move-period
)
386 with tick-period
= (/ (float hanoi-move-period
) total-ticks
)
387 for tick
= (ceiling (/ elapsed tick-period
)) do
388 (hanoi-ring-to-pos ring
(funcall tick-to-pos tick
))
389 (hanoi-sit-for (- (* tick tick-period
) elapsed
)))
390 (loop for tick from
1 to total-ticks by
2 do
391 (hanoi-ring-to-pos ring
(funcall tick-to-pos tick
))
393 ;; Always make last move to keep pole and ring data consistent
394 (hanoi-ring-to-pos ring
(car to
))
395 (if hanoi-move-period
(+ start-time hanoi-move-period
))))
397 ;; update display and pause, quitting with a pithy comment if the user
399 (defun hanoi-sit-for (seconds)
400 (unless (sit-for seconds
)
401 (signal 'quit
'("I can tell you've had enough"))))
403 ;; move ring to a given buffer position and update ring's car.
404 (defun hanoi-ring-to-pos (ring pos
)
405 (unless (= (car ring
) pos
)
406 (let* ((start (- (car ring
) (* (truncate (cdr ring
) 2) fly-step
)))
407 (new-start (- pos
(- (car ring
) start
))))
408 (if hanoi-horizontal-flag
409 (loop for i below
(cdr ring
)
410 for j
= (if (< new-start start
) i
(- (cdr ring
) i
1))
411 for old-pos
= (+ start
(* j fly-step
))
412 for new-pos
= (+ new-start
(* j fly-step
)) do
413 (transpose-regions old-pos
(1+ old-pos
) new-pos
(1+ new-pos
)))
414 (let ((end (+ start
(cdr ring
)))
415 (new-end (+ new-start
(cdr ring
))))
416 (if (< (abs (- new-start start
)) (- end start
))
417 ;; Overlap. Adjust bounds
418 (if (< start new-start
)
420 (setq new-end start
)))
421 (transpose-regions start end new-start new-end t
))))
422 ;; If moved on or off a pole, redraw pole chars.
423 (unless (eq (hanoi-pos-on-tower-p (car ring
)) (hanoi-pos-on-tower-p pos
))
424 (let* ((pole-start (- (car ring
) (* fly-step
(truncate pole-width
2))))
425 (pole-end (+ pole-start
(* fly-step pole-width
)))
426 (on-pole (hanoi-pos-on-tower-p (car ring
)))
427 (new-char (if on-pole pole-char
#\Space
))
428 (curr-char (if on-pole
#\Space pole-char
))
429 (face (if on-pole hanoi-pole-face nil
)))
430 (el:if hanoi-horizontal-flag
431 (loop for pos from pole-start below pole-end by line-offset do
432 (subst-char-in-region pos
(1+ pos
) curr-char new-char
)
433 (hanoi-put-face pos
(1+ pos
) face
))
434 (subst-char-in-region pole-start pole-end curr-char new-char
)
435 (hanoi-put-face pole-start pole-end face
))))
437 (hanoi-goto-char pos
))
439 ;; Check if a buffer position lies on a tower (vis. in the fly row).
440 (defun hanoi-pos-on-tower-p (pos)
441 (if hanoi-horizontal-flag
442 (/= (% pos fly-step
) fly-row-start
)
443 (>= pos
(+ fly-row-start baseward-step
))))
447 ;;; arch-tag: 7a901659-4346-495c-8883-14cbf540610c
448 ;;; hanoi.el ends here