Mercurial > emacs
annotate lisp/play/hanoi.el @ 52392:ea78742dd7ca
(w32_per_char_metric): Allow cached metrics to be
returned even when font_type is unknown.
author | Jason Rumney <jasonr@gnu.org> |
---|---|
date | Sun, 31 Aug 2003 22:15:15 +0000 |
parents | 0d8b17d428b5 |
children | 695cf19ef79e |
rev | line source |
---|---|
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
1 ;;; hanoi.el --- towers of hanoi in Emacs |
660
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. |
38412
253f761ad37b
Some fixes to follow coding conventions in files maintained by FSF.
Pavel Janík <Pavel@Janik.cz>
parents:
28091
diff
changeset
|
10 ;; This file is part of GNU Emacs. |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
11 ; |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
12 ; Support for horizontal poles, large numbers of rings, real-time, |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
13 ; faces, defcustom, and Towers of Unix added in 1999 by Alakazam |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
14 ; Petrofsky <Alakazam@Petrofsky.Berkeley.CA.US>. |
53 | 15 |
2307
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
16 ;;; Commentary: |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
17 |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
18 ;; Solves the Towers of Hanoi puzzle while-U-wait. |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
19 ;; |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
20 ;; The puzzle: Start with N rings, decreasing in sizes from bottom to |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
21 ;; top, stacked around a post. There are two other posts. Your mission, |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
22 ;; should you choose to accept it, is to shift the pile, stacked in its |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
23 ;; original order, to another post. |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
24 ;; |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
25 ;; The challenge is to do it in the fewest possible moves. Each move |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
26 ;; shifts one ring to a different post. But there's a rule; you can |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
27 ;; only stack a ring on top of a larger one. |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
28 ;; |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
29 ;; The simplest nontrivial version of this puzzle is N = 3. Solution |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
30 ;; time rises as 2**N, and programs to solve it have long been considered |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
31 ;; classic introductory exercises in the use of recursion. |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
32 ;; |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
33 ;; The puzzle is called `Towers of Hanoi' because an early popular |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
34 ;; presentation wove a fanciful legend around it. According to this |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
35 ;; myth (uttered long before the Vietnam War), there is a Buddhist |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
36 ;; monastery at Hanoi which contains a large room with three time-worn |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
37 ;; posts in it surrounded by 21 golden discs. Monks, acting out the |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
38 ;; command of an ancient prophecy, have been moving these disks, in |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
39 ;; accordance with the rules of the puzzle, once every day since the |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
40 ;; monastery was founded over a thousand years ago. They are said to |
2307
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
41 ;; believe that when the last move of the puzzle is completed, the |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
42 ;; world will end in a clap of thunder. Fortunately, they are nowhere |
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
43 ;; even close to being done... |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
44 ;; |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
45 ;; 1999 addition: The `Towers of Unix' command (hanoi-unix) stems from |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
46 ;; the never-disproven legend of a Eunuch monastery at Princeton that |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
47 ;; contains a large air-conditioned room with three time-worn posts in |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
48 ;; it surrounded by 32 silicon discs. Nimble monks, acting out the |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
49 ;; command of an ancient prophecy, have been moving these disks, in |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
50 ;; accordance with the rules of the puzzle, once every second since |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
51 ;; the monastery was founded almost a billion seconds ago. They are |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
52 ;; said to believe that when the last move of the puzzle is completed, |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
53 ;; the world will reboot in a clap of thunder. Actually, because the |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
54 ;; bottom disc is blocked by the "Do not feed the monks" sign, it is |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
55 ;; believed the End will come at the time that disc is to be moved... |
2307
10e417efb12a
Added or corrected Commentary sections
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
1663
diff
changeset
|
56 |
793
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
57 ;;; Code: |
6fb68a1460a6
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
663
diff
changeset
|
58 |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
59 (eval-when-compile |
25329 | 60 (require 'cl) |
61 ;; dynamic bondage: | |
62 (defvar baseward-step) | |
63 (defvar fly-step) | |
64 (defvar fly-row-start) | |
65 (defvar pole-width) | |
66 (defvar pole-char) | |
67 (defvar line-offset)) | |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
68 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
69 (defgroup hanoi nil |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
70 "The Towers of Hanoi." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
71 :group 'games) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
72 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
73 (defcustom hanoi-horizontal-flag nil |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
74 "*If non-nil, hanoi poles are oriented horizontally." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
75 :group 'hanoi :type 'boolean) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
76 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
77 (defcustom hanoi-move-period 1.0 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
78 "*Time, in seconds, for each pole-to-pole move of a ring. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
79 If nil, move rings as fast as possible while displaying all |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
80 intermediate positions." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
81 :group 'hanoi :type '(restricted-sexp :match-alternatives (numberp 'nil))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
82 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
83 (defcustom hanoi-use-faces nil |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
84 "*If nil, all hanoi-*-face variables are ignored." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
85 :group 'hanoi :type 'boolean) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
86 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
87 (defcustom hanoi-pole-face 'highlight |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
88 "*Face for poles. Ignored if hanoi-use-faces is nil." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
89 :group 'hanoi :type 'face) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
90 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
91 (defcustom hanoi-base-face 'highlight |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
92 "*Face for base. Ignored if hanoi-use-faces is nil." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
93 :group 'hanoi :type 'face) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
94 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
95 (defcustom hanoi-even-ring-face 'region |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
96 "*Face for even-numbered rings. Ignored if hanoi-use-faces is nil." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
97 :group 'hanoi :type 'face) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
98 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
99 (defcustom hanoi-odd-ring-face 'secondary-selection |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
100 "*Face for odd-numbered rings. Ignored if hanoi-use-faces is nil." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
101 :group 'hanoi :type 'face) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
102 |
53 | 103 |
104 ;;; | |
105 ;;; hanoi - user callable Towers of Hanoi | |
106 ;;; | |
258 | 107 ;;;###autoload |
53 | 108 (defun hanoi (nrings) |
49598
0d8b17d428b5
Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
38412
diff
changeset
|
109 "Towers of Hanoi diversion. Use NRINGS rings." |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
110 (interactive |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
111 (list (if (null current-prefix-arg) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
112 3 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
113 (prefix-numeric-value current-prefix-arg)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
114 (if (< nrings 0) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
115 (error "Negative number of rings")) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
116 (hanoi-internal nrings (make-list nrings 0) (hanoi-current-time-float))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
117 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
118 ;;;###autoload |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
119 (defun hanoi-unix () |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
120 "Towers of Hanoi, UNIX doomsday version. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
121 Displays 32-ring towers that have been progressing at one move per |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
122 second since 1970-01-01 00:00:00 GMT. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
123 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
124 Repent before ring 31 moves." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
125 (interactive) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
126 (let* ((start (ftruncate (hanoi-current-time-float))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
127 (bits (loop repeat 32 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
128 for x = (/ start (expt 2.0 31)) then (* x 2.0) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
129 collect (truncate (mod x 2.0)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
130 (hanoi-move-period 1.0)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
131 (hanoi-internal 32 bits start))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
132 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
133 ;;;###autoload |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
134 (defun hanoi-unix-64 () |
49598
0d8b17d428b5
Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
38412
diff
changeset
|
135 "Like hanoi-unix, but pretend to have a 64-bit clock. |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
136 This is, necessarily (as of emacs 20.3), a crock. When the |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
137 current-time interface is made s2G-compliant, hanoi.el will need |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
138 to be updated." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
139 (interactive) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
140 (let* ((start (ftruncate (hanoi-current-time-float))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
141 (bits (loop repeat 64 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
142 for x = (/ start (expt 2.0 63)) then (* x 2.0) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
143 collect (truncate (mod x 2.0)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
144 (hanoi-move-period 1.0)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
145 (hanoi-internal 64 bits start))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
146 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
147 (defun hanoi-internal (nrings bits start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
148 "Towers of Hanoi internal interface. Use NRINGS rings. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
149 Start after n steps, where BITS is a big-endian list of the bits of n. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
150 BITS must be of length nrings. Start at START-TIME." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
151 (switch-to-buffer "*Hanoi*") |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
152 (buffer-disable-undo (current-buffer)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
153 (unwind-protect |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
154 (let* |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
155 (;; These lines can cause emacs to crash if you ask for too |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
156 ;; many rings. If you uncomment them, on most systems you |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
157 ;; can get 10,000+ rings. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
158 ;;(max-specpdl-size (max max-specpdl-size (* nrings 15))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
159 ;;(max-lisp-eval-depth (max max-lisp-eval-depth (+ nrings 20))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
160 (vert (not hanoi-horizontal-flag)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
161 (pole-width (length (format "%d" (max 0 (1- nrings))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
162 (pole-char (if vert ?\| ?\-)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
163 (base-char (if vert ?\= ?\|)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
164 (base-len (max (+ 8 (* pole-width 3)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
165 (1- (if vert (window-width) (window-height))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
166 (max-ring-diameter (/ (- base-len 2) 3)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
167 (pole1-coord (/ max-ring-diameter 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
168 (pole2-coord (/ base-len 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
169 (pole3-coord (- base-len (/ (1+ max-ring-diameter) 2))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
170 (pole-coords (list pole1-coord pole2-coord pole3-coord)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
171 ;; Number of lines displayed below the bottom-most rings. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
172 (base-lines |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
173 (min 3 (max 0 (- (1- (if vert (window-height) (window-width))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
174 (+ 2 nrings))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
175 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
176 ;; These variables will be set according to hanoi-horizontal-flag: |
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
|
177 |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
178 ;; line-offset is the number of characters per line in the buffer. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
179 line-offset |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
180 ;; fly-row-start is the buffer position of the leftmost or |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
181 ;; uppermost position in the fly row. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
182 fly-row-start |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
183 ;; Adding fly-step to a buffer position moves you one step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
184 ;; along the fly row in the direction from pole1 to pole2. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
185 fly-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
186 ;; Adding baseward-step to a buffer position moves you one step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
187 ;; toward the base. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
188 baseward-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
189 ) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
190 (setq buffer-read-only nil) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
191 (erase-buffer) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
192 (setq truncate-lines t) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
193 (if hanoi-horizontal-flag |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
194 (progn |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
195 (setq line-offset (+ base-lines nrings 3)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
196 (setq fly-row-start (1- line-offset)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
197 (setq fly-step line-offset) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
198 (setq baseward-step -1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
199 (loop repeat base-len do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
200 (unless (zerop base-lines) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
201 (insert-char ?\ (1- base-lines)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
202 (insert base-char) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
203 (hanoi-put-face (1- (point)) (point) hanoi-base-face)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
204 (insert-char ?\ (+ 2 nrings)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
205 (insert ?\n)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
206 (delete-char -1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
207 (loop for coord in pole-coords do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
208 (loop for row from (- coord (/ pole-width 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
209 for start = (+ (* row line-offset) base-lines 1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
210 repeat pole-width do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
211 (subst-char-in-region start (+ start nrings 1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
212 ?\ pole-char) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
213 (hanoi-put-face start (+ start nrings 1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
214 hanoi-pole-face)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
215 ;; vertical |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
216 (setq line-offset (1+ base-len)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
217 (setq fly-step 1) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
218 (setq baseward-step line-offset) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
219 (let ((extra-lines (- (1- (window-height)) (+ nrings 2) base-lines))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
220 (insert-char ?\n (max 0 extra-lines)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
221 (setq fly-row-start (point)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
222 (insert-char ?\ base-len) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
223 (insert ?\n) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
224 (loop repeat (1+ nrings) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
225 with pole-line = |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
226 (loop with line = (make-string base-len ?\ ) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
227 for coord in pole-coords |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
228 for start = (- coord (/ pole-width 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
229 for end = (+ start pole-width) do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
230 (hanoi-put-face start end hanoi-pole-face line) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
231 (loop for i from start below end do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
232 (aset line i pole-char)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
233 finally return line) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
234 do (insert pole-line ?\n)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
235 (insert-char base-char base-len) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
236 (hanoi-put-face (- (point) base-len) (point) hanoi-base-face) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
237 (set-window-start (selected-window) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
238 (1+ (* baseward-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
239 (max 0 (- extra-lines))))))) |
53 | 240 |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
241 (let |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
242 (;; each pole is a pair of buffer positions: |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
243 ;; the car is the position of the top ring currently on the pole, |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
244 ;; (or the base of the pole if it is empty). |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
245 ;; the cdr is in the fly-row just above the pole. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
246 (poles (loop for coord in pole-coords |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
247 for fly-pos = (+ fly-row-start (* fly-step coord)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
248 for base = (+ fly-pos (* baseward-step (+ 2 nrings))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
249 collect (cons base fly-pos))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
250 ;; compute the string for each ring and make the list of |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
251 ;; ring pairs. Each ring pair is initially (str . diameter). |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
252 ;; Once placed in buffer it is changed to (center-pos . diameter). |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
253 (rings |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
254 (loop |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
255 ;; radii are measured from the edge of the pole out. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
256 ;; So diameter = 2 * radius + pole-width. When |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
257 ;; there's room, we make each ring's radius = |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
258 ;; pole-number + 1. If there isn't room, we step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
259 ;; evenly from the max radius down to 1. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
260 with max-radius = (min nrings |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
261 (/ (- max-ring-diameter pole-width) 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
262 for n from (1- nrings) downto 0 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
263 for radius = (1+ (/ (* n max-radius) nrings)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
264 for diameter = (+ pole-width (* 2 radius)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
265 with format-str = (format "%%0%dd" pole-width) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
266 for str = (concat (if vert "<" "^") |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
267 (make-string (1- radius) (if vert ?\- ?\|)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
268 (format format-str n) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
269 (make-string (1- radius) (if vert ?\- ?\|)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
270 (if vert ">" "v")) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
271 for face = |
28091 | 272 (if (eq (logand n 1) 1) ; oddp would require cl at runtime |
273 hanoi-odd-ring-face hanoi-even-ring-face) | |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
274 do (hanoi-put-face 0 (length str) face str) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
275 collect (cons str diameter))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
276 ;; Disable display of line and column numbers, for speed. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
277 (line-number-mode nil) (column-number-mode nil)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
278 ;; do it! |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
279 (hanoi-n bits rings (car poles) (cadr poles) (caddr poles) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
280 start-time)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
281 (message "Done")) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
282 (setq buffer-read-only t) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
283 (force-mode-line-update))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
284 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
285 (defun hanoi-current-time-float () |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
286 "Return values from current-time combined into a single float." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
287 (destructuring-bind (high low micros) (current-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
288 (+ (* high 65536.0) low (/ micros 1000000.0)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
289 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
290 (defun hanoi-put-face (start end value &optional object) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
291 "If hanoi-use-faces is non-nil, call put-text-property for face property." |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
292 (if hanoi-use-faces |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
293 (put-text-property start end 'face value object))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
294 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
295 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
296 ;;; Functions with a start-time argument (hanoi-0, hanoi-n, and |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
297 ;;; hanoi-move-ring) start working at start-time and return the ending |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
298 ;;; time. If hanoi-move-period is nil, start-time is ignored and the |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
299 ;;; return value is junk. |
53 | 300 |
301 ;;; | |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
302 ;;; hanoi-0 - work horse of hanoi |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
303 (defun hanoi-0 (rings from to work start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
304 (if (null rings) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
305 start-time |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
306 (hanoi-0 (cdr rings) work to from |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
307 (hanoi-move-ring (car rings) from to |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
308 (hanoi-0 (cdr rings) from work to start-time))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
309 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
310 ;; start after n moves, where BITS is a big-endian list of the bits of n. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
311 ;; BITS must be of same length as rings. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
312 (defun hanoi-n (bits rings from to work start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
313 (cond ((null rings) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
314 ;; All rings have been placed in starting positions. Update display. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
315 (hanoi-sit-for 0) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
316 start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
317 ((zerop (car bits)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
318 (hanoi-insert-ring (car rings) from) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
319 (hanoi-0 (cdr rings) work to from |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
320 (hanoi-move-ring (car rings) from to |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
321 (hanoi-n (cdr bits) (cdr rings) from work to |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
322 start-time)))) |
53 | 323 (t |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
324 (hanoi-insert-ring (car rings) to) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
325 (hanoi-n (cdr bits) (cdr rings) work to from start-time)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
326 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
327 ;; put never-before-placed RING on POLE and update their cars. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
328 (defun hanoi-insert-ring (ring pole) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
329 (decf (car pole) baseward-step) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
330 (let ((str (car ring)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
331 (start (- (car pole) (* (/ (cdr ring) 2) fly-step)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
332 (setcar ring (car pole)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
333 (loop for pos upfrom start by fly-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
334 for i below (cdr ring) do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
335 (subst-char-in-region pos (1+ pos) (char-after pos) (aref str i)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
336 (set-text-properties pos (1+ pos) (text-properties-at i str))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
337 (hanoi-goto-char (car pole)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
338 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
339 ;; like goto-char, but if position is outside the window, then move to |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
340 ;; corresponding position in the first row displayed. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
341 (defun hanoi-goto-char (pos) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
342 (goto-char (if (or hanoi-horizontal-flag (<= (window-start) pos)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
343 pos |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
344 (+ (window-start) (% (- pos fly-row-start) baseward-step))))) |
53 | 345 |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
346 ;; do one pole-to-pole move and update the ring and pole pairs. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
347 (defun hanoi-move-ring (ring from to start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
348 (incf (car from) baseward-step) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
349 (decf (car to) baseward-step) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
350 (let* ;; We move flywards-steps steps up the pole to the fly row, |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
351 ;; then fly fly-steps steps across the fly row, then go |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
352 ;; baseward-steps steps down the new pole. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
353 ((flyward-steps (/ (- (car ring) (cdr from)) baseward-step)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
354 (fly-steps (abs (/ (- (cdr to) (cdr from)) fly-step))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
355 (directed-fly-step (/ (- (cdr to) (cdr from)) fly-steps)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
356 (baseward-steps (/ (- (car to) (cdr to)) baseward-step)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
357 (total-steps (+ flyward-steps fly-steps baseward-steps)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
358 ;; A step is a character cell. A tick is a time-unit. To |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
359 ;; make horizontal and vertical motion appear roughly the |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
360 ;; same speed, we allow one tick per horizontal step and two |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
361 ;; ticks per vertical step. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
362 (ticks-per-pole-step (if hanoi-horizontal-flag 1 2)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
363 (ticks-per-fly-step (if hanoi-horizontal-flag 2 1)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
364 (flyward-ticks (* ticks-per-pole-step flyward-steps)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
365 (fly-ticks (* ticks-per-fly-step fly-steps)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
366 (baseward-ticks (* ticks-per-pole-step baseward-steps)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
367 (total-ticks (+ flyward-ticks fly-ticks baseward-ticks)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
368 (tick-to-pos |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
369 ;; Return the buffer position of the ring after TICK ticks. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
370 (lambda (tick) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
371 (cond |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
372 ((<= tick flyward-ticks) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
373 (+ (cdr from) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
374 (* baseward-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
375 (- flyward-steps (/ tick ticks-per-pole-step))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
376 ((<= tick (+ flyward-ticks fly-ticks)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
377 (+ (cdr from) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
378 (* directed-fly-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
379 (/ (- tick flyward-ticks) ticks-per-fly-step)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
380 (t |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
381 (+ (cdr to) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
382 (* baseward-step |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
383 (/ (- tick flyward-ticks fly-ticks) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
384 ticks-per-pole-step)))))))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
385 (if hanoi-move-period |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
386 (loop for elapsed = (- (hanoi-current-time-float) start-time) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
387 while (< elapsed hanoi-move-period) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
388 with tick-period = (/ (float hanoi-move-period) total-ticks) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
389 for tick = (ceiling (/ elapsed tick-period)) do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
390 (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
391 (hanoi-sit-for (- (* tick tick-period) elapsed))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
392 (loop for tick from 1 to total-ticks by 2 do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
393 (hanoi-ring-to-pos ring (funcall tick-to-pos tick)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
394 (hanoi-sit-for 0))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
395 ;; Always make last move to keep pole and ring data consistent |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
396 (hanoi-ring-to-pos ring (car to)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
397 (if hanoi-move-period (+ start-time hanoi-move-period)))) |
53 | 398 |
25259
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
399 ;; update display and pause, quitting with a pithy comment if the user |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
400 ;; hits a key. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
401 (defun hanoi-sit-for (seconds) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
402 (sit-for seconds) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
403 (if (input-pending-p) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
404 (signal 'quit '("I can tell you've had enough")))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
405 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
406 ;; move ring to a given buffer position and update ring's car. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
407 (defun hanoi-ring-to-pos (ring pos) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
408 (unless (= (car ring) pos) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
409 (let* ((start (- (car ring) (* (/ (cdr ring) 2) fly-step))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
410 (new-start (- pos (- (car ring) start)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
411 (if hanoi-horizontal-flag |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
412 (loop for i below (cdr ring) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
413 for j = (if (< new-start start) i (- (cdr ring) i 1)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
414 for old-pos = (+ start (* j fly-step)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
415 for new-pos = (+ new-start (* j fly-step)) do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
416 (transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
417 (let ((end (+ start (cdr ring))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
418 (new-end (+ new-start (cdr ring)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
419 (if (< (abs (- new-start start)) (- end start)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
420 ;; Overlap. Adjust bounds |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
421 (if (< start new-start) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
422 (setq new-start end) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
423 (setq new-end start))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
424 (transpose-regions start end new-start new-end t)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
425 ;; If moved on or off a pole, redraw pole chars. |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
426 (unless (eq (hanoi-pos-on-tower-p (car ring)) (hanoi-pos-on-tower-p pos)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
427 (let* ((pole-start (- (car ring) (* fly-step (/ pole-width 2)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
428 (pole-end (+ pole-start (* fly-step pole-width))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
429 (on-pole (hanoi-pos-on-tower-p (car ring))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
430 (new-char (if on-pole pole-char ?\ )) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
431 (curr-char (if on-pole ?\ pole-char)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
432 (face (if on-pole hanoi-pole-face nil))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
433 (if hanoi-horizontal-flag |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
434 (loop for pos from pole-start below pole-end by line-offset do |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
435 (subst-char-in-region pos (1+ pos) curr-char new-char) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
436 (hanoi-put-face pos (1+ pos) face)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
437 (subst-char-in-region pole-start pole-end curr-char new-char) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
438 (hanoi-put-face pole-start pole-end face)))) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
439 (setcar ring pos)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
440 (hanoi-goto-char pos)) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
441 |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
442 ;; Check if a buffer position lies on a tower (vis. in the fly row). |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
443 (defun hanoi-pos-on-tower-p (pos) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
444 (if hanoi-horizontal-flag |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
445 (/= (% pos fly-step) fly-row-start) |
9f7a9dceb11b
Mostly rewritten. Customized. To support an s2G
Karl Heuer <kwzh@gnu.org>
parents:
14570
diff
changeset
|
446 (>= pos (+ fly-row-start baseward-step)))) |
53 | 447 |
4031 | 448 (provide 'hanoi) |
449 | |
450 ;;; hanoi.el ends here |