#lang scheme/base

(require (prefix-in log: (planet synx/log:1))
         scheme/gui/base
         scheme/class)

(define places 
  '((0 0) 
    (0 1) (0 2) (0 3) 

    (1 2)     
   
    (0 4) (0 5) (0 6) (0 7) 
    (1 6) 
    
    (0 8) (0 9) (0 10) (0 11)
    (1 10)
       
    (0 12) (0 13) (0 14) (0 15)     
    (1 14)
    
    (2 8) 
    
    (0 16) (0 17) (0 18) (0 19) 
    (1 18) 

    (0 20) (0 21) (0 22) (0 23) 
    (1 22)
    
    (0 24) (0 25) (0 26) (0 27) 
    (1 26)
    
    (0 28) (0 29) (0 30) (0 31) 
    (1 30)
        
    (2 24)
 
    (0 32) (0 33) (0 34)))

(define final-places
  '((1 32)
    (2 30)
    (3 22)))

(define lines
  (make-immutable-hash
  '(((1 2) (0 0) (0 1) (0 2) (0 3))
    ((1 6) (0 4) (0 5) (0 6) (0 7))
    ((1 10) (0 8) (0 9) (0 10) (0 11))
    ((1 14) (0 12) (0 13) (0 14) (0 15))
    ((2 8) (1 2) (1 6) (1 10) (1 14))
    
    ((1 18) (0 16) (0 17) (0 18) (0 19))
    ((1 22) (0 20) (0 21) (0 22) (0 23))
    ((1 26) (0 24) (0 25) (0 26) (0 27))
    ((1 30) (0 28) (0 29) (0 30) (0 31))
    ((2 24) (1 18) (1 22) (1 26) (1 30))
    
    ((1 32) (0 32) (0 33) (0 34))
    ((2 30) (1 32))
    ((3 22) (2 8) (2 24) (2 30)))))

(define parents
  (foldl
   (λ (pair result)
     (let ((parent (car pair))
           (children (cdr pair)))
       (append 
        (map (λ (child) (cons child parent)) children)
        result)))
   null
   (hash-map lines cons)))

(define displayed-places null)
(define finished-places null)

(define dot-size 10)
(define x-gutter 2)
(define y-gutter 20)

(define (x-pt x)
  (+ 10 (* x (+ dot-size x-gutter))))

(define (y-pt y)
  (+ 10 (* 10 (expt 2 (+ y 1)))))

(define unfinished (send the-color-database find-color "Green"))
(define finished (send the-color-database find-color "Red"))

(define (draw-places canvas dc)
  (for-each
   (λ (place)
     (let ((lines (hash-ref lines place (λ () #f))))
       (when lines
         (let ((y (+ (/ dot-size 2) (y-pt (car place))))
               (x (+ (/ dot-size 2) (x-pt (cadr place)))))
           (for ((end lines))
             (when (member end displayed-places)
               (let ((y1 (+ (/ dot-size 2) (y-pt (car end))))
                     (x1 (+ (/ dot-size 2) (x-pt (cadr end)))))
                 (send dc draw-line x y x1 y1))))))))
    displayed-places)
  (for-each
   (λ (place)
     (let ((y (y-pt (car place)))
           (x (x-pt (cadr place))))
       (send dc set-brush (if (member place finished-places) finished unfinished) 'opaque)
       (send dc draw-ellipse x y dot-size dot-size)))
   displayed-places))

(define (add-place! canvas status place)
  (set! displayed-places (cons place displayed-places))
  (let ((children (hash-ref lines place (λ () #f))))
    (when children
      (set! finished-places (append children finished-places))))
  (send canvas refresh)
  (send status set-label (apply format "place ~a,~a" place))
  (sleep (/ 1 2)))

(define (load-pieces canvas status)
  (thread
   (λ ()
     (for-each
      (λ (place)
        (add-place! canvas status place))
      places)
     (send status set-label "And so on...")
     (sleep 1)
     (send status set-label "Finally, we complete the tree for any pieces left over.")
     (sleep 1)
     (for-each
      (λ (place)
        (add-place! canvas status place))
      final-places))))

(define (main)
  (define frame (new frame% (width 500) (height 500) (label "Display")))
  (define status (new message% (stretchable-width #t) (parent frame) (label "status")))
  (define canvas (new canvas% (parent frame)
                      (paint-callback draw-places)))
  (send frame show #t)
  (load-pieces canvas status))
(provide main)