(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)))