(define std-box '(40 10 240 410))

(define (funstuff n box)
  (set! win-top (car box))
  (set! win-left (cadr box))
  (set! win-bot (caddr box))
  (set! win-right (cadddr box))
  
  (let ((win (mac#newcwindow 
               (mac#rect win-top win-left win-bot win-right)
               "Tower of Hanoi"
               #t 0 -1 #f)))
    (display win)
    (newline)
    
    (setup win)

    (set-height 1 0)
    (set-height 2 0)
    (set-height 3 0)
    
    (start-disk win 1 n)
    
    (mac#delay 120)

    (hanoi win n 1 3 2)
    
    (mac#delay 120)
    (mac#disposewindow win)))


(define (tom-line win pt1 pt2)
  (mac#moveto win (car pt1) (cadr pt1))
  (mac#lineto win (car pt2) (cadr pt2)))

(define (string-at win str pt)
  (mac#moveto win (car pt) (cadr pt))
  (mac#drawstring win str))


(define (setup win)
  (let* ((ht (- win-bot win-top))
         (wd (- win-right win-left)))
  
  (set! width-a (truncate (* 0.25 wd)))
  (set! width-b (truncate (* 0.50 wd)))
  (set! width-c (truncate (* 0.75 wd)))
  
    (make-tower win 1)
    (make-tower win 2)
    (make-tower win 3)
    
    (mac#pensize win 1 5)
    (tom-line win (list 0 (- ht 40))
                  (list wd (- ht 40)))
    (mac#pennormal win)
    
    (string-at win "A" (list (- width-a 5) (- ht 20)))
    (string-at win "B" (list (- width-b 5) (- ht 20)))
    (string-at win "C" (list (- width-c 5) (- ht 20)))
    
    ))

(define (make-tower win tower)
  (tom-line win (list (get-width tower) 40)
                (list (get-width tower) (- win-bot win-top 40))))

(define (set-height tower ht)
  (cond
    ((= tower 1)
     (set! height-a ht))
    ((= tower 2)
     (set! height-b ht))
    (else
     (set! height-c ht))))

(define (get-height tower)
  (cond
    ((= tower 1)
     height-a)
    ((= tower 2)
     height-b)
    (else
     height-c)))


(define (get-width tower)
  (cond
    ((= tower 1)
     width-a)
    ((= tower 2)
     width-b)
    (else
     width-c)))

(define (adj-height tower dh)
  (cond
    ((= tower 1)
     (set! height-a (+ height-a dh)))
    ((= tower 2)
     (set! height-b (+ height-b dh)))
    (else
     (set! height-c (+ height-c dh)))))


(define (start-disk win tower num)
  (let ((h2 (- win-bot win-top 50 (* 10 (get-height tower)))))
  (cond
    ((= num 1)
     (levitate win num tower 20 h2 1)
     (adj-height tower 1)
     (mac#delay 240))
    (else
     (levitate win num tower 20 h2 1)
     (adj-height tower 1)
     (start-disk win tower (- num 1))))))


(define (put-disk win tower disk)
  (let*
    ((top (- win-bot win-top 50 (* 10 (get-height tower))))
     (left (- (get-width tower) (* disk 10)))
     (bottom (+ top 10))
     (right (+ left (* disk 20))))
    (mac#framerect win (mac#rect top left bottom right))
    (adj-height tower 1)))


    
(define (hanoi win ht start end xtra)
  (mac#delay 10)
  (cond 
    ((= ht 1)
      (move-anim win 1 start end))
    (else
     (hanoi win (- ht 1) start xtra end)
     (move-anim win ht start end)
     (hanoi win (- ht 1) xtra end start))))

(define (move-anim win disk t1 t2)
  (let ((top1 (- win-bot win-top 50 (* 10 (- (get-height t1) 1))))
        (top2 (- win-bot win-top 50 (* 10 (get-height t2)))))
    (levitate win disk t1 top1 20 -1)
    (if (< t1 t2)
        (float win disk (get-width t1) (get-width t2) 1)
        (float win disk (get-width t1) (get-width t2) -1))
    (levitate win disk t2 20 top2 1)
    (adj-height t1 -1)
    (adj-height t2 1)))


(define (float win disk w1 w2 dw)
  (let*
    ((left (- w1 (* disk 10)))
     (right (+ left (* disk 20)))
     (pos1 (mac#rect 20 left 30 right))
     (pos2 (mac#rect 20 (+ left dw) 30 (+ right dw))))
    (cond
      ((<= (* dw (- w2 w1)) 0) 0)
      (else
       (mac#eraserect win pos1)
       (mac#framerect win pos2)
       (float win disk (+ w1 dw) w2 dw)))))

(define (levitate win disk tower h1 h2 dh)
  (let*
    ((left (- (get-width tower) (* disk 10)))
     (right (+ left (* disk 20)))
     (pos1 (mac#rect h1 left (+ h1 10) right))
     (pos2 (mac#rect (+ h1 dh) left (+ h1 dh 10) right)))
    (cond
      ((<= (* dh (- h2 h1)) 0)
           0)
      (else
       (mac#eraserect win pos1)
       (mac#framerect win pos2)
       (make-tower win tower)
       (levitate win disk tower (+ h1 dh) h2 dh)))))


(funstuff 5 std-box)