284 lines
7.4 KiB
Bash
Executable File
284 lines
7.4 KiB
Bash
Executable File
#!/bin/sh
|
|
:;exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;;;
|
|
;;;; Hanoi - Towers of Hanoi diversion
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Last file update: 13-Sep-1999 18:00 (eg)
|
|
|
|
;;;; This program is a rewriting in STk of a program found on the net. Original
|
|
;;;; author is Damon A Permezel (probably fubar!dap@natinst.com)
|
|
;;;; Re-writing is very direct and needs much more working
|
|
;;;;
|
|
|
|
(define *gc-verbose* #f)
|
|
|
|
(define hanoi-canvas "")
|
|
(define hanoi-running #f)
|
|
(define hanoi-stop #f)
|
|
(define previousRings 0)
|
|
(define max-rings 20)
|
|
(define num-rings 6)
|
|
(define colours '(DarkOliveGreen snow4 royalblue2 palegreen4
|
|
rosybrown1 wheat4 tan2 brown2 tomato3 hotpink3))
|
|
|
|
(define pole (make-vector 3)) ; elts are <nRing . xPos>
|
|
(define ring (make-vector (+ max-rings 1))); elts are <pole width . obj>
|
|
|
|
(define accel 0)
|
|
(define base 32)
|
|
(define fly-row 32)
|
|
(define width-incr 12)
|
|
(define width-min (* 8 width-incr))
|
|
(define ring-height 26)
|
|
(define ring-spacing (* 2 (/ ring-height 3)))
|
|
|
|
|
|
;;
|
|
;; Setup the main window
|
|
;;
|
|
(define (SetupHanoi)
|
|
(wm 'title "." "Towers of Hanoi")
|
|
|
|
;;
|
|
;; setup frame and main menu button
|
|
;;
|
|
(label ".title" :text "Towers of Hanoi" :bd 4 :fg "RoyalBlue" :relief "ridge")
|
|
(frame ".f")
|
|
(button ".f.run" :text "Run" :command (lambda ()
|
|
(DoHanoi (.nrframe.scale 'get) #t)))
|
|
(button ".f.stop" :text "Stop" :command (lambda ()
|
|
(set! hanoi-stop 1)))
|
|
(button ".f.quit" :text "Quit" :command (lambda ()
|
|
(exit 0)))
|
|
(pack .f.run .f.stop .f.quit :fill "x" :side "left" :expand #t)
|
|
|
|
;;
|
|
;; setup next frame, for #rings slider
|
|
;;
|
|
(frame ".nrframe" :bd 2 :relief 'raised)
|
|
(pack [label ".nrframe.label" :text "Number of Rings: " :width 15 :anchor 'e]
|
|
:side "left")
|
|
(pack [scale ".nrframe.scale" :orient 'hor :from 1 :to max-rings
|
|
:font '(Courier -12)
|
|
:command (lambda (val)
|
|
(set! num-rings val))]
|
|
:side "right" :expand #t :fill "x")
|
|
(.nrframe.scale 'set num-rings)
|
|
|
|
;;
|
|
;; setup next frame, for speed slider
|
|
;;
|
|
(frame ".speed-frame" :bd 2 :relief 'raised)
|
|
(pack [label ".speed-frame.label" :text "Speed: " :width 15 :anchor 'e]
|
|
:side "left")
|
|
(pack [scale ".speed-frame.scale" :orient 'hor :from 1 :to 100
|
|
:font '(Courier -12)
|
|
:command (lambda (val)
|
|
(set! accel val))]
|
|
:side "right" :expand #t :fill "x")
|
|
(.speed-frame.scale 'set 100)
|
|
|
|
;;
|
|
;; setup frame for canvas to appear in
|
|
;;
|
|
(frame ".canv-frame" :bd 4 :relief 'groove)
|
|
(pack [canvas ".canv-frame.canvas" :relief 'sunken])
|
|
(set! hanoi-canvas .canv-frame.canvas)
|
|
|
|
;;
|
|
;; Pack evrybody
|
|
;;
|
|
(pack .title .nrframe .speed-frame .canv-frame .f :expand #t :fill "x")
|
|
|
|
;;
|
|
;; key bindings
|
|
;;
|
|
(bind "." "<KeyPress-r>" (lambda () (DoHanoi [.nrframe.scale 'get] #t)))
|
|
(bind "." "<KeyPress-s>" (lambda () (set! hanoi-stop #t)))
|
|
(bind "." "<KeyPress-q>" (lambda () (exit 0)))
|
|
|
|
;;
|
|
;; Display tower
|
|
;;
|
|
(DoHanoi num-rings #f)
|
|
)
|
|
|
|
;;
|
|
;; DoHanoi
|
|
;;
|
|
;; Input:
|
|
;; n # of rings
|
|
;;
|
|
;; setup the canvas for displaying the Hanoi simulation
|
|
;; Call hanoi if run-it is true.
|
|
;;
|
|
(define (DoHanoi n run-it)
|
|
(unless hanoi-running
|
|
(define ring-width (+ width-min (* n width-incr)))
|
|
(define wm-width (+ (* 3 ring-width) (* 4 12)))
|
|
(define wm-height (+ (* ring-spacing n) fly-row (* 2 ring-height)))
|
|
|
|
|
|
(set! hanoi-stop #f)
|
|
(set! hanoi-running #t)
|
|
(set! base (- wm-height 32))
|
|
|
|
;;
|
|
;; cleanup from previous run
|
|
;;
|
|
(do ((i 1 (+ i 1)))
|
|
((> i previousRings))
|
|
(hanoi-canvas 'delete (cddr (vector-ref ring i))))
|
|
|
|
;;
|
|
;; configure the canvas appropriately
|
|
;;
|
|
(hanoi-canvas 'configure :width wm-width :height wm-height)
|
|
|
|
;;
|
|
;; setup poles
|
|
;;
|
|
(let loop ((i 0))
|
|
(vector-set! pole i (cons 0 (+ (* i (/ wm-width 3)) (/ ring-width 2) 8)))
|
|
(when (< i 2) (loop (+ 1 i))))
|
|
;;
|
|
;; setup rings
|
|
;;
|
|
|
|
(let loop ((i 0))
|
|
(let* ((colour (list-ref colours (modulo i 10)))
|
|
(w (- ring-width (* i 12)))
|
|
(y (- base (* i ring-spacing)))
|
|
(x (- (cdr (vector-ref pole 0)) (/ w 2)))
|
|
(r (- n i)))
|
|
|
|
(vector-set! ring r
|
|
(cons 0
|
|
(cons w
|
|
(hanoi-canvas 'create
|
|
'oval x y (+ x w) (+ y ring-height)
|
|
:fill colour
|
|
:outline colour
|
|
:width 12)))))
|
|
(if (< i (- n 1)) (loop (+ i 1))))
|
|
|
|
(vector-set! pole 0 (cons n (cdr (vector-ref pole 0))))
|
|
(set! previousRings n)
|
|
|
|
(update)
|
|
(when run-it (Hanoi n 0 2 1))
|
|
(set! hanoi-running #f)))
|
|
;;
|
|
;; Hanoi : the guts of the algorithm
|
|
;;
|
|
;; Input:
|
|
;; n # of rings
|
|
;; from pole to move from
|
|
;; to pole to move to
|
|
;; work pole to aid in performing work
|
|
;;
|
|
(define (Hanoi n from to work)
|
|
(when (and (> n 0) (not hanoi-stop))
|
|
(Hanoi (- n 1) from work to)
|
|
(unless hanoi-stop (MoveRing n to))
|
|
(Hanoi (- n 1) work to from)))
|
|
|
|
;;
|
|
;; MoveRing : move a ring to a new pole
|
|
;;
|
|
;; Input:
|
|
;; n ring number
|
|
;; to destination pole
|
|
;;
|
|
(define (MoveRing n to)
|
|
;;
|
|
;; ring(n,obj) can be queried as to its current position.
|
|
;; Thus, we don't need to know which pole the ring is moving from.
|
|
;;
|
|
(let* ((inc 0)
|
|
(tox 0)
|
|
(toy 0)
|
|
|
|
(r (cddr (vector-ref ring n)))
|
|
(coords (hanoi-canvas 'coords r))
|
|
(x0 (list-ref coords 0))
|
|
(y0 (list-ref coords 1))
|
|
(x1 (list-ref coords 2))
|
|
(y1 (list-ref coords 3)))
|
|
|
|
;;
|
|
;; move up to the "fly row"
|
|
;;
|
|
(do ()
|
|
((<= y0 fly-row))
|
|
(set! inc (if (> (- y0 fly-row) accel) accel (- y0 fly-row)))
|
|
(set! y0 (- y0 inc))
|
|
(set! y1 (- y1 inc))
|
|
(hanoi-canvas 'coords r x0 y0 x1 y1)
|
|
(update))
|
|
|
|
;;
|
|
;; one less ring on this pole
|
|
;;
|
|
(let ((tmp (car (vector-ref ring n))))
|
|
(set-car! (vector-ref pole tmp) (- (car (vector-ref pole tmp)) 1)))
|
|
|
|
;;
|
|
;; determine target X position, based on destination pole, and fly ring
|
|
;; over to new pole
|
|
;;
|
|
(set! toX (- (cdr (vector-ref pole to))
|
|
(/ (cadr (vector-ref ring n)) 2)))
|
|
|
|
(do ()
|
|
((>= x0 toX))
|
|
(set! inc (if (> (- toX x0) accel) accel (- toX x0)))
|
|
(set! x0 (+ x0 inc))
|
|
(set! x1 (+ x1 inc))
|
|
(hanoi-canvas 'coords r x0 y0 x1 y1)
|
|
(update))
|
|
|
|
(do ()
|
|
((<= x0 toX))
|
|
(set! inc (if (> (- x0 toX) accel) accel (- x0 toX)))
|
|
(set! x0 (- x0 inc))
|
|
(set! x1 (- x1 inc))
|
|
(hanoi-canvas 'coords r x0 y0 x1 y1)
|
|
(update))
|
|
|
|
;;
|
|
;; determine target Y position, based on ;; rings on destination pole.
|
|
;;
|
|
(set! toY (- base (* (car (vector-ref pole to)) ring-spacing)))
|
|
|
|
;;
|
|
;; float ring down
|
|
;;
|
|
(do ()
|
|
((>= y0 toY))
|
|
(set! inc (if (> (- toY y0) accel) accel (- toY y0)))
|
|
(set! y0 (+ y0 inc))
|
|
(set! y1 (+ y1 inc))
|
|
(hanoi-canvas 'coords r x0 y0 x1 y1)
|
|
(update))
|
|
|
|
;;
|
|
;; increase destination pole usage
|
|
;;
|
|
(set-car! (vector-ref pole to) (+ (car (vector-ref pole to)) 1))
|
|
(set-car! (vector-ref ring n) to)))
|
|
|
|
|
|
(SetupHanoi)
|