(module color-test mzscheme
(require "../reduction-semantics.ss"
"../gui.ss"
"../subst.ss"
(lib "mred.ss" "mred")
(lib "class.ss"))
(reduction-steps-cutoff 1)
(define reductions
(reduction-relation
(language)
(--> (number_1 word)
(,(+ (term number_1) 1) word)
inc)))
(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 (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)
reductions
(list '(1 word))
pred)
)