107 lines
2.9 KiB
Racket
107 lines
2.9 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2016-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(require "../../dataflow.rkt")
|
|
|
|
(module+ test
|
|
(require rackunit)
|
|
|
|
(struct cell (value) #:mutable
|
|
#:methods gen:custom-write
|
|
[(define (write-proc c port mode)
|
|
(fprintf port "#<cell:~v>" (cell-value c)))])
|
|
|
|
(define g #f)
|
|
|
|
(define (R b)
|
|
(dataflow-record-observation! g b)
|
|
(cell-value b))
|
|
|
|
(define (W b v)
|
|
(when (not (equal? (cell-value b) v))
|
|
(dataflow-record-damage! g b)
|
|
(set-cell-value! b v)))
|
|
|
|
(define (repair! b)
|
|
(b))
|
|
|
|
(define-syntax-rule (V expr)
|
|
(letrec ((node (cell #f))
|
|
(handler (lambda ()
|
|
;; (printf "Evaluating ~a\n" 'expr)
|
|
(W node expr))))
|
|
(parameterize ((current-dataflow-subject-id handler))
|
|
(handler)
|
|
node)))
|
|
|
|
(set! g (make-dataflow-graph))
|
|
(let* ((c (V 123))
|
|
(d (V (* (R c) 2))))
|
|
(check-equal? (list (R c) (R d)) (list 123 246))
|
|
(dataflow-repair-damage! g repair!)
|
|
(check-equal? (list (R c) (R d)) (list 123 246))
|
|
(dataflow-repair-damage! g repair!)
|
|
(check-equal? (list (R c) (R d)) (list 123 246))
|
|
(W c 124)
|
|
(check-equal? (list (R c) (R d)) (list 124 246))
|
|
(dataflow-repair-damage! g repair!)
|
|
(check-equal? (list (R c) (R d)) (list 124 248)))
|
|
;; (newline)
|
|
|
|
(set! g (make-dataflow-graph))
|
|
|
|
(define xs (V (list 1 2 3 4)))
|
|
(define sum (V (foldr + 0 (R xs))))
|
|
(define len (V (length (R xs))))
|
|
(define avg (V (if (zero? (R len))
|
|
(void)
|
|
(/ (R sum) (R len)))))
|
|
(define scale (V 1))
|
|
(define ans (V (if (zero? (R scale))
|
|
(void)
|
|
(and (number? (R avg))
|
|
(/ (R avg) (R scale))))))
|
|
|
|
(define (fix! stage)
|
|
;; (printf "\n----- Stage: ~a\n" stage)
|
|
(dataflow-repair-damage! g repair!)
|
|
;; (write `((xs ,(R xs))
|
|
;; (sum ,(R sum))
|
|
;; (len ,(R len))
|
|
;; (avg ,(R avg))
|
|
;; (scale ,(R scale))
|
|
;; (ans ,(R ans))))
|
|
;; (newline)
|
|
)
|
|
|
|
(define-syntax-rule (check-results vs ...)
|
|
(check-equal? (map R (list xs sum len avg scale ans)) (list vs ...)))
|
|
|
|
(fix! 'initial)
|
|
(check-results '(1 2 3 4) 10 4 10/4 1 10/4)
|
|
|
|
(W scale 0)
|
|
(fix! 'scale-zero)
|
|
(check-results '(1 2 3 4) 10 4 10/4 0 (void))
|
|
|
|
(W xs (list* 9 0 (R xs)))
|
|
(fix! 'with-nine-and-zero)
|
|
(check-results '(9 0 1 2 3 4) 19 6 19/6 0 (void))
|
|
|
|
(W xs (list* 5 4 (cddr (R xs))))
|
|
(fix! 'with-five-and-four)
|
|
(check-results '(5 4 1 2 3 4) 19 6 19/6 0 (void))
|
|
|
|
(W scale 1)
|
|
(fix! 'scale-one)
|
|
(check-results '(5 4 1 2 3 4) 19 6 19/6 1 19/6)
|
|
|
|
(W xs '())
|
|
(fix! 'empty)
|
|
(check-results '() 0 0 (void) 1 #f)
|
|
|
|
(W xs (list 4 5 6))
|
|
(fix! 'four-five-six)
|
|
(check-results '(4 5 6) 15 3 15/3 1 15/3))
|