(eval-when-compile
(require 'cl)
(defvar baseward-step)
(defvar fly-step)
(defvar fly-row-start)
(defvar pole-width)
(defvar pole-char)
(defvar line-offset))
(defgroup hanoi nil
"The Towers of Hanoi."
:group 'games)
(defcustom hanoi-horizontal-flag nil
"*If non-nil, hanoi poles are oriented horizontally."
:group 'hanoi :type 'boolean)
(defcustom hanoi-move-period 1.0
"*Time, in seconds, for each pole-to-pole move of a ring.
If nil, move rings as fast as possible while displaying all
intermediate positions."
:group 'hanoi :type '(restricted-sexp :match-alternatives (numberp 'nil)))
(defcustom hanoi-use-faces nil
"*If nil, all hanoi-*-face variables are ignored."
:group 'hanoi :type 'boolean)
(defcustom hanoi-pole-face 'highlight
"*Face for poles. Ignored if hanoi-use-faces is nil."
:group 'hanoi :type 'face)
(defcustom hanoi-base-face 'highlight
"*Face for base. Ignored if hanoi-use-faces is nil."
:group 'hanoi :type 'face)
(defcustom hanoi-even-ring-face 'region
"*Face for even-numbered rings. Ignored if hanoi-use-faces is nil."
:group 'hanoi :type 'face)
(defcustom hanoi-odd-ring-face 'secondary-selection
"*Face for odd-numbered rings. Ignored if hanoi-use-faces is nil."
:group 'hanoi :type 'face)
(defun hanoi (nrings)
"Towers of Hanoi diversion. Use NRINGS rings."
(interactive
(list (if (null current-prefix-arg)
3
(prefix-numeric-value current-prefix-arg))))
(if (< nrings 0)
(error "Negative number of rings"))
(hanoi-internal nrings (make-list nrings 0) (hanoi-current-time-float)))
(defun hanoi-unix ()
"Towers of Hanoi, UNIX doomsday version.
Displays 32-ring towers that have been progressing at one move per
second since 1970-01-01 00:00:00 GMT.
Repent before ring 31 moves."
(interactive)
(let* ((start (ftruncate (hanoi-current-time-float)))
(bits (loop repeat 32
for x = (/ start (expt 2.0 31)) then (* x 2.0)
collect (truncate (mod x 2.0))))
(hanoi-move-period 1.0))
(hanoi-internal 32 bits start)))
(defun hanoi-unix-64 ()
"Like hanoi-unix, but pretend to have a 64-bit clock.
This is, necessarily (as of Emacs 20.3), a crock. When the
current-time interface is made s2G-compliant, hanoi.el will need
to be updated."
(interactive)
(let* ((start (ftruncate (hanoi-current-time-float)))
(bits (loop repeat 64
for x = (/ start (expt 2.0 63)) then (* x 2.0)
collect (truncate (mod x 2.0))))
(hanoi-move-period 1.0))
(hanoi-internal 64 bits start)))
(defun hanoi-internal (nrings bits start-time)
"Towers of Hanoi internal interface. Use NRINGS rings.
Start after n steps, where BITS is a big-endian list of the bits of n.
BITS must be of length nrings. Start at START-TIME."
(switch-to-buffer "*Hanoi*")
(buffer-disable-undo (current-buffer))
(unwind-protect
(let*
( (vert (not hanoi-horizontal-flag))
(pole-width (length (format "%d" (max 0 (1- nrings)))))
(pole-char (if vert ?\| ?\-))
(base-char (if vert ?\= ?\|))
(base-len (max (+ 8 (* pole-width 3))
(1- (if vert (window-width) (window-height)))))
(max-ring-diameter (/ (- base-len 2) 3))
(pole1-coord (/ max-ring-diameter 2))
(pole2-coord (/ base-len 2))
(pole3-coord (- base-len (/ (1+ max-ring-diameter) 2)))
(pole-coords (list pole1-coord pole2-coord pole3-coord))
(base-lines
(min 3 (max 0 (- (1- (if vert (window-height) (window-width)))
(+ 2 nrings)))))
line-offset
fly-row-start
fly-step
baseward-step
)
(setq buffer-read-only nil)
(erase-buffer)
(setq truncate-lines t)
(if hanoi-horizontal-flag
(progn
(setq line-offset (+ base-lines nrings 3))
(setq fly-row-start (1- line-offset))
(setq fly-step line-offset)
(setq baseward-step -1)
(loop repeat base-len do
(unless (zerop base-lines)
(insert-char ?\ (1- base-lines))
(insert base-char)
(hanoi-put-face (1- (point)) (point) hanoi-base-face))
(insert-char ?\ (+ 2 nrings))
(insert ?\n))
(delete-char -1)
(loop for coord in pole-coords do
(loop for row from (- coord (/ pole-width 2))
for start = (+ (* row line-offset) base-lines 1)
repeat pole-width do
(subst-char-in-region start (+ start nrings 1)
?\ pole-char)
(hanoi-put-face start (+ start nrings 1)
hanoi-pole-face))))
(setq line-offset (1+ base-len))
(setq fly-step 1)
(setq baseward-step line-offset)
(let ((extra-lines (- (1- (window-height)) (+ nrings 2) base-lines)))
(insert-char ?\n (max 0 extra-lines))
(setq fly-row-start (point))
(insert-char ?\ base-len)
(insert ?\n)
(loop repeat (1+ nrings)
with pole-line =
(loop with line = (make-string base-len ?\ )
for coord in pole-coords
for start = (- coord (/ pole-width 2))
for end = (+ start pole-width) do
(hanoi-put-face start end hanoi-pole-face line)
(loop for i from start below end do
(aset line i pole-char))
finally return line)
do (insert pole-line ?\n))
(insert-char base-char base-len)
(hanoi-put-face (- (point) base-len) (point) hanoi-base-face)
(set-window-start (selected-window)
(1+ (* baseward-step
(max 0 (- extra-lines)))))))
(let
( (poles (loop for coord in pole-coords
for fly-pos = (+ fly-row-start (* fly-step coord))
for base = (+ fly-pos (* baseward-step (+ 2 nrings)))
collect (cons base fly-pos)))
(rings
(loop
with max-radius = (min nrings
(/ (- max-ring-diameter pole-width) 2))
for n from (1- nrings) downto 0
for radius = (1+ (/ (* n max-radius) nrings))
for diameter = (+ pole-width (* 2 radius))
with format-str = (format "%%0%dd" pole-width)
for str = (concat (if vert "<" "^")
(make-string (1- radius) (if vert ?\- ?\|))
(format format-str n)
(make-string (1- radius) (if vert ?\- ?\|))
(if vert ">" "v"))
for face =
(if (eq (logand n 1) 1) hanoi-odd-ring-face hanoi-even-ring-face)
do (hanoi-put-face 0 (length str) face str)
collect (cons str diameter)))
(line-number-mode nil) (column-number-mode nil))
(hanoi-n bits rings (car poles) (cadr poles) (caddr poles)
start-time))
(message "Done"))
(setq buffer-read-only t)
(force-mode-line-update)))
(defun hanoi-current-time-float ()
"Return values from current-time combined into a single float."
(destructuring-bind (high low micros) (current-time)
(+ (* high 65536.0) low (/ micros 1000000.0))))
(defun hanoi-put-face (start end value &optional object)
"If hanoi-use-faces is non-nil, call put-text-property for face property."
(if hanoi-use-faces
(put-text-property start end 'face value object)))
(defun hanoi-0 (rings from to work start-time)
(if (null rings)
start-time
(hanoi-0 (cdr rings) work to from
(hanoi-move-ring (car rings) from to
(hanoi-0 (cdr rings) from work to start-time)))))
(defun hanoi-n (bits rings from to work start-time)
(cond ((null rings)
(hanoi-sit-for 0)
start-time)
((zerop (car bits))
(hanoi-insert-ring (car rings) from)
(hanoi-0 (cdr rings) work to from
(hanoi-move-ring (car rings) from to
(hanoi-n (cdr bits) (cdr rings) from work to
start-time))))
(t
(hanoi-insert-ring (car rings) to)
(hanoi-n (cdr bits) (cdr rings) work to from start-time))))
(defun hanoi-insert-ring (ring pole)
(decf (car pole) baseward-step)
(let ((str (car ring))
(start (- (car pole) (* (/ (cdr ring) 2) fly-step))))
(setcar ring (car pole))
(loop for pos upfrom start by fly-step
for i below (cdr ring) do
(subst-char-in-region pos (1+ pos) (char-after pos) (aref str i))
(set-text-properties pos (1+ pos) (text-properties-at i str)))
(hanoi-goto-char (car pole))))
(defun hanoi-goto-char (pos)
(goto-char (if (or hanoi-horizontal-flag (<= (window-start) pos))
pos
(+ (window-start) (% (- pos fly-row-start) baseward-step)))))
(defun hanoi-move-ring (ring from to start-time)
(incf (car from) baseward-step)
(decf (car to) baseward-step)
(let* ((flyward-steps (/ (- (car ring) (cdr from)) baseward-step))
(fly-steps (abs (/ (- (cdr to) (cdr from)) fly-step)))
(directed-fly-step (/ (- (cdr to) (cdr from)) fly-steps))
(baseward-steps (/ (- (car to) (cdr to)) baseward-step))
(total-steps (+ flyward-steps fly-steps baseward-steps))
(ticks-per-pole-step (if hanoi-horizontal-flag 1 2))
(ticks-per-fly-step (if hanoi-horizontal-flag 2 1))
(flyward-ticks (* ticks-per-pole-step flyward-steps))
(fly-ticks (* ticks-per-fly-step fly-steps))
(baseward-ticks (* ticks-per-pole-step baseward-steps))
(total-ticks (+ flyward-ticks fly-ticks baseward-ticks))
(tick-to-pos
(lambda (tick)
(cond
((<= tick flyward-ticks)
(+ (cdr from)
(* baseward-step
(- flyward-steps (/ tick ticks-per-pole-step)))))
((<= tick (+ flyward-ticks fly-ticks))
(+ (cdr from)
(* directed-fly-step
(/ (- tick flyward-ticks) ticks-per-fly-step))))
(t
(+ (cdr to)
(* baseward-step
(/ (- tick flyward-ticks fly-ticks)
ticks-per-pole-step))))))))
(if hanoi-move-period
(loop for elapsed = (- (hanoi-current-time-float) start-time)
while (< elapsed hanoi-move-period)
with tick-period = (/ (float hanoi-move-period) total-ticks)
for tick = (ceiling (/ elapsed tick-period)) do
(hanoi-ring-to-pos ring (funcall tick-to-pos tick))
(hanoi-sit-for (- (* tick tick-period) elapsed)))
(loop for tick from 1 to total-ticks by 2 do
(hanoi-ring-to-pos ring (funcall tick-to-pos tick))
(hanoi-sit-for 0)))
(hanoi-ring-to-pos ring (car to))
(if hanoi-move-period (+ start-time hanoi-move-period))))
(defun hanoi-sit-for (seconds)
(unless (sit-for seconds)
(signal 'quit '("I can tell you've had enough"))))
(defun hanoi-ring-to-pos (ring pos)
(unless (= (car ring) pos)
(let* ((start (- (car ring) (* (/ (cdr ring) 2) fly-step)))
(new-start (- pos (- (car ring) start))))
(if hanoi-horizontal-flag
(loop for i below (cdr ring)
for j = (if (< new-start start) i (- (cdr ring) i 1))
for old-pos = (+ start (* j fly-step))
for new-pos = (+ new-start (* j fly-step)) do
(transpose-regions old-pos (1+ old-pos) new-pos (1+ new-pos)))
(let ((end (+ start (cdr ring)))
(new-end (+ new-start (cdr ring))))
(if (< (abs (- new-start start)) (- end start))
(if (< start new-start)
(setq new-start end)
(setq new-end start)))
(transpose-regions start end new-start new-end t))))
(unless (eq (hanoi-pos-on-tower-p (car ring)) (hanoi-pos-on-tower-p pos))
(let* ((pole-start (- (car ring) (* fly-step (/ pole-width 2))))
(pole-end (+ pole-start (* fly-step pole-width)))
(on-pole (hanoi-pos-on-tower-p (car ring)))
(new-char (if on-pole pole-char ?\ ))
(curr-char (if on-pole ?\ pole-char))
(face (if on-pole hanoi-pole-face nil)))
(if hanoi-horizontal-flag
(loop for pos from pole-start below pole-end by line-offset do
(subst-char-in-region pos (1+ pos) curr-char new-char)
(hanoi-put-face pos (1+ pos) face))
(subst-char-in-region pole-start pole-end curr-char new-char)
(hanoi-put-face pole-start pole-end face))))
(setcar ring pos))
(hanoi-goto-char pos))
(defun hanoi-pos-on-tower-p (pos)
(if hanoi-horizontal-flag
(/= (% pos fly-step) fly-row-start)
(>= pos (+ fly-row-start baseward-step))))
(provide 'hanoi)