Mercurial > emacs
annotate lisp/play/hanoi.el @ 2042:bbf37b9a24af
(isearch-mode): Don't make a pre-command-hook.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Sun, 07 Mar 1993 08:43:57 +0000 |
parents | a5eec33a8f44 |
children | 10e417efb12a |
rev | line source |
---|---|
660
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
1 ;;; hanoi.el --- towers of hanoi in GNUmacs |
08eb386dd0f3
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
258
diff
changeset
|
2 |
793
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
3 ;; Author: Damon Anton Permezel |
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
4 ;; Maintainer: FSF |
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
5 ;; Keywords: games |
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
6 |
53 | 7 ; Author (a) 1985, Damon Anton Permezel |
663
3587b3dfac25
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
660
diff
changeset
|
8 ; This is in the public domain |
3587b3dfac25
*** empty log message ***
Richard M. Stallman <rms@gnu.org>
parents:
660
diff
changeset
|
9 ; since he distributed it without copyright notice in 1985. |
53 | 10 |
793
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
11 ;;; Code: |
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
12 |
53 | 13 ;;; |
14 ;;; hanoi-topos - direct cursor addressing | |
15 ;;; | |
16 (defun hanoi-topos (row col) | |
17 (goto-line row) | |
18 (beginning-of-line) | |
19 (forward-char col)) | |
20 | |
21 ;;; | |
22 ;;; hanoi - user callable Towers of Hanoi | |
23 ;;; | |
258 | 24 ;;;###autoload |
53 | 25 (defun hanoi (nrings) |
26 "Towers of Hanoi diversion. Argument is number of rings." | |
27 (interactive | |
28 (list (if (null current-prefix-arg) | |
29 3 | |
30 (prefix-numeric-value current-prefix-arg)))) | |
31 (if (<= nrings 0) (error "Negative number of rings")) | |
1663
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
32 (let* (floor-row |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
33 fly-row |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
34 (window-height (window-height (selected-window))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
35 (window-width (window-width (selected-window))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
36 |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
37 ;; This is the unit of spacing to use between poles. It |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
38 ;; must be even. We round down, since rounding up might |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
39 ;; cause us to draw off the edge of the window. |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
40 (pole-spacing (logand (/ window-width 6) (lognot 1)))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
41 (let ( |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
42 ;; The poles are (1+ NRINGS) rows high; we also want an |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
43 ;; empty row at the top for the flying rings, a base, and a |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
44 ;; blank line underneath that. |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
45 (h (+ nrings 4)) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
46 |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
47 ;; If we have NRINGS rings, we label them with the numbers 0 |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
48 ;; through NRINGS-1. The width of ring i is 2i+3; it pokes |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
49 ;; out i spaces on either side of the pole. Rather than |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
50 ;; checking if the window is wide enough to accomodate this, |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
51 ;; we make sure pole-spacing is large enough, since that |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
52 ;; works even when we have decremented pole-spacing to make |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
53 ;; it even. |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
54 (w (1+ nrings))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
55 (if (not (and (>= window-height h) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
56 (> pole-spacing w))) |
53 | 57 (progn |
58 (delete-other-windows) | |
59 (if (not (and (>= (setq window-height | |
1663
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
60 (window-height (selected-window))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
61 h) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
62 (> (setq pole-spacing |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
63 (logand (/ window-width 6) (lognot 1))) |
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
64 w))) |
53 | 65 (error "Screen is too small (need at least %dx%d)" w h)))) |
66 (setq floor-row (if (> (- window-height 3) h) | |
67 (- window-height 3) window-height))) | |
68 (let ((fly-row (- floor-row nrings 1)) | |
69 ;; pole: column . fill height | |
70 (pole-1 (cons pole-spacing floor-row)) | |
71 (pole-2 (cons (* 3 pole-spacing) floor-row)) | |
72 (pole-3 (cons (* 5 pole-spacing) floor-row)) | |
73 (rings (make-vector nrings nil))) | |
74 ;; construct the ring list | |
75 (let ((i 0)) | |
76 (while (< i nrings) | |
77 ;; ring: [pole-number string empty-string] | |
78 (aset rings i (vector nil | |
79 (make-string (+ i i 3) (+ ?0 i)) | |
80 (make-string (+ i i 3) ?\ ))) | |
81 (setq i (1+ i)))) | |
82 ;; | |
83 ;; init the screen | |
84 ;; | |
85 (switch-to-buffer "*Hanoi*") | |
86 (setq buffer-read-only nil) | |
87 (buffer-disable-undo (current-buffer)) | |
88 (erase-buffer) | |
89 (let ((i 0)) | |
90 (while (< i floor-row) | |
91 (setq i (1+ i)) | |
92 (insert-char ?\ (1- window-width)) | |
93 (insert ?\n))) | |
94 (insert-char ?= (1- window-width)) | |
95 | |
96 (let ((n 1)) | |
97 (while (< n 6) | |
98 (hanoi-topos fly-row (* n pole-spacing)) | |
99 (setq n (+ n 2)) | |
100 (let ((i fly-row)) | |
101 (while (< i floor-row) | |
102 (setq i (1+ i)) | |
103 (next-line 1) | |
104 (insert ?\|) | |
105 (delete-char 1) | |
106 (backward-char 1))))) | |
107 ;(sit-for 0) | |
108 ;; | |
109 ;; now draw the rings in their initial positions | |
110 ;; | |
111 (let ((i 0) | |
112 ring) | |
113 (while (< i nrings) | |
114 (setq ring (aref rings (- nrings 1 i))) | |
115 (aset ring 0 (- floor-row i)) | |
116 (hanoi-topos (cdr pole-1) | |
117 (- (car pole-1) (- nrings i))) | |
118 (hanoi-draw-ring ring t nil) | |
119 (setcdr pole-1 (1- (cdr pole-1))) | |
120 (setq i (1+ i)))) | |
121 (setq buffer-read-only t) | |
122 (sit-for 0) | |
123 ;; | |
124 ;; do it! | |
125 ;; | |
126 (hanoi0 (1- nrings) pole-1 pole-2 pole-3) | |
127 (goto-char (point-min)) | |
128 (message "Done") | |
129 (setq buffer-read-only t) | |
130 (set-buffer-modified-p (buffer-modified-p)) | |
131 (sit-for 0)))) | |
132 | |
133 ;;; | |
134 ;;; hanoi0 - work horse of hanoi | |
135 ;;; | |
136 (defun hanoi0 (n from to work) | |
137 (cond ((input-pending-p) | |
138 (signal 'quit (list "I can tell you've had enough"))) | |
139 ((< n 0)) | |
140 (t | |
141 (hanoi0 (1- n) from work to) | |
142 (hanoi-move-ring n from to) | |
143 (hanoi0 (1- n) work to from)))) | |
144 | |
145 ;;; | |
146 ;;; hanoi-move-ring - move ring 'n' from 'from' to 'to' | |
147 ;;; | |
148 ;;; | |
149 (defun hanoi-move-ring (n from to) | |
150 (let ((ring (aref rings n)) ; ring <- ring: (ring# . row) | |
151 (buffer-read-only nil)) | |
152 (let ((row (aref ring 0)) ; row <- row ring is on | |
153 (col (- (car from) n 1)) ; col <- left edge of ring | |
154 (dst-col (- (car to) n 1)) ; dst-col <- dest col for left edge | |
155 (dst-row (cdr to))) ; dst-row <- dest row for ring | |
156 (hanoi-topos row col) | |
157 (while (> row fly-row) ; move up to the fly row | |
158 (hanoi-draw-ring ring nil t) ; blank out ring | |
159 (previous-line 1) ; move up a line | |
160 (hanoi-draw-ring ring t nil) ; redraw | |
161 (sit-for 0) | |
162 (setq row (1- row))) | |
163 (setcdr from (1+ (cdr from))) ; adjust top row | |
164 ;; | |
165 ;; fly the ring over to the right pole | |
166 ;; | |
167 (while (not (equal dst-col col)) | |
168 (cond ((> dst-col col) ; dst-col > col: right shift | |
169 (end-of-line 1) | |
170 (delete-backward-char 2) | |
171 (beginning-of-line 1) | |
172 (insert ?\ ?\ ) | |
173 (sit-for 0) | |
174 (setq col (1+ (1+ col)))) | |
175 ((< dst-col col) ; dst-col < col: left shift | |
176 (beginning-of-line 1) | |
177 (delete-char 2) | |
178 (end-of-line 1) | |
179 (insert ?\ ?\ ) | |
180 (sit-for 0) | |
181 (setq col (1- (1- col)))))) | |
182 ;; | |
183 ;; let the ring float down | |
184 ;; | |
185 (hanoi-topos fly-row dst-col) | |
186 (while (< row dst-row) ; move down to the dest row | |
187 (hanoi-draw-ring ring nil (> row fly-row)) ; blank out ring | |
188 (next-line 1) ; move down a line | |
189 (hanoi-draw-ring ring t nil) ; redraw ring | |
190 (sit-for 0) | |
191 (setq row (1+ row))) | |
192 (aset ring 0 dst-row) | |
193 (setcdr to (1- (cdr to)))))) ; adjust top row | |
194 | |
195 ;;; | |
196 ;;; draw-ring - draw the ring at point, leave point unchanged | |
197 ;;; | |
198 ;;; Input: | |
199 ;;; ring | |
200 ;;; f1 - flag: t -> draw, nil -> erase | |
201 ;;; f2 - flag: t -> erasing and need to draw ?\| | |
202 ;;; | |
203 (defun hanoi-draw-ring (ring f1 f2) | |
204 (save-excursion | |
205 (let* ((string (if f1 (aref ring 1) (aref ring 2))) | |
206 (len (length string))) | |
207 (delete-char len) | |
208 (insert string) | |
209 (if f2 | |
210 (progn | |
211 (backward-char (/ (+ len 1) 2)) | |
212 (delete-char 1) (insert ?\|)))))) | |
213 | |
1663
a5eec33a8f44
Tue Dec 1 22:34:42 1992 Jim Blandy (jimb@totoro.cs.oberlin.edu)
Jim Blandy <jimb@redhat.com>
parents:
845
diff
changeset
|
214 ;;; hanoi.el |