stk/Demos/hanoi.stk

#!/bin/sh
:;exec /usr/local/bin/stk -f "$0" "$@"
;;;;
;;;; Hanoi - Towers of Hanoi diversion
;;;;
;;;; Copyright <20> 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)