1 ;;; hanoi.el --- towers of hanoi in GNUmacs
3 ;; Author: Damon Anton Permezel
5 ;; Last-Modified: 09 May 1991
8 ; Author (a) 1985, Damon Anton Permezel
9 ; This is in the public domain
10 ; since he distributed it without copyright notice in 1985.
15 ;;; hanoi-topos - direct cursor addressing
17 (defun hanoi-topos (row col
)
23 ;;; hanoi - user callable Towers of Hanoi
27 "Towers of Hanoi diversion. Argument is number of rings."
29 (list (if (null current-prefix-arg
)
31 (prefix-numeric-value current-prefix-arg
))))
32 (if (<= nrings
0) (error "Negative number of rings"))
36 (window-height (window-height (selected-window)))
37 (window-width (window-width (selected-window))))
38 (let ((h (+ nrings
2))
39 (w (+ (* (1- nrings
) 6) 2 5)))
40 (if (not (and (>= window-width h
)
43 (delete-other-windows)
44 (if (not (and (>= (setq window-height
45 (window-height (selected-window))) h
)
47 (window-width (selected-window))) w
)))
48 (error "Screen is too small (need at least %dx%d)" w h
))))
49 (setq pole-spacing
(/ window-width
6))
50 (if (not (zerop (logand pole-spacing
1)))
52 (setq pole-spacing
(1+ pole-spacing
)))
53 (setq floor-row
(if (> (- window-height
3) h
)
54 (- window-height
3) window-height
)))
55 (let ((fly-row (- floor-row nrings
1))
56 ;; pole: column . fill height
57 (pole-1 (cons pole-spacing floor-row
))
58 (pole-2 (cons (* 3 pole-spacing
) floor-row
))
59 (pole-3 (cons (* 5 pole-spacing
) floor-row
))
60 (rings (make-vector nrings nil
)))
61 ;; construct the ring list
64 ;; ring: [pole-number string empty-string]
65 (aset rings i
(vector nil
66 (make-string (+ i i
3) (+ ?
0 i
))
67 (make-string (+ i i
3) ?\
)))
72 (switch-to-buffer "*Hanoi*")
73 (setq buffer-read-only nil
)
74 (buffer-disable-undo (current-buffer))
77 (while (< i floor-row
)
79 (insert-char ?\
(1- window-width
))
81 (insert-char ?
= (1- window-width
))
85 (hanoi-topos fly-row
(* n pole-spacing
))
88 (while (< i floor-row
)
96 ;; now draw the rings in their initial positions
101 (setq ring
(aref rings
(- nrings
1 i
)))
102 (aset ring
0 (- floor-row i
))
103 (hanoi-topos (cdr pole-1
)
104 (- (car pole-1
) (- nrings i
)))
105 (hanoi-draw-ring ring t nil
)
106 (setcdr pole-1
(1- (cdr pole-1
)))
108 (setq buffer-read-only t
)
113 (hanoi0 (1- nrings
) pole-1 pole-2 pole-3
)
114 (goto-char (point-min))
116 (setq buffer-read-only t
)
117 (set-buffer-modified-p (buffer-modified-p))
121 ;;; hanoi0 - work horse of hanoi
123 (defun hanoi0 (n from to work
)
124 (cond ((input-pending-p)
125 (signal 'quit
(list "I can tell you've had enough")))
128 (hanoi0 (1- n
) from work to
)
129 (hanoi-move-ring n from to
)
130 (hanoi0 (1- n
) work to from
))))
133 ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to'
136 (defun hanoi-move-ring (n from to
)
137 (let ((ring (aref rings n
)) ; ring <- ring: (ring# . row)
138 (buffer-read-only nil
))
139 (let ((row (aref ring
0)) ; row <- row ring is on
140 (col (- (car from
) n
1)) ; col <- left edge of ring
141 (dst-col (- (car to
) n
1)) ; dst-col <- dest col for left edge
142 (dst-row (cdr to
))) ; dst-row <- dest row for ring
143 (hanoi-topos row col
)
144 (while (> row fly-row
) ; move up to the fly row
145 (hanoi-draw-ring ring nil t
) ; blank out ring
146 (previous-line 1) ; move up a line
147 (hanoi-draw-ring ring t nil
) ; redraw
150 (setcdr from
(1+ (cdr from
))) ; adjust top row
152 ;; fly the ring over to the right pole
154 (while (not (equal dst-col col
))
155 (cond ((> dst-col col
) ; dst-col > col: right shift
157 (delete-backward-char 2)
158 (beginning-of-line 1)
161 (setq col
(1+ (1+ col
))))
162 ((< dst-col col
) ; dst-col < col: left shift
163 (beginning-of-line 1)
168 (setq col
(1- (1- col
))))))
170 ;; let the ring float down
172 (hanoi-topos fly-row dst-col
)
173 (while (< row dst-row
) ; move down to the dest row
174 (hanoi-draw-ring ring nil
(> row fly-row
)) ; blank out ring
175 (next-line 1) ; move down a line
176 (hanoi-draw-ring ring t nil
) ; redraw ring
179 (aset ring
0 dst-row
)
180 (setcdr to
(1- (cdr to
)))))) ; adjust top row
183 ;;; draw-ring - draw the ring at point, leave point unchanged
187 ;;; f1 - flag: t -> draw, nil -> erase
188 ;;; f2 - flag: t -> erasing and need to draw ?\|
190 (defun hanoi-draw-ring (ring f1 f2
)
192 (let* ((string (if f1
(aref ring
1) (aref ring
2)))
193 (len (length string
)))
198 (backward-char (/ (+ len
1) 2))
199 (delete-char 1) (insert ?\|
))))))