Mercurial > emacs
comparison lisp/play/hanoi.el @ 53:a8efef5eb891
Initial revision
author | Joseph Arceneaux <jla@gnu.org> |
---|---|
date | Tue, 06 Mar 1990 16:45:37 +0000 |
parents | |
children | 1e0bc00dca7a |
comparison
equal
deleted
inserted
replaced
52:2e64db0383ef | 53:a8efef5eb891 |
---|---|
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-disable-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 |