![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hanoi.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to hanoi.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
1.1 root 1: ;
2: ; hanoi - towers of hanoi in GNUmacs
3: ;
4: ; Author (a) 1985, Damon Anton Permezel
5: ;
6:
7: ;;;
8: ;;; hanoi-topos - direct cursor addressing
9: ;;;
10: (defun hanoi-topos (row col)
11: (goto-line row)
12: (beginning-of-line)
13: (forward-char col))
14:
15: ;;;
16: ;;; hanoi - user callable Towers of Hanoi
17: ;;;
18: (defun hanoi (nrings)
19: "Towers of Hanoi diversion. Argument is number of rings."
20: (interactive
21: (list (if (null current-prefix-arg)
22: 3
23: (prefix-numeric-value current-prefix-arg))))
24: (if (<= nrings 0) (error "Negative number of rings"))
25: (let (pole-spacing
26: floor-row
27: fly-row
28: (window-height (window-height (selected-window)))
29: (window-width (window-width (selected-window))))
30: (let ((h (+ nrings 2))
31: (w (+ (* (1- nrings) 6) 2 5)))
32: (if (not (and (>= window-width h)
33: (> window-width w)))
34: (progn
35: (delete-other-windows)
36: (if (not (and (>= (setq window-height
37: (window-height (selected-window))) h)
38: (> (setq window-width
39: (window-width (selected-window))) w)))
40: (error "Screen is too small (need at least %dx%d)" w h))))
41: (setq pole-spacing (/ window-width 6))
42: (if (not (zerop (logand pole-spacing 1)))
43: ;; must be even
44: (setq pole-spacing (1+ pole-spacing)))
45: (setq floor-row (if (> (- window-height 3) h)
46: (- window-height 3) window-height)))
47: (let ((fly-row (- floor-row nrings 1))
48: ;; pole: column . fill height
49: (pole-1 (cons pole-spacing floor-row))
50: (pole-2 (cons (* 3 pole-spacing) floor-row))
51: (pole-3 (cons (* 5 pole-spacing) floor-row))
52: (rings (make-vector nrings nil)))
53: ;; construct the ring list
54: (let ((i 0))
55: (while (< i nrings)
56: ;; ring: [pole-number string empty-string]
57: (aset rings i (vector nil
58: (make-string (+ i i 3) (+ ?0 i))
59: (make-string (+ i i 3) ?\ )))
60: (setq i (1+ i))))
61: ;;
62: ;; init the screen
63: ;;
64: (switch-to-buffer "*Hanoi*")
65: (setq buffer-read-only nil)
66: (buffer-flush-undo (current-buffer))
67: (erase-buffer)
68: (let ((i 0))
69: (while (< i floor-row)
70: (setq i (1+ i))
71: (insert-char ?\ (1- window-width))
72: (insert ?\n)))
73: (insert-char ?= (1- window-width))
74:
75: (let ((n 1))
76: (while (< n 6)
77: (hanoi-topos fly-row (* n pole-spacing))
78: (setq n (+ n 2))
79: (let ((i fly-row))
80: (while (< i floor-row)
81: (setq i (1+ i))
82: (next-line 1)
83: (insert ?\|)
84: (delete-char 1)
85: (backward-char 1)))))
86: ;(sit-for 0)
87: ;;
88: ;; now draw the rings in their initial positions
89: ;;
90: (let ((i 0)
91: ring)
92: (while (< i nrings)
93: (setq ring (aref rings (- nrings 1 i)))
94: (aset ring 0 (- floor-row i))
95: (hanoi-topos (cdr pole-1)
96: (- (car pole-1) (- nrings i)))
97: (hanoi-draw-ring ring t nil)
98: (setcdr pole-1 (1- (cdr pole-1)))
99: (setq i (1+ i))))
100: (setq buffer-read-only t)
101: (sit-for 0)
102: ;;
103: ;; do it!
104: ;;
105: (hanoi0 (1- nrings) pole-1 pole-2 pole-3)
106: (goto-char (point-min))
107: (message "Done")
108: (setq buffer-read-only t)
109: (set-buffer-modified-p (buffer-modified-p))
110: (sit-for 0))))
111:
112: ;;;
113: ;;; hanoi0 - work horse of hanoi
114: ;;;
115: (defun hanoi0 (n from to work)
116: (cond ((input-pending-p)
117: (signal 'quit (list "I can tell you've had enough")))
118: ((< n 0))
119: (t
120: (hanoi0 (1- n) from work to)
121: (hanoi-move-ring n from to)
122: (hanoi0 (1- n) work to from))))
123:
124: ;;;
125: ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to'
126: ;;;
127: ;;;
128: (defun hanoi-move-ring (n from to)
129: (let ((ring (aref rings n)) ; ring <- ring: (ring# . row)
130: (buffer-read-only nil))
131: (let ((row (aref ring 0)) ; row <- row ring is on
132: (col (- (car from) n 1)) ; col <- left edge of ring
133: (dst-col (- (car to) n 1)) ; dst-col <- dest col for left edge
134: (dst-row (cdr to))) ; dst-row <- dest row for ring
135: (hanoi-topos row col)
136: (while (> row fly-row) ; move up to the fly row
137: (hanoi-draw-ring ring nil t) ; blank out ring
138: (previous-line 1) ; move up a line
139: (hanoi-draw-ring ring t nil) ; redraw
140: (sit-for 0)
141: (setq row (1- row)))
142: (setcdr from (1+ (cdr from))) ; adjust top row
143: ;;
144: ;; fly the ring over to the right pole
145: ;;
146: (while (not (equal dst-col col))
147: (cond ((> dst-col col) ; dst-col > col: right shift
148: (end-of-line 1)
149: (delete-backward-char 2)
150: (beginning-of-line 1)
151: (insert ?\ ?\ )
152: (sit-for 0)
153: (setq col (1+ (1+ col))))
154: ((< dst-col col) ; dst-col < col: left shift
155: (beginning-of-line 1)
156: (delete-char 2)
157: (end-of-line 1)
158: (insert ?\ ?\ )
159: (sit-for 0)
160: (setq col (1- (1- col))))))
161: ;;
162: ;; let the ring float down
163: ;;
164: (hanoi-topos fly-row dst-col)
165: (while (< row dst-row) ; move down to the dest row
166: (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring
167: (next-line 1) ; move down a line
168: (hanoi-draw-ring ring t nil) ; redraw ring
169: (sit-for 0)
170: (setq row (1+ row)))
171: (aset ring 0 dst-row)
172: (setcdr to (1- (cdr to)))))) ; adjust top row
173:
174: ;;;
175: ;;; draw-ring - draw the ring at point, leave point unchanged
176: ;;;
177: ;;; Input:
178: ;;; ring
179: ;;; f1 - flag: t -> draw, nil -> erase
180: ;;; f2 - flag: t -> erasing and need to draw ?\|
181: ;;;
182: (defun hanoi-draw-ring (ring f1 f2)
183: (save-excursion
184: (let* ((string (if f1 (aref ring 1) (aref ring 2)))
185: (len (length string)))
186: (delete-char len)
187: (insert string)
188: (if f2
189: (progn
190: (backward-char (/ (+ len 1) 2))
191: (delete-char 1) (insert ?\|))))))
192:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.