![[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] / 43BSD / contrib / emacs / lisp|
Return to hanoi.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / 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 (n-rings)
19: "Towers of Hanoi diversion. Arg is number of rings."
20: (interactive "p")
21: (if (or (> n-rings 9) (<= n-rings 0))
22: (error "Funny number of rings"))
23:
24: (let ((floor-row 21)
25: (fly-row (- 21 n-rings 1))
26: (pole-1 (cons 20 20)) ; pole: column . fill height
27: (pole-2 (cons 40 20)) ; (these must be consed, not '(x . y)
28: (pole-3 (cons 60 20)) ; otherwise we are not reentrant)
29: (rings '(t (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0)
30: (6 . 0) (7 . 0) (8 . 0) (9 . 0))))
31: ;;
32: ;; init the screen
33: ;;
34: (switch-to-buffer " *Hanoi*")
35: (delete-other-windows)
36: (erase-buffer)
37:
38: (let ((i 1)) ; 21 copies of a line of 78 blanks
39: (while (< i floor-row)
40: (setq i (1+ i))
41: (insert " \n")))
42:
43: (let ((i 0)) ; draw the base
44: (while (< i 78)
45: (setq i (1+ i))
46: (insert ?=)))
47:
48: (mapcar (function (lambda (x) ; draw the towers
49: (hanoi-topos fly-row x)
50: (let ((i fly-row))
51: (while (< i floor-row)
52: (setq i (1+ i))
53: (next-line 1)
54: (insert ?|)
55: (delete-char 1)
56: (backward-char 1)))))
57: '(20 40 60))
58: (sit-for 0)
59: ;;
60: ;; now init the rings
61: ;;
62: (let ((where (1- floor-row))
63: (i n-rings)
64: r)
65: (while (> i 0)
66: (setq r (car (nthcdr i rings))) ; extract desired ring
67: (setcdr r where) ; indicate ring row
68: (setq where (1- where))
69: (hanoi-move-ring i pole-1 pole-1)
70: (setq i (1- i))))
71: (sit-for 0)
72: (hanoi0 n-rings pole-1 pole-2 pole-3))
73: (message "Done"))
74:
75: ;;;
76: ;;; hanoi0 - work horse of hanoi
77: ;;;
78: (defun hanoi0 (n from to work)
79: (if (> n 0)
80: (progn
81: (hanoi0 (1- n) from work to)
82: (hanoi-move-ring n from to)
83: (hanoi0 (1- n) work to from))))
84:
85: ;;;
86: ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to'
87: ;;;
88: ;;; from and to are dotted pairs consisting of (pole col . fill height)
89: ;;;
90: (defun hanoi-move-ring (n from to)
91: (let ((r (car (nthcdr n rings)))) ; r <- ring: (ring# . row)
92: (if (eq from to) ; must change poles?
93: ;;
94: ;; ring on same pole - used for initialization
95: ;;
96: (progn
97: (hanoi-topos (cdr to) (- (car to) n))
98: (hanoi-draw-ring n t nil)
99: (setcdr to (1- (cdr to))))
100: (let ((row (cdr r)) ; row <- row ring is on
101: (col (- (car from) n)) ; col <- left edge of ring
102: (dst-col (- (car to) n)) ; dst-col <- dest col for left edge
103: (dst-row (cdr to))) ; dst-row <- dest row for ring
104: (hanoi-topos row col)
105: (while (> row fly-row) ; move up to the fly row
106: (hanoi-draw-ring n nil nil) ; blank out ring
107: (previous-line 1) ; move up a line
108: (hanoi-draw-ring n t nil) ; redraw
109: (sit-for 0)
110: (setq row (1- row)))
111: (setcdr from (1+ (cdr from))) ; adjust top row
112: ;;
113: ;; fly the ring over to the right pole
114: ;;
115: (while (not (equal dst-col col))
116: (cond ((> dst-col col) ; dst-col > col: right shift
117: (end-of-line 1)
118: (delete-backward-char 2)
119: (beginning-of-line 1)
120: (insert " ")
121: (sit-for 0)
122: (setq col (1+ (1+ col))))
123: ((< dst-col col) ; dst-col < col: left shift
124: (beginning-of-line 1)
125: (delete-char 2)
126: (end-of-line 1)
127: (insert " ")
128: (sit-for 0)
129: (setq col (1- (1- col))))))
130: ;;
131: ;; let the ring float down
132: ;;
133: (hanoi-topos fly-row dst-col)
134: (while (< row dst-row) ; move down to the dest row
135: (hanoi-draw-ring n nil (equal row fly-row)) ; blank out ring
136: (next-line 1) ; move down a line
137: (hanoi-draw-ring n t nil) ; redraw ring
138: (sit-for 0)
139: (setq row (1+ row)))
140: (setcdr r dst-row)
141: (setcdr to (1- (cdr to))))))) ; adjust top row
142:
143: ;;;
144: ;;; hanoi-draw-ring - draw the ring at dot, leave dot unchanged
145: ;;;
146: ;;; Input:
147: ;;; n - ring #. used to select drawing character
148: ;;; f1 - flag: t -> draw, nil -> erase
149: ;;; f2 - flag: t -> erasing ring from fly-row -> dont redraw ?|
150: ;;;
151: (defun hanoi-draw-ring (n f1 f2)
152: (save-excursion
153: (let ((i 0)
154: (repl (if f1
155: (car (nthcdr n '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
156: ? )))
157: (delete-char (+ 1 (* 2 n)))
158: (while (< i n)
159: (insert repl)
160: (setq i (1+ i)))
161: (insert (if f1 repl (if f2 ? ?|)))
162: (setq i 0)
163: (while (< i n)
164: (insert repl)
165: (setq i (1+ i))))))
166:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.