#|

tests the color setting ability during a reduction sequence.

In one window, you expect to see a red and a blue snip. as you reduce you expect to see a spectrum from blue to red

In the other window, you expect to see the currently unreducted terms in green and all others white.

|#

(module color-test mzscheme
  (require "../reduction-semantics.ss"
           "../gui.ss"
           (lib "mred.ss" "mred")
           (lib "class.ss"))
  
  (reduction-steps-cutoff 1)
  
  (let ()
    
    (define (get-range term-node)
      (let loop ([node term-node])
        (let ([parents (term-node-parents node)])
          (cond
            [(null? parents) (list node)]
            [else (cons node (loop (car parents)))]))))
    
    (define (color-range-pred sexp term-node) 
      (let* ([parents (get-range term-node)]
             [max-val (car (term-node-expr (car parents)))])
        (for-each
         (λ (node)
           (let ([val (car (term-node-expr node))])
             (term-node-set-color! node
                                   (make-object color% 
                                     (floor (- 255 (* val (/ 255 max-val))))
                                     0
                                     (floor (* val (/ 255 max-val)))))))
         parents)))
    
    (traces/pred (language)
                 (reduction-relation
                  (language)
                  (--> (number_1 word)
                       (,(+ (term number_1) 1) word)
                       inc))
                 (list '(1 word))
                 color-range-pred))
  
  (let ()
    (define (last-color-pred sexp term-node)
      (term-node-set-color! term-node 
                            (if (null? (term-node-children term-node))
                                "green"
                                "white")))
    
    (traces/pred (language)
                 (reduction-relation
                  (language)
                  (--> (number_1 word)
                       (,(+ (term number_1) 1) word)
                       inc)
                  (--> (number_1 word)
                       (,(* (term number_1) 2) word)
                       dup))
                 (list '(1 word))
                 last-color-pred)))