Mercurial > hg > xemacs-beta

comparison lisp/games/hanoi.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents 376386a54a3c
children 131b0175ea99
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
6 6
7 ; Author (a) 1985, Damon Anton Permezel 7 ; Author (a) 1985, Damon Anton Permezel
8 ; This is in the public domain 8 ; This is in the public domain
9 ; since he distributed it without copyright notice in 1985. 9 ; since he distributed it without copyright notice in 1985.
10 10
11 ;;; Synched up with: FSF 19.30. 11 ;; This file is part of XEmacs.
12
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
17
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the Free
25 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
26 ;; 02111-1307, USA.
27
28 ;;; Synched up with: FSF 19.34.
12 29
13 ;;; Commentary: 30 ;;; Commentary:
14 31
15 ;; Solves the Towers of Hanoi puzzle while-U-wait. 32 ;; Solves the Towers of Hanoi puzzle while-U-wait.
16 ;; 33 ;;
55 ;;;###autoload 72 ;;;###autoload
56 (defun hanoi (nrings) 73 (defun hanoi (nrings)
57 "Towers of Hanoi diversion. Argument is number of rings." 74 "Towers of Hanoi diversion. Argument is number of rings."
58 (interactive 75 (interactive
59 (list (if (null current-prefix-arg) 76 (list (if (null current-prefix-arg)
60 3 77 3
61 (prefix-numeric-value current-prefix-arg)))) 78 (prefix-numeric-value current-prefix-arg))))
62 (if (<= nrings 0) (error "Negative number of rings")) 79 (if (<= nrings 0) (error "Negative number of rings"))
63 (let* (floor-row 80 (let* (floor-row
64 fly-row 81 fly-row
65 (window-height (window-height (selected-window))) 82 (window-height (1- (window-height (selected-window))))
66 (window-width (window-width (selected-window))) 83 (window-width (window-width (selected-window)))
67 84
68 ;; This is the unit of spacing to use between poles. It 85 ;; This is half the spacing to use between poles.
69 ;; must be even. We round down, since rounding up might 86 (pole-spacing (/ window-width 6)))
70 ;; cause us to draw off the edge of the window. 87 (if (not (and (> window-height (1+ nrings))
71 (pole-spacing (logand (/ window-width 6) (lognot 1)))) 88 (> pole-spacing nrings)))
72 (let ( 89 (progn
73 ;; The poles are (1+ NRINGS) rows high; we also want an 90 (delete-other-windows)
74 ;; empty row at the top for the flying rings, a base, and a 91 (if (not (and (> (setq window-height
75 ;; blank line underneath that. 92 (1- (window-height (selected-window))))
76 (h (+ nrings 4)) 93 (1+ nrings))
77 94 (> (setq pole-spacing (/ window-width 6))
78 ;; If we have NRINGS rings, we label them with the numbers 0 95 nrings)))
79 ;; through NRINGS-1. The width of ring i is 2i+3; it pokes 96 (error "Window is too small (need at least %dx%d)"
80 ;; out i spaces on either side of the pole. Rather than 97 (* 6 (1+ nrings)) (+ 2 nrings)))))
81 ;; checking if the window is wide enough to accommodate this, 98 (setq floor-row (if (> (- window-height 3) (1+ nrings))
82 ;; we make sure pole-spacing is large enough, since that 99 (- window-height 3) window-height))
83 ;; works even when we have decremented pole-spacing to make
84 ;; it even.
85 (w (1+ nrings)))
86 (if (not (and (>= window-height h)
87 (> pole-spacing w)))
88 (progn
89 (delete-other-windows)
90 (if (not (and (>= (setq window-height
91 (window-height (selected-window)))
92 h)
93 (> (setq pole-spacing
94 (logand (/ window-width 6) (lognot 1)))
95 w)))
96 (error "Screen is too small (need at least %dx%d)" w h))))
97 (setq floor-row (if (> (- window-height 3) h)
98 (- window-height 3) window-height)))
99 (let ((fly-row (- floor-row nrings 1)) 100 (let ((fly-row (- floor-row nrings 1))
100 ;; pole: column . fill height 101 ;; pole: column . fill height
101 (pole-1 (cons pole-spacing floor-row)) 102 (pole-1 (cons (1- pole-spacing) floor-row))
102 (pole-2 (cons (* 3 pole-spacing) floor-row)) 103 (pole-2 (cons (1- (* 3 pole-spacing)) floor-row))
103 (pole-3 (cons (* 5 pole-spacing) floor-row)) 104 (pole-3 (cons (1- (* 5 pole-spacing)) floor-row))
104 (rings (make-vector nrings nil))) 105 (rings (make-vector nrings nil)))
105 ;; construct the ring list 106 ;; construct the ring list
106 (let ((i 0)) 107 (let ((i 0))
107 (while (< i nrings) 108 (while (< i nrings)
108 ;; ring: [pole-number string empty-string] 109 ;; ring: [pole-number string empty-string]
109 (aset rings i (vector nil 110 (aset rings i (vector nil
110 (make-string (+ i i 3) (+ ?0 i)) 111 (make-string (+ i i 3) (+ ?0 (% i 10)))
111 (make-string (+ i i 3) ?\ ))) 112 (make-string (+ i i 3) ?\ )))
112 (setq i (1+ i)))) 113 (setq i (1+ i))))
113 ;; 114 ;;
114 ;; init the screen 115 ;; init the screen
115 ;; 116 ;;
124 (insert ?\n))) 125 (insert ?\n)))
125 (insert-char ?= (1- window-width)) 126 (insert-char ?= (1- window-width))
126 127
127 (let ((n 1)) 128 (let ((n 1))
128 (while (< n 6) 129 (while (< n 6)
129 (hanoi-topos fly-row (* n pole-spacing)) 130 (hanoi-topos fly-row (1- (* n pole-spacing)))
130 (setq n (+ n 2)) 131 (setq n (+ n 2))
131 (let ((i fly-row)) 132 (let ((i fly-row))
132 (while (< i floor-row) 133 (while (< i floor-row)
133 (setq i (1+ i)) 134 (setq i (1+ i))
134 (next-line 1) 135 (next-line 1)
149 (hanoi-draw-ring ring t nil) 150 (hanoi-draw-ring ring t nil)
150 (setcdr pole-1 (1- (cdr pole-1))) 151 (setcdr pole-1 (1- (cdr pole-1)))
151 (setq i (1+ i)))) 152 (setq i (1+ i))))
152 (setq buffer-read-only t) 153 (setq buffer-read-only t)
153 (sit-for 0) 154 (sit-for 0)
154 ;; 155 ;; Disable display of line and column numbers, for speed.
155 ;; do it! 156 (let ((line-number-mode nil)
156 ;; 157 (column-number-mode nil))
157 (hanoi0 (1- nrings) pole-1 pole-2 pole-3) 158 ;; do it!
159 (hanoi0 (1- nrings) pole-1 pole-2 pole-3))
158 (goto-char (point-min)) 160 (goto-char (point-min))
159 (message "Done") 161 (message "Done")
160 (setq buffer-read-only t) 162 (setq buffer-read-only t)
161 (force-mode-line-update) 163 (force-mode-line-update)
162 (sit-for 0)))) 164 (sit-for 0))))