propagator/ 0000775 0012467 0012467 00000000000 12106245156 011406 5 ustar gjs gjs propagator/extensions/ 0000775 0012467 0012467 00000000000 12111231502 013567 5 ustar gjs gjs propagator/extensions/test/ 0000775 0012467 0012467 00000000000 11556117076 014573 5 ustar gjs gjs propagator/extensions/test/load.scm 0000664 0012467 0012467 00000002432 11436622524 016213 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(for-each load-relative
`("inequality-test"
"symbolics-test"
"symbolics-ineq-test"
"functional-reactive-test"
,@(maybe "virtual-environments-test" *virtual-copies*)
,@(maybe "virtual-closures-test" *virtual-copies*)
"graph-drawing-test"))
propagator/extensions/test/functional-reactive-test.scm 0000664 0012467 0012467 00000004414 11423656174 022221 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
functional-reactive
(define-each-check
(generic-match #(frp seconds 0) (make-frpremise 'seconds 0)))
(define-test (glitch)
(interaction
(initialize-scheduler)
(define-cell one)
(define-cell seconds)
(define-cell seconds+one)
(p:+ one seconds seconds+one)
(add-content one 1)
(add-content seconds (make-frs 0 (make-frpremise 'seconds 0)))
(run)
(content seconds+one)
(produces #(frs 1 (#(frp seconds 0))))
(define-cell seconds+one-again)
(define-cell glitchable)
(p:< seconds seconds+one-again glitchable)
(add-content seconds+one-again (content seconds+one))
(run)
(content glitchable)
(produces #(frs #t (#(frp seconds 0))))
(add-content seconds (make-frs 1 (make-frpremise 'seconds 1)))
(content seconds)
(produces #(frs 1 (#(frp seconds 1))))
(run)
(content seconds+one)
(produces #(frs 2 (#(frp seconds 1))))
;; Rather than glitching, it should notice that its input is out of
;; date
(content glitchable)
(produces #(frs #t (#(frp seconds 0))))
;; But when updated, it should propagate
(add-content seconds+one-again (content seconds+one))
(run)
(content glitchable)
(produces #(frs #t (#(frp seconds 1))))))
)
propagator/extensions/test/inequality-test.scm 0000664 0012467 0012467 00000011046 11503765530 020436 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
inequalities
(define (test-try-ineq ineq)
(try-inequality ineq (lambda (x) x) (lambda () 'failed)))
(define-each-check
(tautological-ineq? (make-tautological-ineq))
(contradictory-ineq? (make-contradictory-ineq))
(tautological-ineq?
(test-try-ineq (make-inequality '> '(expt x 2))))
(contradictory-ineq?
(test-try-ineq (make-inequality '< '(expt x 2))))
(generic-match
(make-solved-inequality '< 'y -3)
(test-try-ineq (make-inequality '< '(+ y 3))))
(generic-match
(make-solved-inequality '< 'y -3/2)
(test-try-ineq (make-inequality '< '(+ (* 2 y) 3))))
(generic-match
(make-solved-inequality '<= 'x 0)
(test-try-ineq (make-inequality '<= '(* 23 x))))
(generic-match
(make-solved-inequality '>= 'x 0)
(test-try-ineq (make-inequality '<= '(* -23 x))))
(generic-match
(make-solved-inequality '< 'x 4/23)
(test-try-ineq (make-inequality '> '(+ 4 (* -23 x)))))
(generic-match
'failed
(test-try-ineq (make-inequality '> '(+ x y))))
(generic-match
'failed
(test-try-ineq (make-inequality '> '(+ 5 (exp y) 8))))
(generic-match
'failed
(test-try-ineq (make-inequality '> '(+ (expt z 2) z 3))))
(generic-match '() (simplify-inequalities '()))
(generic-match
(list (make-inequality '> 'x))
(simplify-inequalities
(list (make-inequality '> 'x))))
(generic-match
(list (make-solved-inequality '< 'x 5/2))
(simplify-inequalities
(list (make-inequality '< '(- x 4))
(make-inequality '< '(- (* 2 x) 5)))))
(generic-match
(list (make-solved-inequality '< 'y 4)
(make-solved-inequality '< 'x 5/2))
(simplify-inequalities
(list (make-inequality '< '(- y 4))
(make-inequality '< '(- (* 2 x) 5)))))
(generic-match
(list (make-solved-inequality '< 'x 4))
(simplify-inequalities
(list (make-inequality '< '(- x 4))
(make-inequality '<= '(- (* 2 x) 8)))))
(generic-match
(list (make-solved-inequality '< 'x 4)
(%make-inequality '>= '(+ (expt z 2) z) -2))
(simplify-inequalities
(list (make-inequality '< '(- x 4))
(make-inequality '>= '(+ z 2 (* z z)))
(make-inequality '<= '(- (* 2 x) 8)))))
(generic-match
(list (make-solved-inequality '>= 'y 4)
(make-solved-inequality '< 'x 5/2))
(simplify-inequalities
(list (make-inequality '>= '(- y 4))
(make-inequality '< '(- (* 2 x) 5)))))
(generic-match
#f
(simplify-inequalities
(list (make-inequality '>= '(- x 4))
(make-inequality '< '(- (* 2 x) 5)))))
(generic-match
#f
(simplify-inequalities
(list (make-inequality '>= '(- x 4))
(make-inequality '>= '(+ z 2 (* z z)))
(make-inequality '< '(- (* 2 x) 5)))))
(generic-match
'()
(simplify-inequalities
(list (make-inequality '>= '(+ (* 3 x) (* -2 x) (* -1 x) 4)))))
(generic-match
#f
(simplify-inequalities
(list (make-inequality '>= '(+ (* 3 x) (* -2 x) (* -1 x) 4))
(make-inequality '>= '(+ (* 3 y) (* -2 y) (* -1 y) -4)))))
(generic-match
(make-inequality '< -1)
(transitive-ineq (make-solved-inequality '> 'x 4)
(make-solved-inequality '< 'x 5)))
(equal?
'()
(solve-inequalities '((<= (* x y) (* x y)))))
(equal?
'((>= x -2))
(solve-inequalities '((<= (+ (* 2 x) 1) (+ (* 5 x) 7)))))
(equal?
'((>= (* x y) -2))
(solve-inequalities '((<= (+ (* 2 (* x y)) 1) (+ (* 5 (* x y)) 7)))))
(equal?
'((>= (* x y) -2))
(solve-inequalities '((<= (+ (* 2 (* x y)) 1) (+ (* 5 (* x y)) 7))
(>= (* x y) -3))))
))
propagator/extensions/test/symbolics-test.scm 0000664 0012467 0012467 00000003704 11421421706 020251 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
symbolics
(define-each-check
(generic-match
#(symbolic x #(metadata (x) () ()))
(variable->symbolic 'x))
(generic-match
#(symbolic -1 #(metadata (x) (((= x -1) ())) ()))
(merge (make-symbolic 'x (make-symbolic-metadata '(x) '() '()))
(make-symbolic '(+ (* 2 x) 1) (make-symbolic-metadata '(x) '() '()))))
(generic-match
#(symbolic -11
#(metadata (x z y) (((= z -12) ()) ((= x -1) ()) ((= y -4) ())) ()))
(merge (make-symbolic '(+ (* 2 x) 3 z)
(make-symbolic-metadata '(x z) '(((= y (* 4 x)) ())) '()))
(make-symbolic '(- y 7)
(make-symbolic-metadata '(y) '(((= x (+ 3 y)) ())) '()))))
(generic-match
#(symbolic x #(metadata (x) () ()))
(merge (make-symbolic 'x (make-symbolic-metadata '(x) '() '()))
(make-symbolic 'x (make-symbolic-metadata '(x) '() '()))))
(equal?
nothing
((nary-unpacking +) (make-symbolic 'x (empty-metadata)) nothing))))
propagator/extensions/test/graph-drawing-test.scm 0000664 0012467 0012467 00000014423 11556117076 021012 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
graph-drawing
(define-each-check
(equal? '+ (name generic-+)))
(define-test (drawing-smoke)
(interaction
(force-hash-number 200)
(initialize-scheduler)
(define-cell foo)
(define-cell bar)
(p:id foo bar)
(draw:write-graph-to-string *toplevel-diagram*)
(check (equal?
"digraph G {
ratio=fill;
subgraph cluster_201 { label=\"toplevel\";
\"cell-202\" [label=\"bar\", shape=\"ellipse\" ];
\"cell-203\" [label=\"foo\", shape=\"ellipse\" ];
\"prop-204\" [label=\"identity:p\", shape=\"box\" ];
}
\"cell-203\" -> \"prop-204\" [label=\"\" ];
\"prop-204\" -> \"cell-202\" [label=\"\" ];
}
" (out)))))
#|
;;; These tests are slow (because they ask for lots of GC) but they
;;; don't test much when things are working, because the following
;;; test summarizes them.
(define-each-check
(< (memory-loss-from (repeated 100 make-eq-hash-table)) 2)
(< (memory-loss-from (repeated 100 make-strong-eq-hash-table)) 2)
(< (memory-loss-from (repeated 100 reset-premise-info!)) 2)
(< (memory-loss-from (repeated 500 reset-network-groups!)) 10)
(< (memory-loss-from (repeated 100 initialize-scheduler)) 2))
(define-test (groups-do-not-leak)
(initialize-scheduler)
(define (one-small-network)
(define-cell foo)
(define-cell bar)
(initialize-scheduler))
(check (< (memory-loss-from (repeated 100 one-small-network)) 2)))
|#
(define-test (groups-do-not-leak-2)
(initialize-scheduler)
(define (one-small-network)
(define-cell foo)
(define-cell bar)
(p:id foo bar)
(initialize-scheduler))
(check (< (memory-loss-from (repeated 100 one-small-network)) 2)))
(define-test (grouped-drawing)
(interaction
(force-hash-number 214)
(initialize-scheduler)
(define-cell foo)
(diagram-style-with-diagram (empty-diagram 'subgroup)
(lambda ()
(define-cell bar)
(p:id foo bar)))
(draw:write-graph-to-string *toplevel-diagram*)
(check (equal?
"digraph G {
ratio=fill;
subgraph cluster_215 { label=\"toplevel\";
\"cell-216\" [label=\"foo\", shape=\"ellipse\" ];
subgraph cluster_217 { label=\"subgroup\";
\"cell-218\" [label=\"bar\", shape=\"ellipse\" ];
\"prop-219\" [label=\"identity:p\", shape=\"box\" ];
}
}
\"cell-216\" -> \"prop-219\" [label=\"\" ];
\"prop-219\" -> \"cell-218\" [label=\"\" ];
}
" (out)))))
(define-test (grouped-drawing-2)
(interaction
(force-hash-number 239)
(initialize-scheduler)
(define-cell foo)
(define-cell bar)
(c:id foo bar)
(draw:write-graph-to-string)
(check (equal?
"digraph G {
ratio=fill;
subgraph cluster_240 { label=\"toplevel\";
\"cell-241\" [label=\"bar\", shape=\"ellipse\" ];
\"cell-242\" [label=\"foo\", shape=\"ellipse\" ];
subgraph cluster_243 { label=\"c:id\";
\"prop-244\" [label=\"identity:p\", shape=\"box\" ];
\"prop-245\" [label=\"identity:p\", shape=\"box\" ];
}
}
\"cell-241\" -> \"prop-244\" [label=\"\" ];
\"prop-244\" -> \"cell-242\" [label=\"\" ];
\"cell-242\" -> \"prop-245\" [label=\"\" ];
\"prop-245\" -> \"cell-241\" [label=\"\" ];
}
" (out)))))
;;; TODO expression-substructure-test fails to syntax in at least some
;;; versions of mechanics because of a macro-expander bug. It is also
;;; outdated, in that it relies on old network-group technology rather
;;; than the new diagram technology.
#;
(define-test (expression-substructure-test)
(initialize-scheduler)
(define-propagator (frobnicate frob)
(let* ((first-internal (e:+ frob frob))
(second-internal (e:+ frob first-internal)))
(let-cells ((sum (e:+ frob second-internal)))
(let ((the-expression-substructure
(network-group-expression-substructure *current-network-group*)))
;; sum is shown because it has a name
(check (memq sum the-expression-substructure))
;; frob is not shown because it's not part of the group at all
(check (not (memq frob the-expression-substructure)))
;; first-internal is hidden becuase it's internal to an expression
(check (not (memq first-internal the-expression-substructure)))
;; ditto second-internal
(check (not (memq second-internal the-expression-substructure)))
(check (= 1 (length (filter cell? the-expression-substructure))))
;; all the propagators are hidden because they abut on expressions
(check (= 0 (length (filter propagator? the-expression-substructure))))
;; TODO get the names right
#;
(check
(equal? '(+ frob (+ frob (+ frob frob)))
(name (car (filter network-group?
the-expression-substructure)))))
(let ((the-subgroup-structure
(network-group-expression-substructure
(car (filter network-group? the-expression-substructure)))))
;; But inside the generated subgroup, the internal cell
;; and the propagators it connects are explicit.
(check (memq first-internal the-subgroup-structure))
(check (memq second-internal the-subgroup-structure))
(check (= 3 (length (filter propagator? the-subgroup-structure))))
(check (= 2 (length (filter cell? the-subgroup-structure))))
(check (= 0 (length (filter network-group? the-subgroup-structure))))
)))))
(p:frobnicate (e:constant 2))
)
;; TODO Add a test of drawing networks with expanded and unexpanded
;; compound propagators.
)
propagator/extensions/test/symbolics-ineq-test.scm 0000664 0012467 0012467 00000022223 11423656174 021213 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
symbolics-ineq
(define-each-check
(generic-match
(vector 'symb-ineq nothing '((< me 5 (me)) (> me 4 (me))) '())
(symb-ineq-merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 5))
'())
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 4))
'())
))
(generic-match
(vector 'symb-ineq nothing '((< me 5 (me)) (> me 4 (me))) '())
(merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 5))
'())
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 4))
'())
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 5))
'())
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 6))
'())
))
(generic-match
#(symb-ineq #(symbolic 4 #(metadata () () ())) () ())
(merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 5))
'())
(make-symb-ineq
(make-symbolic 4 (empty-metadata))
'()
'())
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
nothing
'()
(list (%make-inequality '< 'x 5)))
(make-symb-ineq
nothing
'()
(list (%make-inequality '> 'x 6)))
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
(make-symbolic 4 (empty-metadata))
'()
(list (%make-inequality '< 'x 5)))
(make-symb-ineq
(make-symbolic 4 (empty-metadata))
'()
(list (%make-inequality '> 'x 6)))
))
(generic-match
#(symb-ineq #(symbolic 4 #(metadata () () ()))
()
((< x 5 (x))))
(merge
(make-symb-ineq
(make-symbolic 4 (empty-metadata))
'()
(list (%make-inequality '< 'x 5)))
(make-symb-ineq
(make-symbolic 4 (empty-metadata))
'()
'())
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
(make-symbolic 4 (empty-metadata)) '() '())
(make-symb-ineq
(make-symbolic 5 (empty-metadata)) '() '())
))
(generic-match
#(symb-ineq #(symbolic v #(metadata (v) () ()))
()
((< v 5 (v))))
(merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 5))
'())
(make-symb-ineq
(variable->symbolic 'v)
'()
'())
))
(generic-match
#(symb-ineq #(symbolic v #(metadata (v) () ()))
()
((> v 0 (v))))
(merge
(make-symb-ineq
nothing
(list (%make-inequality '< 'me '(* 2 v)))
'())
(make-symb-ineq
(variable->symbolic 'v)
'()
'())
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
(variable->symbolic 'v)
'()
(list (%make-inequality '> 'v 6)))
(make-symb-ineq
nothing
(list (%make-inequality '< 'me '2))
'())
))
(generic-match
#(symb-ineq #(*the-nothing*)
((> me v (me v))
(< me 2 (me)))
((< v 2 (v))))
(merge
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 'v))
'())
(make-symb-ineq
nothing
(list (%make-inequality '< 'me '2))
'())
))
(generic-match
#(symb-ineq #(symbolic w #(metadata (v w) (((= v (* 4 w)) ())) ()))
()
((> w 0 (w))
(< w 1/2 (w))))
(merge
(make-symb-ineq
(make-symbolic
'w
(make-symbolic-metadata
'(v w)
'(((= v (* 4 w)) ()))
'()))
'()
(list (%make-inequality '> 'w 0)))
(make-symb-ineq
nothing
'()
(list (%make-inequality '< 'v '2)))
))
(generic-match
#(symb-ineq #(symbolic w #(metadata (v w) (((= v (* 4 w)) ())) ()))
()
((> w 0 (w))))
(merge
(make-symb-ineq
(make-symbolic
'w
(make-symbolic-metadata
'(v w)
'(((= v (* 4 w)) ()))
'()))
'()
(list (%make-inequality '> 'w 0)))
(make-symb-ineq
nothing
(list (%make-inequality '< 'me 'v))
'())
))
(generic-match
the-contradiction
(merge
(make-symb-ineq
(make-symbolic
'w
(make-symbolic-metadata
'(v w)
'(((= v (* 4 w)) ()))
'()))
'()
(list (%make-inequality '> 'w 0)))
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 'v))
'())
))
(generic-match
#(symb-ineq #(symbolic w #(metadata (v w) (((= v (* 4 w)) ())) ()))
()
((< w 0 (w))))
(merge
(make-symb-ineq
(make-symbolic
'w
(make-symbolic-metadata
'(v w)
'(((= v (* 4 w)) ()))
'()))
'()
'())
(make-symb-ineq
nothing
(list (%make-inequality '> 'me 'v))
'())
))
(generic-match #t ;; TODO Should this forward the metadata?
((binary-mapping generic-<=)
(make-symbolic
-6
(make-symbolic-metadata '(x) '(((= x 0) ())) '()))
(make-symbolic
0
(make-symbolic-metadata '(x) '(((= x 0) ())) '()))))
(generic-match #t ;; TODO Should this detect the inconsistency?
((binary-mapping generic-<=)
(make-symbolic
-6
(make-symbolic-metadata '(x) '(((= x 6) ())) '()))
(make-symbolic
0
(make-symbolic-metadata '(x) '(((= x 0) ())) '()))))
(generic-match #t ;; TODO Should this forward the metadata?
((binary-mapping generic-<=)
(make-symb-ineq
(make-symbolic
-6
(make-symbolic-metadata '(x) '(((= x 0) ())) '()))
'()
'())
(make-symb-ineq
(make-symbolic
0
(make-symbolic-metadata '(x) '(((= x 0) ())) '()))
'()
'())))
)
(define-test (ineq-enforcer-smoke)
(interaction
(initialize-scheduler)
(define-cell five)
((constant (make-tms (supported 5 '(joe)))) five)
(define-cell victim)
((ineq-enforcer '<) five victim)
((ineq-enforcer '<) victim five)
;; Doesn't detect the contradiction without a plunk
(run)
(produces 'done)
(plunker victim)
(run)
(produces '(contradiction (joe)))))
(define-test (ineq-constraint-smoke)
(interaction
(initialize-scheduler)
(define-cell four)
((constant 4) four)
(define-cell ctl)
(define-cell victim)
(c:> ctl four victim)
((constant #t) ctl)
(run)
(content victim)
(produces (vector 'symb-ineq nothing '((< me 4 (me))) '()))))
(define-test (more-ineq-constraint-smoke)
(interaction
(initialize-scheduler)
(define-cell three)
((constant (make-tms (supported 3 '(joe)))) three)
(define-cell victim)
(define-cell ctl)
(c:< ctl three victim)
(c:>= ctl three victim)
;; Doesn't detect the contradiction without a boolean plunk on the
;; control
(run)
(produces 'done)
(binary-amb ctl)
(run)
(produces '(contradiction (joe)))))
(define-test (even-more-ineq-constraint-smoke)
(interaction
(initialize-scheduler)
(define-cell three)
((constant (make-tms (supported 3 '(joe)))) three)
(define-cell victim1)
(define-cell victim2)
(define-cell ctl)
(c:< ctl three victim1)
(c:>= ctl three victim2)
(define-cell zero)
((constant 0) zero)
(c:+ zero victim1 victim2)
;; Doesn't detect the contradiction without a boolean plunk on the
;; control
(run)
(produces 'done)
(binary-amb ctl)
;; Doesn't detect the contradiction without a variable plunk, either
(run)
(produces 'done)
(plunker victim1)
(run)
(produces '(contradiction (joe)))))
(define-test (even-more-more-ineq-constraint-smoke)
(interaction
(initialize-scheduler)
(define-cell three)
((constant (make-tms (supported 3 '(joe)))) three)
(define-cell victim1)
(define-cell victim2)
(define-cell ctl)
(c:< ctl three victim1)
(c:>= ctl three victim2)
(define-cell zero)
((constant 0) zero)
(c:+ zero victim1 victim2)
;; Doesn't detect the contradiction without a boolean plunk on the
;; control.
(run)
(produces 'done)
(binary-amb ctl)
;; Doesn't detect the contradiction without a variable plunk, either
(run)
(produces 'done)
(define-cell four)
((constant 4) four)
(define-cell x)
(plunker x)
(p:* four x victim1)
(run)
(produces '(contradiction (joe)))))
)
propagator/extensions/test/virtual-closures-test.scm 0000664 0012467 0012467 00000016234 11421421706 021572 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
virtual-closures
(define-test (smoke)
(interaction
(initialize-scheduler)
(define repl-frame (make-frame '()))
(define-cell a)
(define-cell b)
(define-cell gcd-a-b)
(define-cell euclid)
(dynamic-call-site euclid (list a b gcd-a-b))
(add-content a (alist->virtual-copies `((,repl-frame . ,(* 17 3)))))
(add-content b (alist->virtual-copies `((,repl-frame . ,(* 17 5)))))
(add-content euclid (alist->virtual-copies `((,repl-frame . ,euclid-cl))))
(add-content gcd-a-b (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content gcd-a-b)
(produces `((,repl-frame . 17)))))
(define-test (closure-switching)
(interaction
(initialize-scheduler)
(define repl-frame-a (make-frame '()))
(define repl-frame-b (make-frame '()))
(define-cell question)
(define-cell answer)
(define-cell closure)
(dynamic-call-site closure (list question answer))
(add-content question
(alist->virtual-copies
`((,repl-frame-a . 4) (,repl-frame-b . 4))))
(add-content answer
(alist->virtual-copies
`((,repl-frame-a . ,nothing) (,repl-frame-b . ,nothing))))
(add-content closure
(alist->virtual-copies
`((,repl-frame-a . ,fact-cl) (,repl-frame-b . ,fib-cl))))
(run)
(content answer)
(produces `((,repl-frame-a . 24) (,repl-frame-b . 5)))
))
;; TODO ((if mumble fact fib) 4) by tms premise?
(define-test (lambda-smoke)
(interaction
(initialize-scheduler)
(define-cell lambda-x)
(let-cells (x x-out)
(let-cells (y y-out)
(vc:adder x y y-out)
(v-closure-emitter (list y y-out) '() x-out))
(v-closure-emitter (list x x-out) '() lambda-x))
(define-cell outer-x)
(define-cell lambda-y)
(dynamic-call-site lambda-x (list outer-x lambda-y))
(define-cell outer-y)
(define-cell answer)
(dynamic-call-site lambda-y (list outer-y answer))
(define repl-frame (make-frame '()))
(add-content outer-x (alist->virtual-copies `((,repl-frame . 4))))
(add-content outer-y (alist->virtual-copies `((,repl-frame . 3))))
(for-each (lambda (cell)
(add-content cell (alist->virtual-copies `((,repl-frame . ,nothing)))))
(list lambda-x lambda-y answer))
(run)
(content answer)
(produces `((,repl-frame . 7)))
(define-cell outer-y2)
(define-cell answer2)
(dynamic-call-site lambda-y (list outer-y2 answer2))
(add-content outer-y2 (alist->virtual-copies `((,repl-frame . 7))))
(add-content answer2 (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content answer2)
(produces `((,repl-frame . 11)))
))
(define-test (compose)
(interaction
(initialize-scheduler)
(define-cell compose)
(let-cells (f g compose-out)
(let-cells (arg composition-out intermediate)
(dynamic-call-site g (list arg intermediate))
(dynamic-call-site f (list intermediate composition-out))
(v-closure-emitter
(list arg composition-out) (list intermediate) compose-out))
(v-closure-emitter (list f g compose-out) '() compose))
(define-cell double)
(let-cells (x out)
(vc:adder x x out)
(v-closure-emitter (list x out) '() double))
(define-cell square)
(let-cells (x out)
(vc:multiplier x x out)
(v-closure-emitter (list x out) '() square))
(define-cell square-double)
(dynamic-call-site compose (list square double square-double))
(define-cell x)
(define-cell answer)
(dynamic-call-site square-double (list x answer))
(define repl-frame (make-frame '()))
(for-each
(lambda (cell)
(add-content cell (alist->virtual-copies `((,repl-frame . ,nothing)))))
(list compose double square square-double x answer))
(add-content x (alist->virtual-copies `((,repl-frame . 4))))
(run)
(content answer)
(produces `((,repl-frame . 64)))
(define-cell double-square)
(dynamic-call-site compose (list double square double-square))
(define-cell x2)
(define-cell answer2)
(dynamic-call-site double-square (list x2 answer2))
(add-content x2 (alist->virtual-copies `((,repl-frame . 4))))
(add-content double-square
(alist->virtual-copies `((,repl-frame . ,nothing))))
(add-content answer2 (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content answer2)
(produces `((,repl-frame . 32)))
))
(define-test (repeat)
(interaction
(initialize-scheduler)
(define-cell compose)
(let-cells (f g compose-out)
(let-cells (arg composition-out intermediate)
(dynamic-call-site g (list arg intermediate))
(dynamic-call-site f (list intermediate composition-out))
(v-closure-emitter
(list arg composition-out) (list intermediate) compose-out))
(v-closure-emitter (list f g compose-out) '() compose))
(define-cell repeat)
(let-cells (f n repeat-out
recur? not-recur? f-again n-again f-n-1 one n-1 out-again)
((vc:const 1) one)
(vc:=? n one not-recur?)
(vc:inverter not-recur? recur?)
(vc:switch not-recur? f repeat-out)
(vc:switch recur? f f-again)
(vc:switch recur? n n-again)
(vc:switch recur? out-again repeat-out)
(vc:subtractor n-again one n-1)
(dynamic-call-site repeat (list f-again n-1 f-n-1))
(dynamic-call-site compose (list f-n-1 f-again out-again))
(v-closure-emitter
(list f n repeat-out)
(list recur? not-recur? f-again n-again f-n-1 one n-1 out-again)
repeat))
(define-cell double)
(let-cells (x out)
(vc:adder x x out)
(v-closure-emitter (list x out) '() double))
(define-cell n)
(define-cell n-double)
(dynamic-call-site repeat (list double n n-double))
(define-cell x)
(define-cell answer)
(dynamic-call-site n-double (list x answer))
(define repl-frame (make-frame '()))
(for-each
(lambda (cell)
(add-content cell (alist->virtual-copies `((,repl-frame . ,nothing)))))
(list compose repeat double n n-double x answer))
(add-content x (alist->virtual-copies `((,repl-frame . 1))))
(add-content n (alist->virtual-copies `((,repl-frame . 4))))
(run)
(content answer)
(produces `((,repl-frame . 16)))
))
)
propagator/extensions/test/virtual-environments-test.scm 0000664 0012467 0012467 00000023265 11421421706 022464 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
virtual-environments
(let* ((base (make-frame '()))
(derived (make-frame (list base)))
(base-content (make-interval 3 10))
(derived-content (make-interval 5 15))
(base-only
(alist->virtual-copies `((,base . ,base-content))))
(derived-only
(alist->virtual-copies `((,derived . ,derived-content))))
(base-and-derived
(alist->virtual-copies
`((,base . ,base-content)
(,derived . ,derived-content)))))
(define-each-check
(equal? (list derived base) (frame-ancestors derived))
(eq? base-content (direct-frame-content base-and-derived base))
(eq? derived-content (direct-frame-content base-and-derived derived))
(eq? base-content (full-frame-content base-and-derived base))
(equivalent? (merge base-content derived-content)
(full-frame-content base-and-derived derived))
(nothing? (direct-frame-content base-and-derived (make-frame '())))
(nothing? (full-frame-content base-and-derived (make-frame '())))
(lexical-invariant? base-only)
(lexical-invariant? derived-only)
(not (lexical-invariant? base-and-derived))
(acceptable-frame? derived (list base-only derived-only))
(good-frame? derived (list base-only derived-only))
(v-c-equal? base-and-derived (merge base-only derived-only))
(eq? base-and-derived (merge base-only base-and-derived))
(eq? base-and-derived
(merge (make-virtual-copies `((,base . ,(make-interval 2 12))))
base-and-derived))
(generic-match `((,base . #(interval 9 100)))
((v-c-i/o-unpacking generic-square) base-only base-only))
(generic-match `((,derived . #(interval 9 100)))
((v-c-i/o-unpacking generic-square)
base-only derived-only))
(generic-match `((,derived . #(interval 25 225)))
((v-c-i/o-unpacking generic-square)
derived-only derived-only))
(generic-match `((,base . #(interval 25 225)))
((v-c-i/o-unpacking generic-square)
derived-only base-only))
(generic-match `((,base . #(interval 9 100)))
((v-c-i/o-unpacking generic-*)
base-only base-only base-only))
(generic-match `((,base . #(interval 15 150)))
((v-c-i/o-unpacking generic-*)
base-only derived-only base-only))
(generic-match `((,derived . #(interval 15 150)))
((v-c-i/o-unpacking generic-*)
derived-only base-only derived-only))
(generic-match `((,derived . #(interval 9 100)))
((v-c-i/o-unpacking generic-*)
base-only base-only derived-only))
))
(define-test (interior-propagator-smoke)
(initialize-scheduler)
(define-cell four)
(define-cell zero)
(define-cell same)
(vc:=? four zero same)
(define repl-frame (make-frame '()))
(add-content four (alist->virtual-copies `((,repl-frame . 4))))
(add-content zero (alist->virtual-copies `((,repl-frame . 0))))
(add-content same (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content same)
(check (generic-match `((,repl-frame . #f)) (content same)))
)
(define-test (call-site-smoke)
(initialize-scheduler)
(define-cell in-squaree)
(define-cell in-square)
(vc:squarer in-squaree in-square)
(define repl-frame (make-frame '()))
(define-cell out-squaree)
(define-cell out-square)
(static-call-site
(make-v-closure (list in-squaree in-square) '() '())
(list out-squaree out-square))
(add-content out-squaree
(alist->virtual-copies `((,repl-frame . 4))))
(add-content out-square
(alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(check (generic-match `((,repl-frame . 16)) (content out-square))))
(define-test (factorial)
(initialize-scheduler)
;; Definition of factorial
(define-cell in-n)
(define-cell in-n!)
(define-cell zero)
(define-cell control)
(define-cell not-control)
(define-cell one)
(define-cell n-again)
(define-cell n-1)
(define-cell n-1!)
(define-cell empty)
(define fact
(make-v-closure
(list in-n in-n!)
(list zero control not-control one n-again n-1 n-1! empty)
'())) ; No global environment yet
((vc:const 0) zero)
((vc:const 1) one)
(vc:=? in-n zero control)
(vc:inverter control not-control)
(vc:switch control one in-n!)
(vc:switch not-control in-n n-again)
(vc:subtractor n-again one n-1)
(static-call-site fact (list n-1 n-1!))
(vc:multiplier n-1! in-n in-n!)
;; Use
(define repl-frame (make-frame '()))
(define-cell out-n)
(define-cell out-n!)
(static-call-site fact (list out-n out-n!))
(add-content out-n (alist->virtual-copies `((,repl-frame . 4))))
(add-content out-n! (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(check (generic-match `((,repl-frame . 24)) (content out-n!)))
)
(define-test (iterative-factorial)
;; TODO Of course, for this to really be iterative, we need to
;; flatten chains of virtual bridges that have no further effect
;; (except passing things through switches and such). An
;; approximation of the fully-determined? predicate might be
;; helpful.
(initialize-scheduler)
;; Definition of iterative factorial loop
(define-cell in-accum)
(define-cell in-n)
(define-cell out)
(define-cell one)
(define-cell done)
(define-cell not-done)
(define-cell recur-accum)
(define-cell accum-again)
(define-cell n-again)
(define-cell out-again)
(define-cell n-1)
(define fact-iter-loop
(make-v-closure
(list in-accum in-n out)
(list one done not-done recur-accum accum-again n-again out-again n-1)
'())) ; No global environment yet
((vc:const 1) one)
(vc:=? in-n one done)
(vc:inverter done not-done)
(vc:switch done in-accum out)
(vc:switch not-done in-accum accum-again)
(vc:switch not-done in-n n-again)
(vc:switch not-done out-again out)
(vc:subtractor n-again one n-1)
(vc:multiplier accum-again n-again recur-accum)
(static-call-site fact-iter-loop (list recur-accum n-1 out-again))
;; Definition of iterative factorial start
(define-cell n)
(define-cell n!)
(define-cell init-accum)
(define fact-start
(make-v-closure (list n n!) (list init-accum) '()))
((vc:const 1) init-accum)
(static-call-site fact-iter-loop (list init-accum n n!))
;; Use
(define repl-frame (make-frame '()))
(define-cell my-n)
(define-cell my-n!)
(static-call-site fact-start (list my-n my-n!))
(add-content my-n (alist->virtual-copies `((,repl-frame . 5))))
(add-content my-n! (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(check (generic-match `((,repl-frame . 120)) (content my-n!)))
)
(define-test (fibonacci)
(interaction
(initialize-scheduler)
;; Definition of fibonacci
(define-cell in-n)
(define-cell fib-n)
(define-cell one)
(define-cell two)
(define-cell recur)
(define-cell not-recur)
(define-cell n-again)
(define-cell n-1)
(define-cell n-2)
(define-cell fib-n-1)
(define-cell fib-n-2)
(define fib
(make-v-closure
(list in-n fib-n)
(list one two recur not-recur n-again n-1 n-2 fib-n-1 fib-n-2)
'()))
((vc:const 1) one)
((vc:const 2) two)
(vc: in-n two not-recur)
(vc:inverter not-recur recur)
(vc:switch not-recur one fib-n)
(vc:switch recur in-n n-again)
(vc:subtractor n-again one n-1)
(static-call-site fib (list n-1 fib-n-1))
(vc:subtractor n-again two n-2)
(static-call-site fib (list n-2 fib-n-2))
(vc:adder fib-n-1 fib-n-2 fib-n)
;; Use
(define repl-frame (make-frame '()))
(define-cell my-n)
(define-cell my-fib-n)
(static-call-site fib (list my-n my-fib-n))
(add-content my-n (alist->virtual-copies `((,repl-frame . 5))))
(add-content my-fib-n (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content my-fib-n)
(produces `((,repl-frame . 8)))
))
(define-test (fibonacci-again)
(interaction
(initialize-scheduler)
(define repl-frame (make-frame '()))
(define-cell n)
(define-cell fib-n)
(static-call-site fib-cl (list n fib-n))
(add-content n (alist->virtual-copies `((,repl-frame . 4))))
(add-content fib-n (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content fib-n)
(produces `((,repl-frame . 5)))
))
(define-test (euclid)
(interaction
(initialize-scheduler)
(define repl-frame (make-frame '()))
(define-cell a)
(define-cell b)
(define-cell gcd-a-b)
(static-call-site euclid-cl (list a b gcd-a-b))
(add-content a (alist->virtual-copies `((,repl-frame . ,(* 17 3)))))
(add-content b (alist->virtual-copies `((,repl-frame . ,(* 17 5)))))
(add-content gcd-a-b (alist->virtual-copies `((,repl-frame . ,nothing))))
(run)
(content gcd-a-b)
(produces `((,repl-frame . 17)))
))
)
propagator/extensions/dot-writer.scm 0000664 0012467 0012467 00000010140 11556111204 016377 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(define (make-dot-writer output-port)
(define (write-graph write-contents)
(write-string "digraph G {" output-port)
(newline output-port)
(draw:indented
(lambda ()
(write-options)
(write-contents)))
(write-string "}" output-port)
(newline output-port))
(define (write-options)
(for-each (lambda (option)
(write-indentation)
(write-string option output-port)
(write-string ";" output-port)
(newline output-port))
'(; "orientation=landscape"
; "size=\"10,7.5\""
; "page=\"8.5,11\""
"ratio=fill")))
(define (do-write-node node-id attributes)
(write-indentation)
(write node-id output-port)
(write-attributes attributes)
(write-string ";" output-port)
(newline output-port))
(define (node-shape node)
(cond ((cell? node) "ellipse")
((diagram? node) "box")
(else
(error "Unshapeable node type" node))))
(define (write-node node)
(do-write-node
(draw:node-id node)
`(("label" . ,(draw:node-label node))
("shape" . ,(node-shape node)))))
(define (write-edge source-name target-name label)
(write-indentation)
(write source-name output-port)
(write-string " -> " output-port)
(write target-name output-port)
(write-attributes `(("label" . ,label)))
(write-string ";" output-port)
(newline output-port))
(define (write-cluster id label write-contents)
(write-subgraph
(string-append "cluster_" (write-to-string id))
label write-contents))
(define (write-subgraph id label write-contents)
(write-indentation)
(write-string "subgraph " output-port)
(write-string id output-port)
(write-string " { " output-port)
(write-subgraph-attributes `(("label" . ,(write-to-string label))))
(newline output-port)
(draw:indented write-contents)
(write-indentation)
(write-string "}" output-port)
(newline output-port))
(define (write-attributes attributes)
(if (pair? attributes)
(let ((first-attribute? #t))
(write-string " [" output-port)
(for-each (lambda (attribute)
(if (not first-attribute?)
(write-string ", " output-port))
(write-string (car attribute) output-port)
(write-string "=" output-port)
(write (cdr attribute) output-port)
(set! first-attribute? #f))
attributes)
(write-string " ]" output-port))))
;;; TODO Why is the string handling in MIT Scheme so awful?
(define (write-subgraph-attributes attributes)
(if (pair? attributes)
(for-each (lambda (attribute)
(write-string (car attribute) output-port)
(write-string "=" output-port)
(write (cdr attribute) output-port)
(write-string "; " output-port))
attributes)))
(define (write-indentation)
(repeat draw:indentation-level
(lambda ()
(write-string " " output-port))))
(define (me message)
(cond ((eq? 'write-graph message) write-graph)
((eq? 'write-node message) write-node)
((eq? 'write-edge message) write-edge)
((eq? 'write-cluster message) write-cluster)
(else
(error "Unknown message" message))))
me)
propagator/extensions/load.scm 0000664 0012467 0012467 00000003744 11506433253 015240 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(define (self-relatively thunk)
(let ((place (ignore-errors current-load-pathname)))
(if (pathname? place)
(with-working-directory-pathname
(directory-namestring place)
thunk)
(thunk))))
(define (load-relative filename)
(self-relatively (lambda () (load filename))))
(load-relative "../core/load.scm")
(define *virtual-copies* #t)
(define (maybe thing bool)
(if bool
(list thing)
'()))
(for-each load-relative-compiled
`(,@(maybe "virtual-environments" *virtual-copies*)
,@(maybe "virtual-closures" *virtual-copies*)
"info-alist"
"functional-reactivity"
"solve" ; Requires mechanics to work
"inequalities" ; Requires mechanics to work
"symbolics" ; Requires mechanics to work
"symbolics-ineq" ; Requires mechanics to work
"test-utils"))
(for-each load-relative
`(,@(maybe "example-closures" *virtual-copies*)
"draw"
"dot-writer"
"graphml-writer"))
(maybe-warn-low-memory)
(initialize-scheduler)
propagator/extensions/symbolics-ineq.scm 0000664 0012467 0012467 00000026667 11542430404 017263 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;; local is a list of known "local" inequalities; applicable to "this
;;; value" only. These are represented as inequalities in the
;;; designated "variable" 'me. global is a list of known global
;;; inequalities, which should be transmitted to neighbors as
;;; appropriate. expression is a symbolic-expression object
;;; describing what is known about the present value with equality.
;;; The local inequalities are only useful if there is no expression
;;; (i.e. the expression is nothing), and will only be present in that
;;; case.
(declare (usual-integrations make-cell cell?))
(define-structure (symb-ineq (safe-accessors #t))
expression
local
global)
(declare-type-tester symb-ineq? rtd:symb-ineq)
(declare-coercion rtd:symb-ineq ->contingent) ;; Really?
(declare-coercion-target symb-ineq
(lambda (thing) (make-symb-ineq (->symbolic thing) '() '())))
(declare-coercion symbolic? ->symb-ineq)
(declare-coercion symbolic-able? ->symb-ineq)
(define (local->global-inequalities ineq-list)
(let ((lower-bounds (filter lower-bound-ineq? ineq-list))
(upper-bounds (filter upper-bound-ineq? ineq-list)))
(apply
append
(map (lambda (lower)
(map (lambda (upper)
(transitive-ineq lower upper))
upper-bounds))
lower-bounds))))
(define (apply-substitutions-to-inequality ineq substitutions)
(%make-inequality
(inequality-direction ineq)
(apply-substitutions (inequality-expr1 ineq) substitutions)
(apply-substitutions (inequality-expr2 ineq) substitutions)))
(define (apply-substitutions-to-inequalities ineqs substitutions)
(map (lambda (ineq)
(apply-substitutions-to-inequality ineq substitutions))
ineqs))
(define (local+expression->global expression local-ineqs)
(map normalize-ineq
(map (lambda (local-ineq)
(%make-inequality
(inequality-direction local-ineq)
expression
(inequality-expr2 local-ineq)))
local-ineqs)))
(define (symb-ineq-merge symb-ineq1 symb-ineq2)
(let ((new-expression (generic-flatten
(merge (symb-ineq-expression symb-ineq1)
(symb-ineq-expression symb-ineq2)))))
(cond ((contradictory? new-expression)
the-contradiction)
((nothing? new-expression)
(let ((new-local
;; TODO Also simplify them?
(delete-duplicates
(append (symb-ineq-local symb-ineq1)
(symb-ineq-local symb-ineq2)))))
(let ((new-global
(simplify-inequalities
(delete-duplicates
(append
(local->global-inequalities new-local)
(symb-ineq-global symb-ineq1)
(symb-ineq-global symb-ineq2))))))
(if (not new-global)
;; Solution failed
the-contradiction
;; TODO eq?-normalize
(make-symb-ineq new-expression new-local new-global)))))
((symbolic? new-expression)
(let ((substituted-local
(apply-substitutions-to-inequalities
(append (symb-ineq-local symb-ineq1)
(symb-ineq-local symb-ineq2))
(symbolic-substitutions (symbolic-metadata new-expression))))
(substituted-global
(apply-substitutions-to-inequalities
(append (symb-ineq-global symb-ineq1)
(symb-ineq-global symb-ineq2))
(symbolic-substitutions (symbolic-metadata new-expression)))))
(let ((new-global
(simplify-inequalities
(append
(local+expression->global
(symbolic-expression new-expression)
substituted-local)
substituted-global))))
(if (not new-global)
;; Solution failed
the-contradiction
;; TODO eq?-normalize
(make-symb-ineq new-expression '() new-global)))))
((boolean? new-expression)
;; TODO What about keeping track of the hard-earned metadata?
new-expression)
(else
(error "Wah! symb-ineq-merge doesn't know how to handle" new-expression)))))
(define (same-symb-ineq? symb-ineq1 symb-ineq2)
(and (symb-ineq? symb-ineq1)
(symb-ineq? symb-ineq2)
(or (equal? (symb-ineq-expression symb-ineq1)
(symb-ineq-expression symb-ineq2))
(same-symbolic? (symb-ineq-expression symb-ineq1)
(symb-ineq-expression symb-ineq2)))
(equal? (symb-ineq-local symb-ineq1)
(symb-ineq-local symb-ineq2))
(equal? (symb-ineq-global symb-ineq1)
(symb-ineq-global symb-ineq2))))
(defhandler-coercing merge symb-ineq-merge ->symb-ineq)
(defhandler-coercing equivalent? same-symb-ineq? ->symb-ineq)
(define (symb-ineq-binary-map ineq1 ineq2)
(lambda (f)
(merge
(make-symb-ineq nothing '() (symb-ineq-global ineq1))
(make-symb-ineq
(f (symb-ineq-expression ineq1)
(symb-ineq-expression ineq2))
'()
(symb-ineq-global ineq2)))))
(defhandler-coercing binary-map symb-ineq-binary-map ->symb-ineq)
(defhandler generic-unpack
(lambda (symb-ineq function)
(make-symb-ineq
(generic-bind (symb-ineq-expression symb-ineq) function)
'() ;; Never pass on the local stuff
(symb-ineq-global symb-ineq)))
symb-ineq? any?)
(defhandler generic-flatten
(lambda (symb-ineq) symb-ineq)
symb-ineq?)
;;; TODO This (and its analogue for regular symbolics) is dubious,
;;; because it may throw away metadata that might otherwise be worth
;;; transmitting. Oh well.
#;
(defhandler generic-flatten
(lambda (thing) nothing)
(guard rtd:symb-ineq (lambda (thing) (nothing? (symb-ineq-expression thing)))))
#;
(defhandler generic-flatten
(lambda (thing) nothing)
(guard rtd:symb-ineq (lambda (thing)
(nothing? (symb-ineq-expression thing))
(null? (symb-ineq-local thing))
(null? (symb-ineq-global thing)))))
(defhandler generic-flatten
(lambda (symb-ineq)
(generic-flatten
(let ((sub-ineq (symb-ineq-expression symb-ineq)))
;; TODO I wonder whether merge is generally useful for flattening...
(merge
(make-symb-ineq
nothing
(symb-ineq-local symb-ineq)
(symb-ineq-global symb-ineq))
sub-ineq))))
(guard rtd:symb-ineq (lambda (thing) (symb-ineq? (symb-ineq-expression thing)))))
;;; TODO Why am I writing so many methods for generic-flatten that
;;; just flip things inside out? Could a binary version of bind work
;;; better?
(defhandler generic-flatten
(lambda (symbolic)
(let ((sub-ineq (symbolic-expression symbolic)))
(generic-flatten
(make-symb-ineq
(generic-flatten
(%make-symbolic
(generic-flatten (symb-ineq-expression sub-ineq))
(symbolic-metadata symbolic)))
(symb-ineq-local sub-ineq)
(symb-ineq-global sub-ineq)))))
(guard rtd:symbolic (lambda (thing) (symb-ineq? (symbolic-expression thing)))))
(defhandler generic-flatten
(lambda (symb-ineq)
(let ((the-tms (generic-flatten (symb-ineq-expression symb-ineq))))
(let ((the-value (tms-query the-tms)))
(if (nothing? the-value)
nothing
(generic-flatten
(make-tms
(supported
(generic-flatten
(make-symb-ineq
(generic-flatten (v&s-value the-value))
(symb-ineq-local symb-ineq)
(symb-ineq-global symb-ineq)))
(v&s-support the-value)
(v&s-informants the-value))))))))
(guard rtd:symb-ineq (lambda (thing) (tms? (symb-ineq-expression thing)))))
(defhandler generic-flatten
(lambda (symb-ineq)
(symb-ineq-expression symb-ineq))
(guard rtd:symb-ineq (lambda (thing) (boolean? (symb-ineq-expression thing)))))
(defhandler generic-flatten
(lambda (symbolic)
(symbolic-expression symbolic))
(guard rtd:symbolic (lambda (thing) (boolean? (symbolic-expression thing)))))
(define ((ineq-enforcer-func direction) in)
(make-symb-ineq
nothing
(list (%make-inequality direction 'me in))
'()))
(define (ineq-enforcer direction)
(function->propagator-constructor
(nary-unpacking
(ineq-enforcer-func direction))))
(define ((toggled-enforcer direction) control in out)
(let-cell intermediate
(p:switch control in intermediate)
((ineq-enforcer (reverse-sense direction)) intermediate out)))
(define ((ineq-constraint prop dir) control in out)
(let-cell not-control
(p:not control not-control)
(prop in out control)
((toggled-enforcer dir) control in out)
((toggled-enforcer (reverse-sense dir)) control out in)
((toggled-enforcer (negate-sense dir)) not-control in out)
((toggled-enforcer (reverse-sense (negate-sense dir))) not-control out in)))
(define c:> (ineq-constraint p:> '>))
(define c:>= (ineq-constraint p:>= '>=))
(define c:<= (ineq-constraint p:<= '<=))
(define c:< (ineq-constraint p:< '<))
(define (determined-symbolic? thing)
(or (and (symbolic? thing)
(or (number? (symbolic-expression thing))
(boolean? (symbolic-expression thing))
(determined-symbolic? (symbolic-expression thing))))
(and (symb-ineq? thing)
(or (number? (symb-ineq-expression thing))
(boolean? (symb-ineq-expression thing))
(determined-symbolic? (symb-ineq-expression thing))))))
(define (undetermined-symbolic? thing)
(and (or (symbolic? thing)
(symb-ineq? thing))
(not (determined-symbolic? thing))))
(define (the-determined-answer thing)
(cond ((not (determined-symbolic? thing))
(error "There is no answer" thing))
((number? thing)
thing)
((boolean? thing)
thing)
((symbolic? thing)
(the-determined-answer (symbolic-expression thing)))
((symb-ineq? thing)
(the-determined-answer (symb-ineq-expression thing)))
(else
(error "This shouldn't happen to the-determined-answer" thing))))
(defhandler merge
(lambda (content increment)
(merge (the-determined-answer content)
(the-determined-answer increment)))
boolean? determined-symbolic?)
(defhandler merge
(lambda (content increment)
(merge (the-determined-answer content)
(the-determined-answer increment)))
determined-symbolic? boolean?)
(defhandler merge
(lambda (content increment)
content)
boolean? undetermined-symbolic?)
(defhandler merge
(lambda (content increment)
increment)
undetermined-symbolic? boolean?)
(define (axch-abstract-number? thing)
;; TODO Ugh!
(or (symbol? thing)
(and (list? thing)
(memq (car thing) '(+ - * /)))))
(define (no-abstract-comparisons operation)
(defhandler operation
(lambda (a b) nothing)
number? axch-abstract-number?)
(defhandler operation
(lambda (a b) nothing)
axch-abstract-number? number?)
(defhandler operation
(lambda (a b) nothing)
axch-abstract-number? axch-abstract-number?))
(no-abstract-comparisons generic->)
(no-abstract-comparisons generic-<)
(no-abstract-comparisons generic->=)
(no-abstract-comparisons generic-<=)
#|
;;; TODO This feels like a hack...
;;; moved to standard-propagators
(defhandler generic-/
(lambda (a b) nothing)
any? (lambda (x) (and (number? x) (zero? x))))
|# propagator/extensions/symbolics.scm 0000664 0012467 0012467 00000021361 11542430404 016313 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define-structure
(symbolic-metadata (conc-name symbolic-) (safe-accessors #t))
variable-order
substitutions
residual-equations)
(define (empty-metadata)
(make-symbolic-metadata '() '() '()))
(define (same-metadata? meta1 meta2)
(and (equal? (symbolic-variable-order meta1)
(symbolic-variable-order meta2))
(equal? (symbolic-substitutions meta1)
(symbolic-substitutions meta2))
(equal? (symbolic-residual-equations meta1)
(symbolic-residual-equations meta2))))
(define (combine-variable-orders order1 order2)
(append
order1
(filter (lambda (v)
(not (member v order1 same-variable?)))
order2)))
(define (same-variable? var1 var2)
(eq? var1 var2))
(define (unify-metadata meta1 meta2)
(let ((new-variable-order (combine-variable-orders
(symbolic-variable-order meta1)
(symbolic-variable-order meta2))))
(let ((solution
(solve-incremental
(append
(substs->equations (symbolic-substitutions meta2))
(symbolic-residual-equations meta1)
(symbolic-residual-equations meta2))
new-variable-order
(symbolic-substitutions meta1))))
;; TODO Check the solution for being contradictory
(make-symbolic-metadata
new-variable-order
(substitutions solution)
(residual-equations solution)))))
(define (list-unify-metadata metadatas)
(reduce unify-metadata (empty-metadata) metadatas))
(define-structure
(symbolic (constructor %make-symbolic) (safe-accessors #t))
expression
metadata)
(declare-type-tester symbolic? rtd:symbolic)
(declare-coercion rtd:symbolic ->contingent)
(declare-coercion-target symbolic
(lambda (thing) (make-symbolic thing (empty-metadata))))
(declare-coercion ->symbolic)
(declare-coercion ->symbolic)
(define (make-symbolic expression metadata)
(%make-symbolic
(simplify (apply-substitutions expression (symbolic-substitutions metadata)))
metadata))
(define (same-symbolic? symb1 symb2)
;; TODO I really want good generic equality!
(and (symbolic? symb1)
(symbolic? symb2)
(equal? (symbolic-expression symb1)
(symbolic-expression symb2))
(same-metadata? (symbolic-metadata symb1)
(symbolic-metadata symb2))))
(define (symbolic-merge symb1 symb2)
(let* ((new-metadata (unify-metadata (symbolic-metadata symb1)
(symbolic-metadata symb2)))
(expr1 (symbolic-expression symb1))
(expr2 (symbolic-expression symb2))
(equation (symb:- expr1 expr2))
(solution
(solve-incremental
(cons (make-equation equation '())
(symbolic-residual-equations new-metadata))
(symbolic-variable-order new-metadata)
(symbolic-substitutions new-metadata))))
(cond ((eqn-contradiction? solution)
the-contradiction)
(else
(make-symbolic
expr1
(make-symbolic-metadata
(symbolic-variable-order new-metadata)
(substitutions solution)
(residual-equations solution)))))))
(defhandler-coercing merge symbolic-merge ->symbolic)
(defhandler-coercing equivalent? same-symbolic? ->symbolic)
(define (symbolic-binary-map symb1 symb2)
(lambda (f)
(let ((answer (f (symbolic-expression symb1) (symbolic-expression symb2))))
;; This check protects against confusion engendered by >
;; returning nothing or a boolean. I will need to understand
;; more carefully what's going on to do this more cleanly. In
;; particular, doing things this way drops hard-earned metadata
;; on the floor.
(if (or (nothing? answer) (boolean? answer))
answer
(make-symbolic
answer
(unify-metadata (symbolic-metadata symb1) (symbolic-metadata symb2)))))))
(defhandler-coercing binary-map symbolic-binary-map ->symbolic)
;;; Two ways to add symbolic expressions as a partial information type.
;;; One way is to use the nary-unpacking machinery:
(defhandler generic-unpack
(lambda (symbolic function)
(%make-symbolic ; The simplify in make-symbolic chokes on nothings
(generic-bind (symbolic-expression symbolic) function)
(symbolic-metadata symbolic)))
symbolic? any?)
(defhandler generic-flatten
(lambda (symbolic)
(make-symbolic ; Invoke the simplify that didn't happen in generic-unpack
(symbolic-expression symbolic)
(symbolic-metadata symbolic)))
symbolic?)
(defhandler generic-flatten
(lambda (symb1)
(generic-flatten
(make-symbolic
(generic-flatten (symbolic-expression (symbolic-expression symb1)))
(unify-metadata (symbolic-metadata symb1)
(symbolic-metadata (symbolic-expression symb1))))))
(guard rtd:symbolic (lambda (thing) (symbolic? (symbolic-expression thing)))))
(defhandler generic-flatten
(lambda (thing) nothing)
(guard rtd:symbolic (lambda (thing) (nothing? (symbolic-expression thing)))))
(defhandler generic-flatten
(lambda (symbolic)
(let ((the-tms (generic-flatten (symbolic-expression symbolic))))
(let ((the-value (tms-query the-tms)))
(if (nothing? the-value)
nothing
(generic-flatten
(make-tms
(supported
(generic-flatten
(%make-symbolic
(generic-flatten (v&s-value the-value))
(symbolic-metadata symbolic)))
(v&s-support the-value)
(v&s-informants the-value))))))))
(guard rtd:symbolic (lambda (thing) (tms? (symbolic-expression thing)))))
;;; The other way is the old school, adding methods to every generic
;;; operation:
#;
(define (symbolic-unpacking f)
(lambda args
(make-symbolic
(apply f (map symbolic-expression args))
(list-unify-metadata (map symbolic-metadata args)))))
#;
(define (coerce-symbolic operator)
(case (generic-operator-arity operator)
((1)
(defhandler operator (symbolic-unpacking operator) symbolic?))
((2)
(defhandler operator (symbolic-unpacking operator) symbolic? symbolic?)
(defhandler operator (coercing ->symbolic operator) symbolic? symbolic-able?)
(defhandler operator (coercing ->symbolic operator) symbolic-able? symbolic?))))
#;
(for-each coerce-symbolic
(list generic-+ generic-- generic-* generic-/
generic-= generic-< generic-> generic-<= generic->=
generic-and generic-or
generic-abs generic-square generic-sqrt generic-not))
;;; The old school method is annoying because one needs to maintain a
;;; complete list of all the generic operations one might want to
;;; augment, and it doesn't really scale to applications like teaching
;;; car to handle TMSes. On the other hand, the new school method is
;;; annoying because it's asymmetric in the arguments (there's no good
;;; way to say "if either argument is nothing, don't bother me"), and
;;; because repacked but not yet flattened structures often seem to
;;; violate that data type's invariants. TMSes and symbolic
;;; expressions are a case in point: they are not written to handle
;;; having a nothing for payload, but generic-unpack shoves it right
;;; in so that generic-flatten can take it back out again. Maybe this
;;; is why Haskell chose bind as the fundamental monadic operation.
;;; The asymmetry can be largely solved by defining
;;; generic-binary-unpack (which is used inside a binary bind,
;;; followed by the same flatten).
;;; The new school method also has the problem that it isn't really
;;; very good for the comparison operators, because this data type is
;;; really only applicable to numbers, not to boolean values (unless I
;;; change it to be applicable to boolean values too...)
(define (make-variable)
(generate-uninterned-symbol 'x))
(define (variable->symbolic variable)
(make-symbolic
variable
(make-symbolic-metadata (list variable) '() '())))
(define (plunker cell #!optional variable)
(let ((my-var (if (default-object? variable)
(make-variable)
variable)))
((constant (variable->symbolic my-var)) cell)))
propagator/extensions/run-tests 0000775 0012467 0012467 00000000372 11334635502 015501 0 ustar gjs gjs #!/bin/sh
exec ./mechanics --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --load load.scm --load test/load --eval '(let ((v (show-time run-registered-tests))) (newline) (flush-output) (%exit v))'
propagator/extensions/solve.scm 0000664 0012467 0012467 00000047064 11537734465 015471 0 ustar gjs gjs #| -*-Scheme-*-
$Id$
Copyright 2006 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.
|#
;;; Must be loaded before handler.scm if used in constraint propagator.
;;;; Simple catch-as-catch-can solver #42.
;;; By GJS, November 2003. For use with SCMUTILS.
;;; Updated by GJS, 8 April 2009.
(declare (usual-integrations))
;;; Assumes standardized equations, as produced below.
#|
(define (solve-incremental equations variables) ...)
;;; Variables list gives variables to be eliminated in the preferred
;;; order of elimination.
;;; To access the parts of a solution returned by solve-incremental
(define (residual-equations solution) ...)
(define (residual-variables solution) ...)
(define (substitutions solution) ...)
(define (hopeless-variables solution) ...)
;;; To access substitutions produced by solve-incremental
(define (substitution-variable subst) ...)
(define (substitution-expression subst) ...)
(define (substitution-justifications subst) ...)
;;; To access residual equations of a solution
(define (equation-expression eqn) ...)
(define (equation-justifications eqn) ...)
|#
#|
We are looking to accumulate a substitution for
each variable, and use it to eliminate that
variable from the resulting equations and
previously acquired substitutions.
The general strategy is:
1. Choose a variable to eliminate.
2. Look for an equation for which that variable
can be isolated.
3. Isolate and make a substitution for that
variable.
4. Use the substitution to eliminate the variable
from the remaining equations.
5. Use the substitution to eliminate the variable
from the accumulated substitutions.
6. If more variables and more equations,
go to step #1.
|#
(define (residual-equations solution) (car solution))
(define (residual-variables solution) (cadr solution))
(define (substitutions solution) (caddr solution))
(define (hopeless-variables solution) (cadddr solution))
;;; The following is commented out to make the system work with the new version
;;; of scmutils, but it breaks the old version. We should fix.
#;
(define (solve-incremental equations variables #!optional substitutions hopeless)
(if (default-object? substitutions) (set! substitutions '()))
(if (default-object? hopeless) (set! hopeless '()))
(let lp ((residual-eqs
(flush-tautologies
(map (lambda (equation)
(apply-substitutions-to-equation equation substitutions))
equations)))
(residual-vars variables)
(substitutions substitutions)
(hopeless-vars hopeless)
(progress #f))
(define (return)
(list residual-eqs residual-vars substitutions hopeless-vars))
(cond ((null? residual-eqs) ; Done
(return))
((null? residual-vars)
(cond ((null? hopeless-vars) (return))
(progress
(lp residual-eqs hopeless-vars substitutions '() #f))
(else (return))))
(else
(isolate-var
(car residual-vars)
(sort residual-eqs fewer-variables?)
(lambda (new-substitution equation-used)
(lp (flush-tautologies
(next-equations new-substitution
(delete equation-used residual-eqs)))
(cdr residual-vars)
(cons new-substitution
(next-substitutions new-substitution substitutions))
hopeless-vars
#t))
(lambda () ; fail
(lp residual-eqs
(cdr residual-vars)
substitutions
(cons (car residual-vars) hopeless-vars)
progress)))))))
(define (fewer-variables? eqn1 eqn2)
(< (length (equation-variables eqn1))
(length (equation-variables eqn2))))
(define (flush-tautologies equations)
(filter (lambda (eqn)
(let ((expr
(equation-expression eqn)))
(not (and (number? expr)
(= expr 0)))))
equations))
(define (next-equations substitution equations)
(map (lambda (equation)
(backsubstitute-equation substitution
equation))
equations))
(define (next-substitutions new-substitution
substitutions)
(map (lambda (substitution)
(backsubstitute-substitution new-substitution
substitution))
substitutions))
;;; To isolate a variable, given a set of
;;; equations we go through the equations and try
;;; to isolate the variable from each one. Note
;;; that in the following code we find the first
;;; reference to justifications.
(define (isolate-var var eqs succeed fail)
;; succeed = (lambda (new-substitution equation-used) ...)
;; fail = (lambda () ...)
(let lp ((eqs-to-scan eqs))
(cond ((null? eqs-to-scan) (fail))
((occurs? var (car eqs-to-scan))
(isolatable? var (car eqs-to-scan)
(lambda (value)
(succeed
(make-substitution var value
(equation-justifications (car eqs-to-scan)))
(car eqs-to-scan)))
(lambda ()
(lp (cdr eqs-to-scan)))))
(else (lp (cdr eqs-to-scan))))))
(define (occurs? var expr)
(or (equal? var expr)
(and (pair? expr)
(or (occurs? var (car expr))
(occurs? var (cdr expr))))))
;;; Isolatable is a kludge. It should have been
;;; written as a pattern-matcher, but it wasn't
;;; when I wrote it. Sorry...
(define (isolatable? var eqn succeed fail)
(let lp ((expr (equation-expression eqn)))
(cond ((equal? var expr) (succeed 0))
((positive-power? expr)
(lp (car (operands expr))))
((product? expr)
;; If var^n in operands then zero.
(var-in-product var expr succeed fail))
((sum? expr)
(var-in-sum var expr succeed fail))
(else (fail)))))
(define (positive-power? expr)
(and (expt? expr)
(number? (cadr (operands expr)))
(> (cadr (operands expr)) 0)))
(define (var-in-product var expr succeed fail)
(let lp ((factors (operands expr)))
(if (pair? factors)
(let ((ff (car factors)))
(cond ((and (symbol? ff)
(equal? var ff))
(succeed 0))
((and
(positive-power? ff)
(equal? var
(car (operands ff))))
(succeed 0))
(else
(lp (cdr factors)))))
(fail))))
(define (var-in-sum var expr succeed fail)
;; Split addends into with var^1 and without...
(let lp ((addends (operands expr))
(with '())
(without '()))
(cond ((null? addends)
(if (null? without)
(succeed 0)
(succeed
(symb:quo (symb:negate (symb:add:n without))
(symb:add:n with)))))
((occurs? var (car addends))
(let ((addend (car addends)))
(cond ((equal? var addend)
(lp (cdr addends)
(cons 1 with)
without))
((product? addend)
(let ((factors (operands addend)))
(if (member var factors)
(lp (cdr addends)
(cons
(symb:mul:n (delete var factors))
with)
without)
;; occurs more painfully
(fail))))
(else (fail)))))
(else
(lp (cdr addends)
with
(cons (car addends) without))))))
(define (backsubstitute-substitution new-substitution substitution)
(if (occurs? (substitution-variable new-substitution)
(substitution-expression substitution))
(make-substitution
(substitution-variable substitution)
(substitute (substitution-expression new-substitution)
(substitution-variable new-substitution)
(substitution-expression substitution))
(list-union (substitution-justifications substitution)
(substitution-justifications new-substitution)))
substitution))
(define (backsubstitute-equation substitution equation)
(if (occurs? (substitution-variable substitution)
(equation-expression equation))
(make-equation
(substitute (substitution-expression substitution)
(substitution-variable substitution)
(equation-expression equation))
(list-union (equation-justifications equation)
(substitution-justifications substitution)))
equation))
(define (substs->equations substs)
(map subst->equation substs))
(define (subst->equation subst)
(make-equation
(symb:- (substitution-variable subst)
(substitution-expression subst))
(substitution-justifications subst)))
(define (apply-substitutions expression substitutions)
(let loop ((expression expression)
(substs substitutions))
(if (null? substs)
expression
(loop (substitute (substitution-expression (car substs))
(substitution-variable (car substs))
expression)
(cdr substs)))))
(define (apply-substitutions-to-equation equation substitutions)
(make-equation
(apply-substitutions (equation-expression equation)
substitutions)
(equation-justifications equation)))
(define (make-substitution var value justs)
(list (list '= var (simplify value)) justs))
(define (substitution-variable subst) (cadar subst))
(define (substitution-expression subst) (caddar subst))
(define (substitution-justifications subst) (cadr subst))
(define (make-equation expr justs)
(let* ((specs (standardize-equation expr '() '() #f))
(pexpr (car specs))
(vspecs (cadr specs)))
(if (and (number? pexpr) (not (= pexpr 0)))
(begin (if *solve:contradiction-wallp*
(write-line `(contradiction ,justs)))
(list pexpr justs vspecs))
(list pexpr justs vspecs))))
(define (equation-expression eqn) (car eqn))
(define (equation-justifications eqn) (cadr eqn))
(define (equation-variables eqn) (caddr eqn))
(if (not (lexical-unbound? (the-environment) '*solve:contradiction-wallp*))
(set! *solve:contradiction-wallp* #f))
(define *solve:contradiction-wallp* #f)
(define (contradictory-eqn? eqn)
(let ((expr (equation-expression eqn)))
(and (number? expr) (not (= expr 0)))))
(define (eqn-contradiction? solution)
(any contradictory-eqn? (residual-equations solution)))
;;; This stuff is in support of standardize-equation, below.
(define *zero-threshold* 1e-15) ;for small numbers
(define (differential-operator? expression)
(or (D? expression) (Dn? expression)))
(define (D? x)
(and (pair? x)
(eq? (car x) 'D)))
(define (Dn? x)
(and (pair? x)
(expt? (car x))
(eq? (car (operands (car x))) 'D)))
;;; The procedure standardize-equation is a wierd device that performs
;;; several functions. It walks the residual, finding the variables
;;; that one might want to solve for and adds them to the given
;;; variables. This is the new-map. Given an independent variable,
;;; say t, it finds expression that are functions of t, such as (f t),
;;; ((D f) t), (((expt D 2) f) t) and adds them to the given functions
;;; and the map. This is useful for hacking differential equations,
;;; by extracting the time functions from the algebraic skeleton.
;;; This code also finds very small numbers and makes them zero, to
;;; improve simplification -- this is questionable.
#|
;;; For example...
(pp (standardize-equation '(- (* 3 ((D f) t))
(+ (* (sqrt x) z (f t))
(g t)
(((expt D 2) g) t)
(square y)))
'() '() 't))
((+ (* -1 z (f t) (sqrt x))
(* -1 (expt y 2))
(* 3 ((D f) t))
(* -1 (g t))
(* -1 (((expt D 2) g) t)))
((((expt D 2) g) t) (g t) ((D f) t) y x (f t) z)
(((expt D 2) g) g (D f) f))
|#
(define (standardize-equation residual variables functions variable)
;; returns list = (new-residual new-map functions)
(let ((redo #f)) ; True if an inexact number becomes exact
(define (walk-expression expression map functions continue)
(cond ((pair? expression)
(let ((rator (operator expression))
(rands (operands expression)))
(cond ((and (= (length rands) 1)
(eq? (car rands) variable))
(continue expression
(list-adjoin expression map)
(list-adjoin rator functions)))
((differential-operator? expression)
(continue expression
map
(list-adjoin expression functions)))
(else
(walk-expression rator map functions
(lambda (rator-result rator-map rator-functions)
(walk-list rands rator-map rator-functions
(lambda (rands-result rands-map rands-functions)
(continue (cons rator-result
rands-result)
rands-map
rands-functions)))))))))
((number? expression)
(continue (if (and (inexact? expression)
(< (abs expression) *zero-threshold*))
(begin (set! redo #t) 0)
expression)
map
functions))
((memq expression '(+ - / * D expt sqrt exp sin cos))
(continue expression map functions))
(else
(continue expression (list-adjoin expression map) functions))))
(define (walk-list elist map functions continue)
(if (pair? elist)
(walk-expression (car elist) map functions
(lambda (car-result car-map car-functions)
(walk-list (cdr elist) car-map car-functions
(lambda (cdr-result cdr-map cdr-functions)
(continue (cons car-result cdr-result)
cdr-map
cdr-functions)))))
(continue elist map functions)))
(let lp ((residual (simplify residual)))
(walk-expression (if (quotient? residual)
(symb:dividend residual)
residual)
variables
functions
(lambda (expression map funs)
(if redo
(begin (set! redo #f)
(lp (simplify expression)))
(list expression map funs)))))))
#|
;;; Signs of life.
(pp (solve-incremental
(list (make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(x y)))
(() () (((= y 1) (B A)) ((= x 2) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ x y z 1) (list 'A))
(make-equation '(+ x y 2) (list 'B))
(make-equation '(+ x 1) (list 'C)))
'(x y z)))
(() () (((= z 1) (A B C)) ((= y -1) (B C)) ((= x -1) (C))) ())
(pp (solve-incremental
(list (make-equation '(+ x 1) (list 'C))
(make-equation '(+ x y 2) (list 'B))
(make-equation '(+ x y z 1) (list 'A)))
'(x y z)))
(() () (((= z 1) (A B C)) ((= y -1) (B C)) ((= x -1) (C))) ())
;;; The following signals a contradiction, as it should:
(pp (solve-incremental
(list (make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) y -5) (list 'B)))
'(x y)))
(contradiction (B A))
(((2 (B A))) () (((= x (+ 7/3 (* -1/3 y))) (A))) (y))
;;; Some slightly nonlinear systems can be solved:
(pp (solve-incremental
(list (make-equation '(- 3 (+ x y)) (list 'A))
(make-equation '(- 5 (- x y)) (list 'B))
(make-equation '(- 3 (+ (* (sqrt x) z) (square y))) (list 'C)))
'(x y z)))
(() () (((= z 1) (C B A)) ((= y -1) (B A)) ((= x 4) (B A))) ())
;;; Underdetermined systems can be reduced:
(pp (solve-incremental
(list (make-equation '(+ (* (+ a b) (- a c)) c) (list 'A))
(make-equation '(- 3 (+ a b)) (list 'B)))
'(a b c)))
(() (c) (((= b (+ 3 (* -2/3 c))) (A B)) ((= a (* 2/3 c)) (A B))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (+ a b) (- a c)) c) (list 'A))
(make-equation '(- 3 (- a c)) (list 'B)))
'(a b c)))
(() (c) (((= b (+ -3 (* -4/3 c))) (A B)) ((= a (+ 3 c)) (B))) ())
;;; Even very hard ones are clarified.
(pp (solve-incremental
(list (make-equation '(+ (* (+ a b) (- a c)) c) (list 'A))
(make-equation '(- 3 (- a b)) (list 'B)))
'(a b c)))
(()
()
(((= c (/ (+ 9/2 (expt b 2) (* 9/2 b)) (+ 1 b))) (A B))
((= a (+ 3 b)) (B)))
(b))
;;; This can be improved...
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(x y z)))
(() () (((= z -1/2) (C B A)) ((= y 1) (B A)) ((= x 2) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(z x y)))
((((+ 1 (* 2 z)) (C B A) (z))) () (((= y 1) (B A)) ((= x 2) (B A))) (z))
;;; Now fixed -- 3 April 2007 -- GJS
(() () (((= z -1/2) (C B A)) ((= y 1) (B A)) ((= x 2) (B A))) ())
;;; The following are permutations of the solution sequence
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(x y z)))
(() () (((= z -1/2) (C B A)) ((= y 1) (B A)) ((= x 2) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(z x y)))
(() () (((= z -1/2) (C B A)) ((= y 1) (B A)) ((= x 2) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(y z x)))
(() () (((= z -1/2) (C B A)) ((= x 2) (B A)) ((= y 1) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(y x z)))
(() () (((= z -1/2) (C B A)) ((= x 2) (B A)) ((= y 1) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(z y x)))
(() () (((= z -1/2) (C B A)) ((= x 2) (B A)) ((= y 1) (B A))) ())
(pp (solve-incremental
(list (make-equation '(+ (* (- x (* 2 y)) (expt z 2)) (* 2 z) 1) (list 'C))
(make-equation '(+ (* 3 x) y -7) (list 'A))
(make-equation '(+ (* 3 x) (- y) -5) (list 'B)))
'(x z y)))
(() () (((= z -1/2) (C B A)) ((= y 1) (B A)) ((= x 2) (B A))) ())
;;; Loses Badly
(pp (solve-incremental
(list (make-equation '(- 200/3 (/ 1 (+ (/ 1 R1) (/ 1 R2)))) (list 'A))
(make-equation '(- 1/3 (/ R2 (+ R1 R2))) (list 'B)))
'(R1 R2)))
((((+ (/ (* -1 R1 R2) (+ R1 R2))
(/ (* 200/3 R1) (+ R1 R2))
(/ (* 200/3 R2) (+ R1 R2)))
(A)
(R2 R1))
((+ (/ (* 1/3 R1) (+ R1 R2)) (/ (* -2/3 R2) (+ R1 R2))) (B) (R2 R1)))
()
()
(R2 R1))
;;; But, I can solve it by clearing the denominator of B!
(pp (solve-incremental
(list (make-equation '(- 200/3 (/ 1 (+ (/ 1 R1) (/ 1 R2)))) (list 'A))
(make-equation '(- (* 1/3 (+ R1 R2)) R2) (list 'B)))
'(R1 R2)))
(() () (((= R2 100) (A B)) ((= R1 200) (A B))) ())
;;; But, if I clear both denominators, unfortunately I get a quadratic!
(pp (solve-incremental
(list (make-equation '(- (* 200/3 (+ R1 R2)) (* R1 R2)) (list 'A))
(make-equation '(- (* 1/3 (+ R1 R2)) R2) (list 'B)))
'(R1 R2)))
((((+ (/ (* -2/3 (expt R2 2)) (+ -200/3 R2)) (/ (* 200/3 R2) (+ -200/3 R2)))
(B A)
(R2)))
()
(((= R1 (/ (* 200/3 R2) (+ -200/3 R2))) (A)))
(R2))
;;; I still lose if I do it in the other order
(pp (solve-incremental
(list (make-equation '(- (* 1/3 (+ R1 R2)) R2) (list 'B))
(make-equation '(- (* 200/3 (+ R1 R2)) (* R1 R2)) (list 'A)))
'(R1 R2)))
((((+ (* -2 (expt R2 2)) (* 200 R2)) (A B) (R2))) () (((= R1 (* 2 R2)) (B))) (R2))
;;; But not so badly, because the quadratic is simpler.
;;; Unfortunately, the extra root, R2=0 & R1=0 satisfies the given
;;; equations but not the original problem.
|#
propagator/extensions/functional-reactivity.scm 0000664 0012467 0012467 00000012744 11421421707 020641 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define-structure
(frpremise
(constructor make-frpremise (identity timestamp))
(print-procedure
(simple-unparser-method 'frp
(lambda (frpremise)
(list (frpremise-identity frpremise)
(frpremise-timestamp frpremise))))))
identity
timestamp
(total-delay 0) ;; TODO Account for this
)
(define (fr-same-input? frp1 frp2)
(eq? (frpremise-identity frp1)
(frpremise-identity frp2)))
(define (fr-invalidates? frp1 frp2)
(and (fr-same-input? frp1 frp2)
(> (frpremise-timestamp frp1)
(frpremise-timestamp frp2))))
(define-structure
;; For functional reactive supported
(frs (constructor %make-frs (value support))
(print-procedure
(simple-unparser-method 'frs
(lambda (frs)
(list (frs-value frs) (frs-support frs))))))
value
support
(stale #f))
(declare-type-tester frs? rtd:frs)
(define (make-frs value support)
(%make-frs value (listify support)))
(define (make-stale-frs value support)
(let ((answer (make-frs value support)))
(set-frs-stale! answer #t)
answer))
(define (stale-frs? thing)
(and (frs? thing) (frs-stale thing)))
(declare-explicit-guard stale-frs? rtd:frs)
(define (fr-support-invalidates? frsupport1 frsupport2)
(any (lambda (frp1)
(any (lambda (frp2)
(fr-invalidates? frp1 frp2))
frsupport2))
frsupport1))
(define (fr-merge-supports frsupport1 frsupport2)
(lset-union fr-same-input? frsupport1 frsupport2))
(define (fr-more-recent? frsupport1 frsupport2)
(>-list (map frpremise-timestamp frsupport1)
(map frpremise-timestamp frsupport2)))
(define (>-list lst1 lst2)
(cond ((and (null? ls1) (null? ls2))
#f)
((null? lst1)
#t)
((null? lst2)
#f)
((> (car lst1) (car lst2))
#t)
((< (car lst1) (car lst2))
#t)
(else
(>-list (cdr lst1) (cdr lst2)))))
(declare-coercion-target frs
(lambda (thing) (make-frs thing '())))
(declare-coercion ->frs)
(declare-coercion ->frs)
(define (frs-binary-map frs1 frs2)
(lambda (f)
(let ((support1 (frs-support frs1))
(support2 (frs-support frs2)))
(if (or (fr-support-invalidates? support1 support2)
(fr-support-invalidates? support2 support1))
nothing
(make-frs
(f (frs-value frs1) (frs-value frs2))
(fr-merge-supports support1 support2))))))
(defhandler-coercing binary-map frs-binary-map ->frs)
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
frs? stale-frs?)
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
stale-frs? frs?)
(defhandler generic-unpack
(lambda (frs function)
(make-frs
(generic-bind (frs-value frs) function)
(frs-support frs)))
frs? any?)
(defhandler generic-unpack
(lambda (frs function) nothing)
stale-frs? any?)
(defhandler generic-flatten
(lambda (frs) nothing)
(guard rtd:frs (lambda (thing) (nothing? (frs-value thing)))))
(defhandler generic-flatten
(lambda (frs)
(let ((support1 (frs-support frs))
(support2 (frs-support (frs-value frs))))
(if (or (fr-support-invalidates? support1 support2)
(fr-support-invalidates? support2 support1))
nothing
(generic-flatten
(make-frs
(frs-value (frs-value frs))
(fr-merge-supports support1 support2))))))
(guard rtd:frs (lambda (thing) (frs? (frs-value thing)))))
(define (merge-frs frs1 frs2)
(let ((support1 (frs-support frs1))
(support2 (frs-support frs2)))
(cond ((and (fr-support-invalidates? support1 support2)
(fr-support-invalidates? support2 support1))
(make-stale-frs
(frs-value frs1)
(fr-max-supports support1 support2)))
((fr-support-invalidates? support1 support2)
frs1)
((fr-support-invalidates? support2 support1)
frs2)
;; These two are more policy decisions
((fr-more-recent? support1 support2)
frs1)
((fr-more-recent? support2 support1)
frs2)
(else
(let* ((frs1-value (frs-value frs1))
(frs2-value (frs-value frs2))
(value-merge (merge frs1-value frs2-value)))
(cond ((eq? value-merge frs1-value)
(if (implies? frs2-value value-merge)
;; Confirmation of existing information
#;
(if (more-informative-support? frs2 frs1)
frs2
frs1)
frs1
;; New information is not interesting
frs1))
((eq? value-merge frs2-value)
;; New information overrides old information
frs2)
(else
;; Interesting merge, need both provenances
(make-frs value-merge
(fr-merge-supports support1 support2)))))))))
(defhandler merge merge-frs frs? frs?)
propagator/extensions/test-utils.scm 0000664 0012467 0012467 00000007335 11503765530 016441 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define (fail-all cells)
(process-one-contradiction
(apply append (map v&s-support (filter v&s? (map tms-query (filter tms? (map content cells))))))))
(define (for-each-consistent-state proc cells)
(set! cells (listify cells))
(let loop ((last-run-result (run)))
(if (eq? 'done last-run-result)
(begin
(proc)
(fail-all cells)
(loop (run))))))
(define map-consistent-states (walker->mapper for-each-consistent-state))
(define-method generic-match ((pattern ) (object rtd:symbolic-metadata))
(generic-match
pattern (vector 'metadata (symbolic-variable-order object)
(symbolic-substitutions object)
(symbolic-residual-equations object))))
(define-method generic-match ((pattern ) (object rtd:symbolic))
(generic-match
pattern (vector 'symbolic (symbolic-expression object)
(symbolic-metadata object))))
(define-method generic-match ((pattern ) (object rtd:symb-ineq))
(generic-match
pattern (vector 'symb-ineq (symb-ineq-expression object)
(symb-ineq-local object)
(symb-ineq-global object))))
(define-method generic-match ((pattern ) (object rtd:inequality))
(generic-match pattern `(,@(inequality->list object) ,(inequality-variables object))))
(define-method generic-match ((pattern rtd:inequality) (object rtd:inequality))
(generic-match (inequality->list pattern) (inequality->list object)))
(define-method generic-match ((pattern ) (object rtd:frs))
(if (stale-frs? object)
(generic-match
pattern (vector 'stale-frs (frs-value object)
(frs-support object)))
(generic-match
pattern (vector 'frs (frs-value object)
(frs-support object)))))
(define-method generic-match ((pattern ) (object rtd:frpremise))
(generic-match
pattern (vector 'frp (frpremise-identity object)
(frpremise-timestamp object))))
#|
;;; Trying to abstract the above.
(define (record-type-summarizer record-type-descriptor)
(lambda (object)
(list->vector
(cons (symbol (record-type-name record-type-descriptor))
(map (lambda (field-name)
((record-accessor record-type-descriptor field-name)
object))
(record-type-field-names record-type-descriptor))))))
(define (declare-match-vector-patterns record-type-descriptor)
(add-method generic-match
(make-method (list record-type-descriptor)
(lambda (pattern object)
(generic-match
pattern
((record-type-summarizer record-type-descriptor)
object))))))
(declare-match-vector-patterns rtd:symbolic-metadata)
(declare-match-vector-patterns rtd:symbolic)
(declare-match-vector-patterns rtd:symb-ineq)
(declare-match-vector-patterns rtd:frpremise)
|#
propagator/extensions/mechanics 0000775 0012467 0012467 00000003707 11424076514 015476 0 ustar gjs gjs #!/usr/bin/env ruby
### ----------------------------------------------------------------------
### Copyright 2009-2010 Alexey Radul.
### ----------------------------------------------------------------------
### This file is part of Propagator Network Prototype.
###
### Propagator Network Prototype is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation, either version 3 of the License, or
### (at your option) any later version.
###
### Propagator Network Prototype is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with Propagator Network Prototype. If not, see .
### ----------------------------------------------------------------------
# -*- ruby-mode -*-
def root
ENV["SCMUTILS_ROOT"] || "/usr/local/scmutils"
end
def scheme
scheme = "#{root}/mit-scheme/bin/scheme"
end
def try_by_executable
fixed_opts = ["--library",
"#{root}/mit-scheme/lib",
"--heap",
"6000",
"--band",
"edwin-mechanics.com"
]
if File.executable?(scheme)
exec scheme, *(fixed_opts + ARGV)
end
end
def mechanics_band
"/scmutils/linux/edwin-mechanics.com"
end
def mechanics_band64
"/scmutils/scheme-x86-64/edwin-mechanics.com"
end
def try_by_band(band)
fixed_opts = ["-constant",
"2000",
"-heap",
"10000",
"-band",
band
]
if File.exist?(band)
exec "mit-scheme", *(fixed_opts + ARGV)
end
end
try_by_executable
try_by_band("/sw" + mechanics_band)
try_by_band("/usr/local"+ mechanics_band)
try_by_band("/usr/local"+ mechanics_band64)
puts "No Scheme at #{scheme} and no Mechanics bands at {/sw|/usr/local}#{mechanics_band} :("
propagator/extensions/draw.scm 0000664 0012467 0012467 00000022617 11556301155 015256 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Taylor Campbell and Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;;; Code to visualize propagator networks as graphs.
;;; Uses:
;;;
;;; (draw:show-graph)
;;; Dumps the whole current network in dot format, runs the dot
;;; graph layout engine over it, and displays the resulting svg file
;;; with eog. Errors out if dot or eog are not available.
;;;
;;; (draw:show-graph )
;;; As above, but shows the portion of the network identified by
;;; . If is a cell or a propagator, draws the
;;; connected component containing that cell or propagator. If
;;; is a network group, draws the elements that are part of
;;; that network group.
;;;
;;; (draw:show-graph )
;;; As above, but uses the specified drawing program (indicated as a
;;; string) instead of dot. As of the present writing, the graphviz
;;; system ships with the programs dot, neato, twopi, circo, and
;;; fdp, which embody different graph layout algorithms.
;;;
;;; (draw:draw-graph-to-file )
;;; (draw:draw-graph-to-file )
;;; (draw:draw-graph-to-file )
;;; Saves the graph layout output in the given , but does
;;; not display it. Same treatment of as above.
;;;
;;; (draw:write-graph)
;;; (draw:write-graph )
;;; (draw:write-graph )
;;; (draw:write-graph-to-file )
;;; (draw:write-graph-to-file )
;;; (draw:write-graph-to-string)
;;; (draw:write-graph-to-string )
;;; Writes the graph to the specified output location (either the
;;; standard output, or the given port, or the given file, or a
;;; fresh string it then returns). Does not process the output with
;;; any external programs.
;;;
;;; The behavior of the above can be modulated by fluid-letting
;;; several variables:
;;;
;;; draw:cell-label
;;; A procedure that accepts a cell and emits a structure that will
;;; be passed through write-to-string to generate the label that
;;; cell should have in the output. Defaults to the procedure name.
;;;
;;; draw:propagator-label
;;; A procedure that accepts a propagator and emits a structure that
;;; will be passed through write-to-string to generate the label
;;; that cell should have in the output. Defaults to name.
;;;
;;; draw:format
;;; A symbol that specifies the output format. Currently supported
;;; formats are:
;;; dot, for the graphviz suite (this is the default)
;;; graphml, for yEd
;;;
;;; For example,
#;
(fluid-let ((draw:cell-label
(lambda (var) (cons (name var) (content var)))))
(draw:show-graph))
;;; will display the network, laid out with dot, but including the
;;; contents of all cells in addition to their names.
;;;
#;
(fluid-let ((draw:format 'graphml))
(draw:write-graph-to-file "frob.graphml"))
;;; will write the graph structure of the whole propagator network to
;;; the file "frob.graphml" in graphml format, which can then be
;;; viewed with yEd (if that program is available).
;;; TODOs:
;;; Write a handful of useful procedures to fluid bind draw:cell-label to
;;; Dump port data (this compound box takes these inputs and then
;;; routes them to these sub-boxes)
;;; Dump subgroup data for closures ??
;;; - Implement (draw:show-graph some-closure)
;;; Dump animations of the progress of values over time
;;; - ddb searches; recursions
;;; Draw pictures of all the interesting propagator networks.
;;; Explore various graph drawing engines: graphviz, JGraph, others.
;;; http://www2.research.att.com/~volinsky/Graphs/slides/north.pdf
(define (draw:show-graph #!optional start drawing-program)
(call-with-temporary-file-pathname
(lambda (svg-pathname)
(draw:draw-graph-to-file svg-pathname start drawing-program)
;; TODO There is, in principle, support for asynchronous
;; subprocesses, but it is "available for those who are willing
;; to read the source code." More on this in an email exchange
;; with Taylor titled "Happy New Year, and a Question"
(force-run-shell-command
(string-append "eog " (->namestring svg-pathname))))))
(define (draw:draw-graph-to-file pathname #!optional start drawer)
(if (default-object? drawer)
(set! drawer "dot"))
(call-with-temporary-file-pathname
(lambda (graph-pathname)
(draw:write-graph-to-file graph-pathname start)
(force-run-shell-command
(string-append
drawer " " (->namestring graph-pathname)
" -Tsvg -o " (->namestring pathname))))))
(define (force-run-shell-command command)
(let ((status (run-shell-command command)))
(if (= 0 status)
'ok
(error "Shell command failed" command))))
(define (draw:write-graph-to-file pathname #!optional start)
(call-with-output-file pathname
(lambda (output-port)
(draw:write-graph start output-port))))
(define (draw:write-graph-to-string #!optional start)
(call-with-output-string
(lambda (output-port)
(draw:write-graph start output-port))))
(define (draw:write-graph #!optional start output-port)
(if (default-object? output-port)
(set! output-port (current-output-port)))
(let ((writer (draw:make-writer output-port)))
((writer 'write-graph)
(lambda ()
(draw:walk-graph writer start)))))
(define draw:format 'dot)
(define (draw:make-writer output-port)
((case draw:format
((dot) make-dot-writer)
((graphml) make-graphml-writer)
(else (error "Unsupported drawing format" draw:format)))
output-port))
(define (draw:walk-graph writer #!optional start)
(let ((traversed (make-eq-hash-table))
(defer-edges? #f)
(deferred-edges '()))
;; TODO Handle circumstances when the same diagram is a part of
;; several clubs.
(define write-node (writer 'write-node))
(define (write-edge source target label)
(define (edge-writer)
((writer 'write-edge) source target label))
(if defer-edges?
(set! deferred-edges (cons edge-writer deferred-edges))
(edge-writer)))
(define (write-input-edge input name index)
(write-edge input name index))
(define (write-output-edge output name index)
(write-edge name output index))
(define (write-edges diagram accessor write-edge)
(let ((name (draw:node-id diagram))
(number-edges? (< 1 (length (accessor diagram)))))
(let loop ((cells (accessor diagram)) (index 0))
(if (pair? cells)
(let ((cell (car cells)))
(write-edge (draw:node-id cell) name (if number-edges? index ""))
(loop (cdr cells) (+ index 1)))))))
(define (write-apex diagram)
(write-node diagram)
(write-edges diagram diagram-inputs write-input-edge)
(write-edges diagram diagram-outputs write-output-edge))
;; TODO Implement levels of detail in the graph drawing. An
;; unexpanded compound should have good arrows to its external
;; parts.
(define (traverse-group group)
(fluid-let ((defer-edges? #t))
((writer 'write-cluster) (hash group) (name group)
(lambda ()
(for-each traverse (diagram-expression-substructure group)))))
(if (not defer-edges?)
(dump-deferred-edges)))
(define (traverse thing)
(if (hash-table/get traversed thing #f)
'ok
(begin
(hash-table/put! traversed thing #t)
(cond ((cell? thing)
(write-node thing))
((primitive-diagram? thing)
(write-apex thing))
((diagram? thing)
(traverse-group thing))
(else
'ok)))))
(define (dump-deferred-edges)
(for-each (lambda (edge-writer) (edge-writer))
(reverse deferred-edges))
(set! deferred-edges '()))
(define (dispatch start)
(cond ((default-object? start) (traverse-group *toplevel-diagram*))
((diagram? start) (traverse start))
((pair? start) (for-each dispatch start))
(else
(error "Unknown entry point" start))))
(dispatch start)))
(define (draw:node-id node)
(define (node-type-string node)
(cond ((cell? node) "cell-")
((diagram? node) "prop-")
(else
(error "Unknown node type" node))))
(string-append (node-type-string node) (write-to-string (hash node))))
(define (draw:node-label node)
(write-to-string
(cond ((cell? node) (draw:cell-label node))
((diagram? node) (draw:diagram-label node))
(else
(error "Unnameable node type" node)))))
(define draw:indentation-level 0)
(define (draw:indented thunk)
(fluid-let ((draw:indentation-level
(+ draw:indentation-level 1)))
(thunk)))
(define draw:diagram-label name)
(define draw:cell-label name)
propagator/extensions/info-alist.scm 0000664 0012467 0012467 00000004015 11421421707 016353 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define (information-assq key alist)
(let ((binding (assq key alist)))
(if binding
(cdr binding)
nothing)))
(define (same-alist? alist1 alist2)
(lset= (lambda (pair1 pair2)
(and (eq? (car pair1) (car pair2))
(equivalent? (cdr pair1) (cdr pair2))))
alist1 alist2))
(define (unary-alist-unpacking f)
(lambda (alist)
(map (lambda (binding)
(cons (car binding) (f (cdr binding))))
alist)))
(define (binary-alist-unpacking f)
(lambda (alist1 alist2)
(let ((keys (lset-union eq? (map car alist1) (map car alist2))))
(define get information-assq)
(map (lambda (key)
(cons key (f (get key alist1) (get key alist2))))
keys))))
(define %merge-alist (binary-alist-unpacking merge))
(define (merge-alist alist1 alist2)
(let ((putative-answer (%merge-alist alist1 alist2)))
(effectful-list-bind (map cdr putative-answer)
(lambda (cdrs)
(map cons
(map car putative-answer)
cdrs)))))
propagator/extensions/inequalities.scm 0000664 0012467 0012467 00000032715 11503765530 017020 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;; Strategy:
;;;
;;; Use equations to solve for variables
;;;
;;; Substitute into the inequalities thoroughly
;;;
;;; When the time comes, check the inequalities for consistency by
;;; looking for ones where a variable appears alone
;;; solving for that variable
;;; isolating the strongest inequality in that variable in each direction
;;; (the rest can be discarded as redundant)
;;; checking whether the resulting interval is empty
(declare (usual-integrations))
(define (symbolic-variable? thing)
(and (symbol? thing)
(not (memq thing '(+ - / * D expt sqrt exp sin cos < > <= >=)))))
(define (find-variables expr)
(define (tree-fringe tree)
(let walk ((tree tree)
(answer '()))
(cond ((pair? tree)
(walk (car tree) (walk (cdr tree) answer)))
((null? tree) answer)
(else
(cons tree answer)))))
(delete-duplicates (filter symbolic-variable? (tree-fringe expr))))
(define-structure (inequality (constructor %%make-inequality) safe-accessors)
direction
expr1
expr2
variables)
(define (inequality->list ineq)
`(,(inequality-direction ineq)
,(inequality-expr1 ineq)
,(inequality-expr2 ineq)))
(define (list->inequality lst)
(if (inequality? lst)
lst
(if (and (pair? lst)
(= 3 (length lst))
(memq (car lst) '(< > <= >=)))
(%make-inequality (car lst) (cadr lst) (caddr lst))
(error "Given object does not look like an inequality" lst))))
(define (%make-inequality dir expr1 expr2)
(if (not (memq dir '(< <= > >=)))
(error "Unsupported direction" dir))
(let ((expr1 (simplify expr1))
(expr2 (simplify expr2)))
(%%make-inequality dir expr1 expr2 (find-variables (cons expr1 expr2)))))
(define (make-inequality dir expr)
(%make-inequality dir expr 0))
(define (make-solved-inequality dir var answer)
(if (or (not (symbolic-variable? var)) (not (number? answer)))
(error "Incomplete solution" dir var answer))
(%make-inequality dir var answer))
(define (inequality-expression ineq)
(if (and (number? (inequality-expr2 ineq))
(= 0 (inequality-expr2 ineq)))
(inequality-expr1 ineq)
(simplify
(symb:- (inequality-expr1 ineq)
(inequality-expr2 ineq)))))
(define (the-ineq-variable ineq)
(if (= 1 (length (inequality-variables ineq)))
(car (inequality-variables ineq))
(error "No unique variable in" ineq)))
(define (normalized-ineq? ineq)
(number? (inequality-expr2 ineq)))
(define (normalize-ineq ineq)
(if (normalized-ineq? ineq)
ineq
(make-inequality
(inequality-direction ineq)
(inequality-expression ineq))))
(define (solved-ineq? ineq)
(and (symbolic-variable? (inequality-expr1 ineq))
(number? (inequality-expr2 ineq))))
(define (determined-ineq? ineq)
(= 0 (length (inequality-variables ineq))))
(define (evaluate-ineq ineq)
(if (not (determined-ineq? ineq))
(error "Cannot evaluate undetermined inequality" ineq))
(eval
(list (inequality-direction ineq)
(inequality-expr1 ineq)
(inequality-expr2 ineq))
(nearest-repl/environment)))
(define (tautological-ineq? ineq)
(and (determined-ineq? ineq)
(evaluate-ineq ineq)))
(define (contradictory-ineq? ineq)
(and (determined-ineq? ineq)
(not (evaluate-ineq ineq))))
(define (make-tautological-ineq)
(make-inequality '<= 0))
(define (make-contradictory-ineq)
(make-inequality '< 0))
;;; This is the main interface to the inequality solver. Given a list
;;; of inequalities, it either returns a simplified list of
;;; inequalities, of #f if the inequalities are inconsistent.
(define (solve-inequalities inequalities)
(let ((answer (simplify-inequalities (map list->inequality inequalities))))
(and answer (map inequality->list answer))))
(define (simplify-inequalities inequalities)
(let loop ((inequalities (map simplify-ineq inequalities))
(solved '())
(unsolved '()))
(if (null? inequalities)
(consistent-subset (append unsolved solved))
(try-inequality
(car inequalities)
(lambda (deduction)
(cond ((tautological-ineq? deduction)
(loop (cdr inequalities) solved unsolved))
((contradictory-ineq? deduction)
#f)
((solved-ineq? deduction)
(loop (cdr inequalities)
(cons deduction solved)
unsolved))
(else
(loop (cdr inequalities)
solved
(cons deduction unsolved)))))
(lambda ()
(loop (cdr inequalities)
solved
(cons (car inequalities) unsolved)))))))
(define (consistent-subset inequalities)
(let ((inequalities (map normalize-ineq inequalities)))
(let loop ((expressions
(delete-duplicates
(map inequality-expr1 inequalities)))
(answer '()))
(if (null? expressions)
answer
(let ((one-expr-consistent
(consistent-subset-one-expr
(filter (lambda (ineq)
(equal? (car expressions)
(inequality-expr1 ineq)))
inequalities))))
(and one-expr-consistent
(loop (cdr expressions)
(append one-expr-consistent answer))))))))
(define (minimum lst <)
(if (null? lst)
#f
(let loop ((min (car lst))
(rest (cdr lst)))
(if (null? rest)
min
(if (< min (car rest))
(loop min (cdr rest))
(loop (car rest) (cdr rest)))))))
(define (upper-bound-ineq? ineq)
(memq (inequality-direction ineq) '(< <=)))
(define (lower-bound-ineq? ineq)
(memq (inequality-direction ineq) '(> >=)))
(define (stricter-upper-bound? ineq1 ineq2)
(and (equal? (inequality-expr1 ineq1)
(inequality-expr1 ineq2))
(or (< (inequality-expr2 ineq1)
(inequality-expr2 ineq2))
(and (= (inequality-expr2 ineq1)
(inequality-expr2 ineq2))
(or (eq? '< (inequality-direction ineq1))
(and (eq? '<= (inequality-direction ineq1))
(eq? '<= (inequality-direction ineq2))))))))
(define (stricter-lower-bound? ineq1 ineq2)
(and (equal? (inequality-expr1 ineq1)
(inequality-expr1 ineq2))
(or (> (inequality-expr2 ineq1)
(inequality-expr2 ineq2))
(and (= (inequality-expr2 ineq1)
(inequality-expr2 ineq2))
(or (eq? '> (inequality-direction ineq1))
(and (eq? '>= (inequality-direction ineq1))
(eq? '>= (inequality-direction ineq2))))))))
(define (consistent-subset-one-expr inequalities)
(let ((best-upper-bound
(minimum (filter upper-bound-ineq? inequalities)
stricter-upper-bound?))
(best-lower-bound
(minimum (filter lower-bound-ineq? inequalities)
stricter-lower-bound?)))
(cond ((and best-upper-bound best-lower-bound)
(let ((consistent?
(evaluate-ineq
(transitive-ineq best-lower-bound best-upper-bound))))
(if consistent?
(list best-lower-bound best-upper-bound)
#f)))
(best-upper-bound (list best-upper-bound))
(best-lower-bound (list best-lower-bound))
(else '()))))
(define (transitive-ineq lower-bound upper-bound)
(cond ((not (lower-bound-ineq? lower-bound))
(error "Not a lower bound" lower-bound))
((not (upper-bound-ineq? upper-bound))
(error "Not an upper bound" upper-bound))
((not (equal? (inequality-expr1 lower-bound)
(inequality-expr1 upper-bound)))
(error "Inappropriate attempt at transitivity" lower-bound upper-bound))
(else
(make-inequality (joint-operation (inequality-direction lower-bound)
(inequality-direction upper-bound))
(simplify
(symb:- (inequality-expr2 lower-bound)
(inequality-expr2 upper-bound)))))))
(define (joint-operation lower-dir upper-dir)
(if (and (eq? '>= lower-dir) (eq? '<= upper-dir))
'<=
'<))
(define (try-inequality ineq succeed fail)
(if (or (solved-ineq? ineq)
(tautological-ineq? ineq)
(contradictory-ineq? ineq))
(succeed ineq)
(if (> (length (inequality-variables ineq)) 1)
(fail)
(try-ineq-expression
(the-ineq-variable ineq)
(inequality-direction ineq)
(inequality-expression ineq)
succeed fail))))
(define (try-ineq-expression var dir expr succeed fail)
(cond ((equal? var expr)
(succeed (make-solved-inequality dir var 0)))
((expt? expr)
(numerify
(cadr (operands expr))
(lambda (num)
(try-power var dir expr succeed fail))
fail))
((product? expr)
(try-product var dir expr succeed fail))
((sum? expr)
(try-sum var dir expr succeed fail))
(else
(fail))))
(define (expr-exponent expr)
(if (expt? expr)
(cadr (operands expr))
1))
(define (numerify possibly-symbolic-number succeed fail)
(let ((answer (simplify possibly-symbolic-number)))
(if (number? answer)
(succeed answer)
(fail))))
(define (try-power var dir expr succeed fail)
(if (even? (cadr (operands expr)))
(case dir
((<) (succeed (make-contradictory-ineq)))
;; TODO (= expr 0)
((<=) (succeed (make-contradictory-ineq)))
((>=) (succeed (make-tautological-ineq)))
;; TODO (<> expr 0)
((>) (succeed (make-tautological-ineq)))
(else
(error "Invalid direction" dir)))
(try-ineq-expression var dir (car (operands expr)) succeed fail)))
(define (reverse-sense dir)
(case dir
((<) '>)
((<=) '>=)
((>=) '<=)
((>) '<)
(else
(error "Invalid direction" dir))))
(define (negate-sense dir)
(case dir
((<) '>=)
((<=) '>)
((>=) '<)
((>) '<=)
(else
(error "Invalid direction" dir))))
(define (try-product var dir expr succeed fail)
(let loop ((factors (operands expr))
(powers-of-var '())
(constants '()))
(cond ((null? factors)
(numerify
(symb:add:n (map expr-exponent powers-of-var))
(lambda (power)
(numerify
(symb:mul:n constants)
(lambda (factor)
(cond ((= factor 0)
(succeed (make-inequality dir 0)))
((> factor 0)
(try-power var dir
`(expt ,var ,power) succeed fail))
((< factor 0)
(try-power var (reverse-sense dir)
`(expt ,var ,power) succeed fail))))
fail))
fail))
((occurs? var (car factors))
(if (or (equal? var (car factors))
(and (expt? (car factors))
(equal var (car (operands factors)))))
(loop (cdr factors)
(cons (car factors) powers-of-var)
constants)
;; Otherwise the presence of var is too complicated
(fail)))
(else
(loop (cdr factors)
powers-of-var
(cons (car factors) constants))))))
(define (try-sum var dir expr succeed fail)
(let loop ((addends (operands expr))
(coefficients-of-var '())
(constants '()))
(cond ((null? addends)
(numerify
(symb:add:n coefficients-of-var)
(lambda (coeff)
(numerify
(symb:add:n constants)
(lambda (constant)
(cond ((= coeff 0)
(succeed (make-inequality dir constant)))
((> coeff 0)
(succeed
(make-solved-inequality
dir var (/ (- constant) coeff))))
((< coeff 0)
(succeed
(make-solved-inequality
(reverse-sense dir) var (/ (- constant) coeff))))))
fail))
fail))
((occurs? var (car addends))
(cond ((equal? var (car addends))
(loop (cdr addends)
(cons 1 coefficients-of-var)
constants))
((product? (car addends))
(let ((factors (operands (car addends))))
(if (member var factors)
(loop (cdr addends)
(cons (symb:mul:n (delete var factors))
coefficients-of-var)
constants)
;; Otherwise the presence of var is too complicated
(fail))))
(else (fail))))
(else
(loop (cdr addends)
coefficients-of-var
(cons (car addends) constants))))))
(define (simplify-ineq ineq)
(define (try-power dir expr num loop done)
(numerify
(cadr (operands expr))
(lambda (power)
(if (even? power)
;; Even powers are not monotonic
(done)
(loop dir (car (operands expr)) (expt num (/ 1 power)))))
done))
(define (try-product dir expr num loop done)
(let ((numbers (filter number? expr)))
(if (null? numbers)
(done)
(let ((coeff (apply * numbers)))
;; Assume coeff = 0 would have simplifed already
(loop (if (> coeff 0) dir (reverse-sense dir))
(simplify (symb:/ expr coeff))
(/ num coeff))))))
(define (try-sum dir expr num loop done)
(let ((numbers (filter number? expr)))
(if (null? numbers)
(done)
(let ((addend (apply + numbers)))
(loop dir
(simplify (symb:- expr addend))
(- num addend))))))
(let ((ineq (normalize-ineq ineq)))
(if (determined-ineq? ineq)
ineq
(let loop ((dir (inequality-direction ineq))
(expr (inequality-expr1 ineq))
(num (inequality-expr2 ineq)))
(define (done)
(%make-inequality dir expr num))
(cond ((expt? expr)
(try-power dir expr num loop done))
((product? expr)
(try-product dir expr num loop done))
((sum? expr)
(try-sum dir expr num loop done))
(else (done)))))))
propagator/extensions/graphml-writer.scm 0000664 0012467 0012467 00000012600 11421421707 017251 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(define (make-graphml-writer output-port)
(define (write-graph write-contents)
(write-xml-header
(lambda ()
(write-graph-header)
(write-tag "graph" `((edgedefault . "directed")
(id . "G"))
write-contents))))
(define (write-xml-header write-contents)
(write-string "" output-port)
(write-tag
"graphml"
`((xmlns . "http://graphml.graphdrawing.org/xmlns")
(xmlns:xsi . "http://www.w3.org/2001/XMLSchema-instance")
(xmlns:y . "http://www.yworks.com/xml/graphml")
("xsi:schemaLocation" . "http://graphml.graphdrawing.org/xmlns http://www.yworks.com/xml/schema/graphml/1.1/ygraphml.xsd"))
write-contents)
(newline output-port))
(define (write-graph-header)
(write-tag "key" '((for . "node") (id . "d3") (yfiles.type . "nodegraphics")))
(write-tag "key" '((for . "edge") (id . "d6") (yfiles.type . "edgegraphics"))))
(define (write-tag tag attributes #!optional write-contents)
(newline output-port)
(write-indentation)
(write-string "<" output-port)
(write-string tag output-port)
(for-each (lambda (pair)
(write-string " " output-port)
(if (string? (car pair))
(write-string (car pair) output-port)
(write (car pair) output-port))
(write-string "=" output-port)
(write-string "\"" output-port)
(write-string (cdr pair) output-port)
(write-string "\"" output-port))
attributes)
(if (default-object? write-contents)
(write-string "/>" output-port)
(begin (write-string ">" output-port)
(draw:indented write-contents)
(write-string "" output-port)
(write-string tag output-port)
(write-string ">" output-port))))
(define (write-data string)
(write-string (xml-escape string) output-port))
(define (xml-escape string)
;; Yes, I know this is horribly inadequate and wrong, but it's
;; good enough for now.
(string-replace string "<" "<"))
(define (write-node node)
(write-tag
"node" `((id . ,(draw:node-id node)))
(lambda ()
(write-tag
"data" '((key . "d3"))
(lambda ()
;; Could also do y:GenericNode configuration="ShinyPlateNode2" for propagators
(write-tag
"y:ShapeNode" '()
(lambda ()
(write-tag
"y:NodeLabel" '()
(lambda ()
(write-data (draw:node-label node))))
(write-tag
"y:Shape" `((type . ,(compute-node-shape node)))))))))))
(define (compute-node-shape node)
(cond ((cell? node) "ellipse")
((propagator? node) "roundrectangle")
(else
(error "Unknown node type" node))))
(define (write-edge source-name target-name label)
;; TODO Edge labels
(write-tag "edge" `((source . ,source-name)
(target . ,target-name))
(lambda ()
(write-tag "data" '((key . "d6"))
(lambda ()
(write-tag "y:PolyLineEdge" '()
(lambda ()
(write-tag "y:Arrows" '((source . "none")
(target . "standard"))))))))))
(define (write-cluster id label write-contents)
(write-tag "node" `((id . ,(string-append "cluster-" (write-to-string id)))
(yfiles.foldertype . "folder"))
(lambda ()
(write-tag "data" `((key . "d3"))
(lambda ()
(write-tag "y:ProxyAutoBoundsNode" '()
(lambda ()
(write-tag "y:Realizers" '((active . "1"))
(lambda ()
(write-tag "y:GroupNode" '()
(lambda ()
(write-tag "y:NodeLabel" '(("modelName" . "internal")
("modelPosition" . "tl"))
(lambda ()
;; Hack to avoid the open-close icon
(write-string " " output-port)
(write label output-port)))))
(write-tag "y:GroupNode" '()
(lambda ()
(write-tag "y:NodeLabel" '(("modelName" . "internal")
("modelPosition" . "tl"))
(lambda ()
;; Hack to avoid the open-close icon
(write-string " " output-port)
(write label output-port)))))))))))
(write-tag
"graph" `((edgedefault . "directed")
(id . ,(string-append "subgraph-" (write-to-string id))))
write-contents))))
(define (write-indentation)
(repeat draw:indentation-level
(lambda ()
(write-string " " output-port))))
(define (me message)
(cond ((eq? 'write-graph message) write-graph)
((eq? 'write-node message) write-node)
((eq? 'write-edge message) write-edge)
((eq? 'write-cluster message) write-cluster)
(else
(error "Unknown message" message))))
me)
propagator/extensions/example-closures.scm 0000664 0012467 0012467 00000006171 11421421707 017603 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define fact-cl
(let-cells (in-n in-n!
zero control not-control one n-again n-1 n-1! empty)
(define fact-cl
(make-v-closure
(list in-n in-n!)
(list zero control not-control one n-again n-1 n-1! empty)
'())) ; No global environment yet
((vc:const 0) zero)
((vc:const 1) one)
(vc:=? in-n zero control)
(vc:inverter control not-control)
(vc:switch control one in-n!)
(vc:switch not-control in-n n-again)
(vc:subtractor n-again one n-1)
(static-call-site fact-cl (list n-1 n-1!))
(vc:multiplier n-1! in-n in-n!)
fact-cl))
(define fib-cl
(let-cells (in-n fib-n one two recur not-recur
n-again n-1 n-2 fib-n-1 fib-n-2)
(define fib-cl
(make-v-closure
(list in-n fib-n)
(list one two recur not-recur n-again n-1 n-2 fib-n-1 fib-n-2)
'()))
((vc:const 1) one)
((vc:const 2) two)
(vc: in-n two not-recur)
(vc:inverter not-recur recur)
(vc:switch not-recur one fib-n)
(vc:switch recur in-n n-again)
(vc:subtractor n-again one n-1)
(static-call-site fib-cl (list n-1 fib-n-1))
(vc:subtractor n-again two n-2)
(static-call-site fib-cl (list n-2 fib-n-2))
(vc:adder fib-n-1 fib-n-2 fib-n)
fib-cl))
(define quot-rem-cl
(let-cells (dividend divisor quot rem)
(vc:quotient dividend divisor quot)
(vc:remainder dividend divisor rem)
(make-v-closure (list dividend divisor quot rem) '() '())))
(define euclid-cl
(let-cells (a b gcd zero recur not-recur
a-again b-again a-mod-b a-quot-b gcd-again)
(define euclid-cl
(make-v-closure
(list a b gcd)
(list zero recur not-recur a-again b-again a-mod-b a-quot-b gcd-again)
'()))
((vc:const 0) zero)
(vc:=? b zero not-recur)
(vc:inverter not-recur recur)
(vc:switch not-recur a gcd)
(vc:switch recur a a-again)
(vc:switch recur b b-again)
(static-call-site quot-rem-cl (list a-again b-again a-quot-b a-mod-b))
(static-call-site euclid-cl (list b-again a-mod-b gcd-again))
(vc:switch recur gcd-again gcd)
euclid-cl))
propagator/extensions/virtual-environments.scm 0000664 0012467 0012467 00000023443 11421421707 020527 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;;; Fully-virtual environments. See environments.tex.
(declare (usual-integrations make-cell cell?))
;;;; Frames
;;; A frame tag is a record with an identity and a parent list. The
;;; notion is that the information in a cell at a frame is the stuff
;;; computed directly in that frame, or anywhere up the chain of
;;; ancestors. This is orthogonal to whether a frame can have
;;; multiple parents.
(define-structure
(frame (constructor %make-frame) (safe-accessors #t))
parents
strict-ancestors) ; Cache the ancestor computation
(define (%compute-ancestors frames)
(delete-duplicates (append-map frame-ancestors frames)))
(define (frame-ancestors frame)
(cons frame (frame-strict-ancestors frame)))
(define (make-frame parents)
(%make-frame parents (%compute-ancestors parents)))
;;;; Virtual Copy Sets
;;; A virtual copies set is a structure that associates frame tags
;;; (which for the nonce need only be assumed to be eq?-comparable)
;;; with information.
(define-structure
(virtual-copies (safe-accessors #t))
alist)
(declare-type-tester virtual-copies? rtd:virtual-copies)
(define alist->virtual-copies make-virtual-copies)
(define virtual-copies->alist virtual-copies-alist)
(define-method generic-match ((pattern ) (object rtd:virtual-copies))
(generic-match pattern (virtual-copies->alist object)))
(define (frame-binding copy-set frame)
;; TODO Of course, an alist is the worst possible data structure for
;; this purpose, but it's built-in and it's persistent.
(assq frame (virtual-copies-alist copy-set)))
(define (occurring-frames copy-set)
(map car (virtual-copies-alist copy-set)))
(define (occurring-frames* copy-sets)
(delete-duplicates (append-map occurring-frames copy-sets)))
(define (frame-occurs? copy-set frame)
(not (not (frame-binding copy-set frame))))
(define (direct-frame-content copy-set frame)
(let ((occurrence (frame-binding copy-set frame)))
(if occurrence
(cdr occurrence)
nothing)))
;;;; Frame & Copy-set Interactions
;;; The intention is that the full information content of a cell in a
;;; frame is the merge of all information available in that frame and
;;; all that frame's ancestors. I can implement that intention
;;; directly per below; or I can use one-cell cross-frame propagators
;;; to maintain the invariant that the direct content in every frame
;;; stabilizes to be the same as the intended full content; or I can
;;; hatch some scheme whereby that intention is maintained in some
;;; implicit manner but not represented explicitly. That's a choice.
(define (full-frame-content copy-set frame)
(fold merge nothing
(map (lambda (frame)
(direct-frame-content copy-set frame))
(frame-ancestors frame))))
(define (ancestral-occurrence-count copy-set frame)
(count (lambda (frame)
(frame-occurs? copy-set frame))
(frame-ancestors frame)))
;; See environments.tex for the meaning of "acceptable".
(define (acceptable-frame? frame copy-sets)
(apply boolean/and
(map (lambda (copy-set)
(<= 1 (ancestral-occurrence-count copy-set frame)))
copy-sets)))
;; See environments.tex for the meaning of "good".
(define (good-frame? frame copy-sets)
(and (acceptable-frame? frame copy-sets)
(not (apply boolean/or
(map (lambda (parent)
(acceptable-frame? parent copy-sets))
(frame-parents frame))))))
(define (good-frames copy-sets)
;; TODO I'm *certain* there's a more efficient way to do this
(filter (lambda (frame)
(good-frame? frame copy-sets))
(occurring-frames* copy-sets)))
(define (lexical-invariant? copy-set)
(apply boolean/and
(map (lambda (frame)
(<= (ancestral-occurrence-count copy-set frame) 1))
(occurring-frames copy-set))))
;; This operation, as named, depends on the lexical invariant above
;; holding good.
(define (the-occurring-parent frame copy-set)
(find (lambda (parent)
(frame-occurs? copy-set parent))
(frame-ancestors frame)))
;;;; Equating and merging virtual copy sets
(define (v-c-equal? copy-set1 copy-set2)
(let ((the-frames (occurring-frames copy-set1)))
(and (lset= eq? the-frames (occurring-frames copy-set2))
(apply boolean/and
(map (lambda (frame)
(equivalent? (full-frame-content copy-set1 frame)
(full-frame-content copy-set2 frame)))
the-frames)))))
;;; This merge is OK if "normal" propagators use v-c-i/o-unpacking
;;; (below) for their operations. Then they will respect the
;;; occurrence structure so the merge operation doesn't have to.
(define (virtual-copy-merge copy-set1 copy-set2)
(define (frame-by-frame f)
(lambda args
(alist->virtual-copies
(map (lambda (frame)
(cons frame (apply f (map (lambda (arg)
(full-frame-content arg frame))
args))))
(occurring-frames* args)))))
((frame-by-frame merge) copy-set1 copy-set2))
(defhandler merge virtual-copy-merge virtual-copies? virtual-copies?)
(defhandler equivalent? v-c-equal? virtual-copies? virtual-copies?)
(defhandler contradictory?
(lambda (vcs)
(any contradictory? (map cdr (virtual-copies->alist vcs))))
virtual-copies?)
;;;; Propagator Machinery
;;; Doing virtual copies via the generic-unpack mechanism presents
;;; three problems. First, imagine a binary operation with two
;;; virtual-copies arguments. A direct implementation of
;;; virtual-copy-bind would evaluate that operation on all
;;; quadratically many combinations of pairs of frames, and then do
;;; something to only keep the pieces we had wanted. That could get
;;; ugly. Second, the unpacking mechanism below actually needs to
;;; look at all the neighbor cells in order to decide which sets of
;;; frames to operate on. Third, if one goes through the standard
;;; unpack-flatten mechanism, then a binary operation working on a
;;; pair of virtual copies of TMSes of something will find itself
;;; trying to flatten a set of virtual copies of TMSes of virtual
;;; copies of TMSes of something. Doing that correctly requires a
;;; mechanism to turn a TMS of virtual copies of X into a virtual
;;; copies of a TMS of X; but under the current regime (i.e. without
;;; knowing what type the final result is supposed to be) the
;;; existence of that mechanism will force all TMSes of virtual copies
;;; to become virtual copies of TMSes. But what if I *want* to
;;; subject the frames to TMS premises in some region of the network?
;;; This is a very general problem. Are monad transformers such
;;; conversion mechanisms? Or do they prevent this issue from arising
;;; by some other means? (Or are they completely unrelated?) This
;;; whole mess is perhaps a function of not being able to look at what
;;; the client wants.
(define (v-c-i/o-unpacking f)
(lambda args
(let ((output (car (last-pair args)))
(inputs (except-last-pair args)))
(alist->virtual-copies
(map (lambda (frame)
(cons (the-occurring-parent frame output)
(apply f (map (lambda (copy-set)
(full-frame-content copy-set frame))
inputs))))
(good-frames args))))))
(define (i/o-function->propagator-constructor f)
(lambda cells
(let ((output (car (last-pair cells))))
(propagator cells
(lambda ()
(add-content output (apply f (map content cells))))))))
;; Now the version with the metadata
(define (i/o-function->propagator-constructor f)
(lambda cells
(let ((output (car (last-pair cells))))
(propagator cells
(eq-label!
(lambda ()
(add-content output (apply f (map content cells))))
;; TODO Currently ok, because the last "input" is only used
;; for virtualization
'inputs (except-last-pair cells)
'name f
'outputs (list output))))))
(define (doit f)
(i/o-function->propagator-constructor
(eq-put!
(lambda args
;; TODO Generalize this to other information types
(if (any nothing? args)
nothing
(apply (v-c-i/o-unpacking (nary-unpacking f)) args)))
'name f)))
;;;; Propagators
(define vc:adder (doit generic-+))
(define vc:subtractor (doit generic--))
(define vc:multiplier (doit generic-*))
(define vc:divider (doit generic-/))
(define vc:absolute-value (doit generic-abs))
(define vc:squarer (doit generic-square))
(define vc:sqrter (doit generic-sqrt))
(define vc:=? (doit generic-=))
(define vc: (doit generic-<))
(define vc:>? (doit generic->))
(define vc:<=? (doit generic-<=))
(define vc:>=? (doit generic->=))
(define vc:inverter (doit generic-not))
(define vc:conjoiner (doit generic-and))
(define vc:disjoiner (doit generic-or))
(define (vc:const value)
(doit (eq-put! (lambda () value) 'name (list 'const value))))
(define vc:switch (doit switch-function))
(define generic-quotient (make-generic-operator 2 'quotient quotient))
(eq-put! generic-quotient 'name 'quotient)
(define vc:quotient (doit generic-quotient))
(define generic-remainder (make-generic-operator 2 'remainder remainder))
(eq-put! generic-remainder 'name 'remainder)
(define vc:remainder (doit generic-remainder))
propagator/extensions/virtual-closures.scm 0000664 0012467 0012467 00000036117 11421421707 017641 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;;; Closures for fully-virtual environments. See environments.scm
;;;; and environments.tex.
(declare (usual-integrations make-cell cell?))
;;;; Frame Maps
(define-structure
frame-map
alist
default-parents)
(declare-type-tester frame-map? rtd:frame-map)
(define (frame-map-bind frame-map key1 key2)
(make-frame-map
(cons (cons key1 key2)
(frame-map-alist frame-map))
(frame-map-default-parents frame-map)))
(define (frame-map-lookup frame-map key)
(assq key (frame-map-alist frame-map)))
(define (frame-map-get frame-map key)
(let ((binding (frame-map-lookup frame-map key)))
(if binding
(cdr binding)
(error "Key not found" key frame-map))))
(define (mapping-available? frame-map key)
(not (not (frame-map-lookup frame-map key))))
;;;; Equating and merging frame maps
(define (same-binding? bind1 bind2)
(and (eq? (car bind1) (car bind2))
(eq? (cdr bind1) (cdr bind2))))
(define (frame-map-merge map1 map2)
(define (repeated-elt? lst)
(not (lset= eq? lst (delete-duplicates lst))))
(define (merge-bindings alist1 alist2)
(let ((answer (lset-union same-binding? alist1 alist2)))
(if (repeated-elt? (map car answer))
(error "Same frame mapped to different targets" map1 map2)
answer)))
(make-frame-map
(merge-bindings (frame-map-alist map1) (frame-map-alist map2))
(delete-duplicates (append (frame-map-default-parents map1)
(frame-map-default-parents map2)))))
(define (f-m-equal? map1 map2)
(and (lset= same-binding?
(frame-map-alist map1) (frame-map-alist map2))
(lset= eq? (frame-map-default-parents map1)
(frame-map-default-parents map2))))
(defhandler merge frame-map-merge frame-map? frame-map?)
(defhandler equivalent? f-m-equal? frame-map? frame-map?)
;;;; Extending frame maps
(define (complete-frame-map copy-set frame-map)
(let loop ((frame-map frame-map)
(frames (occurring-frames copy-set)))
(if (null? frames)
frame-map
(ensure-mapping-available-for
frame-map (car frames)
(lambda (new-map) (loop new-map (cdr frames)))))))
(define (ensure-mapping-available-for frame-map key cont)
(define (doit frame-map)
(if (mapping-available? frame-map key)
(cont frame-map)
(cont (frame-map-bind
frame-map key (make-image-for frame-map key)))))
(let loop ((frame-map frame-map)
(parents (frame-parents key)))
(if (null? parents)
(doit frame-map)
(ensure-mapping-available-for
frame-map (car parents)
(lambda (new-map) (loop new-map (cdr parents)))))))
(define (make-image-for frame-map key)
(make-frame
(append
;; Do I really want the images of the parents of the current frame
;; to be parents of the image? What if those parents do not have
;; images? should I always create them? Are there frames that
;; should not get images in called abstractions? Or should not
;; always get fresh images?
;; Hm. It seems that it's ok to make lots of images, provided I
;; am careful not to generate occurrences in the callee that
;; do not correspond to occurrences that exist in the caller.
;; On the other hand, perfect consistency with the "extra identity
;; propagators" interpretation of physical copies would seem to
;; suggest that I only create one image, and copy down from
;; parents (and back up, in the case of outputs).
(map (lambda (parent)
(frame-map-get frame-map parent))
(frame-parents key))
;; If I could promise that all frames eventually topped out at
;; frames without incoming parents, then I could choose to attach
;; these only to such frames, instead of to all of them.
(frame-map-default-parents frame-map))))
(define (simple-ensure-mapping frame-map key #!optional parents)
(if (default-object? parents)
(set! parents (frame-map-default-parents frame-map)))
(if (mapping-available? frame-map key)
frame-map
(frame-map-bind frame-map key (make-frame parents))))
;;;; Call Sites
(define-structure
(v-closure (safe-accessors #t))
inside
interior
default-parents)
(declare-type-tester v-closure? rtd:v-closure)
;; This still requires the closure to be known statically.
(define (static-call-site v-closure outside-cells)
(let ((inside-cells (v-closure-inside v-closure))
(interior-cells (v-closure-interior v-closure)))
(if (not (= (length outside-cells)
(length inside-cells)))
(error "Differing boundary lengths" outside-cells inside-cells))
(let ((frame-map (make-frame-map '() (v-closure-default-parents v-closure)))
(frame-map-cell (make-named-cell 'frame-map)))
(add-content frame-map-cell frame-map)
(interior-copier frame-map-cell outside-cells interior-cells)
(map (lambda (outside-cell inside-cell)
;; It's not clear whether independent frame mappers are
;; the right thing. The "extra identity propagators"
;; interpretation of physical copies would, I think,
;; rather suggest that there be one map-keeper for the
;; entire outside, and it ensure that good frames in the
;; outside have images in the inside. On the other hand,
;; perhaps this is ok, because the interior copier is the
;; one that's actually responsible for creating those
;; occurrences on the inside of the abstraction
;; (including the boundary), and as long as it does the
;; right thing, extra bindings in the frame map don't
;; hurt anyone. But then, the inward transfer (and
;; outward transfer) would also need to be done on a
;; whole-boundary basis?
(map-keeper outside-cell frame-map-cell)
(inward-transferrer frame-map-cell inside-cell outside-cell)
(outward-transferrer frame-map-cell inside-cell outside-cell))
outside-cells
inside-cells))))
(define (map-keeper outside frame-map-cell)
(propagator outside
(eq-label!
(lambda ()
(add-content frame-map-cell
(complete-frame-map (content outside) (content frame-map-cell))))
'name 'map-keeper
'inputs (list outside)
'outputs (list frame-map-cell))))
(define (interior-copier frame-map-cell outside interior)
(propagator (cons frame-map-cell outside)
(eq-label!
(lambda ()
(let ((answer (needed-interior-copies (content frame-map-cell)
(map content outside))))
(for-each (lambda (cell)
(add-content cell answer))
interior)))
'name 'interior-copier
'inputs (cons frame-map-cell outside)
;; I'm scared to write the outputs of this one, because it hits
;; the whole interior (and only with virtualization information)
)))
(define (inward-transferrer frame-map-cell inside outside)
(propagator (list frame-map-cell outside)
(eq-label!
(lambda ()
(add-content inside
(transfer-inward (content frame-map-cell) (content outside))))
'name 'inward
'inputs (list frame-map-cell outside)
'outputs (list inside))))
(define (outward-transferrer frame-map-cell inside outside)
(propagator (list frame-map-cell inside outside)
(eq-label!
(lambda ()
(add-content outside
(transfer-outward
(content frame-map-cell) (content inside) (content outside))))
'name 'outward
'inputs (list frame-map-cell inside)
'outputs (list outside))))
;;;; Actually migrating things across abstraction boundaries
;;; This treats the outside as the boss: new frames that appear on the
;;; outside generate new frame map entries, but new frames that appear
;;; on the inside do not. Instead, the channels from the inside to
;;; the outside only transport things for which there already are
;;; frame map entries. Perhaps this has something to do with the fact
;;; that the inside is by design shared by all call sites of a given
;;; abstraction, but each call site has a different outside.
(define (select-submap frame-map frames)
(let* ((mapped-frames
(filter (lambda (frame)
(mapping-available? frame-map frame))
frames)))
(map (lambda (frame)
(cons frame (frame-map-get frame-map frame)))
mapped-frames)))
(define (transfer-inward frame-map outside-copies)
(if (or (nothing? frame-map) (nothing? outside-copies))
nothing
;; This is careful about mappings
(alist->virtual-copies
(map (lambda (frame-pair)
(cons (cdr frame-pair)
;; This can be direct-frame-content if all the
;; parents of the inside frame are images of the
;; frame map; but they may not be if stuff is
;; known about the interior abstraction
;; independently of its call sites.
;; TODO In fact, this is the place where things that
;; care about crossing abstraction boundaries might
;; be checked.
(full-frame-content outside-copies (car frame-pair))))
(select-submap frame-map (occurring-frames outside-copies))))))
(define (transfer-outward frame-map inside-copies outside-copies)
(if (or (nothing? frame-map)
(nothing? inside-copies) (nothing? outside-copies))
nothing
;; This is very careful about occurrences
(let* ((exterior-bindings
(select-submap frame-map (occurring-frames outside-copies)))
(bindings
(filter
(lambda (frame-pair)
(frame-occurs? inside-copies (cdr frame-pair)))
exterior-bindings)))
(alist->virtual-copies
(map (lambda (frame-pair)
(cons (car frame-pair)
;; direct- vs full- here as above
(full-frame-content inside-copies (cdr frame-pair))))
bindings)))))
(define (needed-interior-copies frame-map outside-vcs)
(if (or (nothing? frame-map) (any nothing? outside-vcs))
nothing
(let ((right-frames
(filter
(lambda (frame)
;; TODO Maybe the inside-transferrer needs to do
;; something like this too, to avoid creating copies
;; when all inputs are nothing.
(not (every nothing?
(map (lambda (vcs)
;; TODO direct- or full-?
(direct-frame-content vcs frame))
outside-vcs))))
(good-frames outside-vcs))))
(alist->virtual-copies
(map (lambda (frame)
(cons frame nothing))
(map cdr (select-submap frame-map right-frames)))))))
;;;; Dynamic call sites
(define (dynamic-call-site closure-cell outside-cells)
(let ((frame-map-cell (make-named-cell 'frame-map))
(frame-map (make-frame-map '() '())))
(add-content frame-map-cell frame-map)
(propagator (cons* frame-map-cell closure-cell outside-cells)
(eq-label!
(letrec ((the-propagator
(lambda ()
(do-the-dynamic-do
frame-map-cell closure-cell outside-cells the-propagator))))
the-propagator)
'name 'dynamic-call-manager
'inputs (cons* frame-map-cell closure-cell outside-cells)
;; These outputs are not really right. It has i/o with the
;; cells in the closure; and which of the boundary cells are
;; actually written also depends on which closures flow in.
'outputs (cons* frame-map-cell outside-cells)))))
(define (do-the-dynamic-do frame-map-cell closure-cell outside-cells self)
(define (update-map frame parents)
(add-content frame-map-cell
(simple-ensure-mapping (content frame-map-cell) frame parents)))
(define (build-interior-occurrences closure target-frame)
(for-each (lambda (cell)
(add-content cell (alist->virtual-copies
`((,target-frame . ,nothing)))))
(v-closure-interior closure)))
(define (transfer-inward frame target-frame outside-cells inside-cells)
(for-each
(lambda (out-cell in-cell)
(add-content in-cell
(alist->virtual-copies
`((,target-frame .
,(full-frame-content (content out-cell) frame))))))
outside-cells
inside-cells))
(define (transfer-outward frame target-frame outside-cells inside-cells)
(for-each
(lambda (out-cell in-cell)
(add-content out-cell
(alist->virtual-copies
`((,(the-occurring-parent frame (content out-cell)) .
,(full-frame-content (content in-cell) target-frame))))))
outside-cells
inside-cells))
(if (or (nothing? (content closure-cell))
(any nothing? (map content outside-cells)))
'done
(for-each
(lambda (frame)
(let ((closure (full-frame-content (content closure-cell) frame)))
;; TODO At this point, closure is an arbitrary partial
;; information structure, presumably over closures. To do this
;; properly, I would need to unpack it. The contents of the
;; outside-cells I can just transfer, however.
(if (or (nothing? closure)
(every nothing?
(map (lambda (vcs)
(direct-frame-content vcs frame))
(map content outside-cells))))
'done
(begin
(update-map frame (v-closure-default-parents closure))
(let ((target-frame (frame-map-get (content frame-map-cell) frame)))
(build-interior-occurrences closure target-frame)
(transfer-inward
frame target-frame outside-cells (v-closure-inside closure))
(transfer-outward
frame target-frame outside-cells (v-closure-inside closure)))
;; TODO Wow, what a hack! But yes, the transfer
;; outward portion of this does need to wake up when
;; the interior of the closure gets an answer. I
;; should separate that out, and make it properly
;; conditioned on the closure remaining the same, and
;; everything, but this conservative extension will
;; do for now.
(for-each (lambda (cell)
(new-neighbor! cell self))
(v-closure-inside closure))))))
(good-frames (cons (content closure-cell)
(map content outside-cells))))))
(define (v-closure-emitter boundary interior output)
(propagator output
(eq-label!
(lambda ()
(if (not (nothing? (content output)))
(add-content output
(alist->virtual-copies
(map (lambda (frame-content)
(cons (car frame-content)
(make-v-closure
boundary interior (list (car frame-content)))))
(virtual-copies->alist (content output)))))))
'name 'v-closure-emitter
'inputs (list output)
'outputs (list output))))
(define (merge-v-closures cl1 cl2)
(if (and (equal? (v-closure-interior cl1) (v-closure-interior cl2))
(equal? (v-closure-inside cl1) (v-closure-inside cl2))
(equal? (v-closure-default-parents cl1) (v-closure-default-parents cl2)))
cl1
the-contradiction))
(defhandler merge merge-v-closures v-closure? v-closure?)
propagator/core/ 0000775 0012467 0012467 00000000000 12111231500 012316 5 ustar gjs gjs propagator/core/test/ 0000775 0012467 0012467 00000000000 12106244135 013311 5 ustar gjs gjs propagator/core/test/core-test.scm 0000664 0012467 0012467 00000012460 11537676153 015745 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
core
(define-test (temperature1)
(interaction
(initialize-scheduler)
(define-cell f)
(define-cell c)
(p:fahrenheit->celsius f c)
(add-content f 77)
(run)
(content c)
(produces 25)
))
(define-test (temperature2)
(interaction
(initialize-scheduler)
(define-cell f)
(define-cell c)
(c:fahrenheit-celsius f c)
(add-content c 25)
(run)
(content f)
(produces 77)
(define-cell k)
(c:celsius-kelvin c k)
(run)
(content k)
(produces 298.15)
))
(define-test (barometer-fall-time)
(interaction
(initialize-scheduler)
(define-cell fall-time)
(define-cell building-height)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
(produces #(interval 41.163 47.243))
))
(define-test (barometer)
(interaction
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles barometer-shadow barometer-height
building-shadow building-height)
(add-content building-shadow (make-interval 54.9 55.1))
(add-content barometer-height (make-interval 0.3 0.32))
(add-content barometer-shadow (make-interval 0.36 0.37))
(run)
(content building-height)
(produces #(interval 44.514 48.978))
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
(produces #(interval 44.514 47.243))
(content barometer-height)
(produces #(interval .3 .31839))
;; Refining the (make-interval 0.3 0.32) we put in originally
(content fall-time)
(produces #(interval 3.0091 3.1))
;; Refining (make-interval 2.9 3.1)
(add-content building-height (make-interval 45 45))
(run)
(content barometer-height)
(produces #(interval .3 .30328))
(content barometer-shadow)
(produces #(interval .366 .37))
(content building-shadow)
(produces #(interval 54.9 55.1))
(content fall-time)
(produces #(interval 3.0255 3.0322))
))
(define-test (barometer-reverse-fall-time)
(interaction
(initialize-scheduler)
(define-cell fall-time)
(define-cell building-height)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
(produces #(interval 41.163 47.243))
(add-content building-height 45)
(run)
(content fall-time)
(produces #(interval 3.0255 3.0322))
))
(define-each-check
(= 4 (let-cell (x 4) (run) (content x)))
(= 5 (let-cells ((x (e:constant 2))
(y 3))
(let-cell (z (e:+ x y))
(run)
(content z))))
(= 7 (let-cells* ((x 3)
(y (e:+ x 4)))
(run)
(content y)))
(= 1 (let-cell ((answer (ce:+ 2 %% 3)))
(run)
(content answer)))
(= 7 (let-cells-rec ((z (e:+ x y))
(x (e:- z y))
(y (e:- z x)))
(c:id x 4)
(c:id y 3)
(run)
(content z)))
(= 4 (let-cells-rec ((z (e:+ x y))
(x (e:- z y))
(y (e:- z x)))
(c:id z 7)
(c:id y 3)
(run)
(content x)))
(= 3 (let-cells-rec ((z (e:+ x y))
(x (e:- z y))
(y (e:- z x)))
(c:id x 4)
(c:id z 7)
(run)
(content y))))
(define-test (serpent)
(initialize-scheduler)
(let-cell-rec (ones (e:cons 1 ones))
(run)
(check (eqv? 1 (content (e:car ones))))
(check (eqv? 1 (content (e:car (e:cdr ones)))))
(check (eqv? 1 (content (e:car (e:cdr (e:cdr ones))))))))
(define-test (monotonic-intervals)
(interaction
(initialize-scheduler)
(define-cell range1 (make-interval -5 5))
(define-cell range2 (make-interval -5 5))
(define-cell less? (e:< range1 range2))
(define-cell same? (e:= range1 range2))
(define-cell more? (e:> range1 range2))
(run)
(add-content range1 (make-interval 3 5))
(add-content range2 (make-interval 1 2))
(run)
(content less?)
(produces #f)
(content same?)
(produces #f)
(content more?)
(produces #t)))
(define-test (divisible-intervals)
(check (contradictory? (generic-/ (make-interval 3 4) 0)))
(check (contradictory? (generic-/ (make-interval 3 4) (make-interval 0 0)))))
)
propagator/core/test/load.scm 0000664 0012467 0012467 00000002452 11556106440 014743 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(for-each load-relative
'("scheduler-test"
"core-test"
"metadata-test"
"dependencies-test"
"partial-compounds-test"
"switches-test"
"compound-merges-test"
"copying-data-test"
"carrying-cells-test"
"physical-closures-test"
"barometer-test"))
propagator/core/test/partial-compounds-test.scm 0000664 0012467 0012467 00000006221 11421421707 020435 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
partial-compounds
(define caring-function (nary-unpacking car))
(define-each-check
(initialize-scheduler) ;; Why I need this is a mystery to me
(equal? nothing (caring-function nothing))
(equal? nothing (caring-function (cons nothing 5)))
(equal? 3 (caring-function (cons 3 5)))
(equal? 4 (generic-unpack (cons 4 5) car))
(generic-match
#(supported 4 (joe))
(generic-flatten (supported 4 '(joe))))
(generic-match
#(supported 4 (joe))
(generic-unpack (supported (cons 4 5) '(joe)) car))
(generic-match
#(supported 4 (joe))
(caring-function (supported (cons 4 5) '(joe))))
(generic-match
#(supported 4 (harry joe))
(caring-function (supported (cons (supported 4 '(harry)) 5) '(joe))))
(generic-match
#(supported 4 (harry joe))
(caring-function (supported (cons (supported 4 '(harry))
(supported 5 '(george)))
'(joe))))
(generic-match
nothing
(caring-function (supported (cons nothing 5) '(joe))))
(generic-match
#(tms (#(supported 4 (harry joe))))
(caring-function (make-tms (supported (cons (supported 4 '(harry)) 5) '(joe)))))
(generic-match
#(tms (#(supported 4 (harry joe))))
(caring-function
(make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe)))))
(generic-match
nothing
(disbelieving 'joe
(caring-function
(make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe))))))
(generic-match
nothing
(disbelieving 'harry
(caring-function
(make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe))))))
(generic-match
#(tms (#(supported 4 (harry joe))))
(disbelieving 'george
(caring-function
(make-tms (supported (cons (make-tms (supported 4 '(harry)))
(make-tms (supported 5 '(george))))
'(joe))))))
(generic-match
nothing
(caring-function
(make-tms (supported (cons nothing 4) '(joe)))))
(generic-match
#(tms (#(supported #(interval 4 5) (harry joe))))
(caring-function
(make-tms
(supported (cons (make-tms (supported (make-interval 4 5) '(harry))) 5)
'(joe)))))
))
propagator/core/test/dependencies-test.scm 0000664 0012467 0012467 00000023767 12106237272 017443 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
dependencies
(define-test (smoke)
(interaction
(initialize-scheduler)
(define-cell frob (make-tms (contingent 4 '(bill))))
(define-cell maybe-frob (e:switch (make-tms (contingent #t '(fred))) frob))
(run)
(tms-query (content maybe-frob))
(produces #(supported 4 (bill fred)))))
(define-test (supported-barometer)
(interaction
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles barometer-shadow barometer-height
building-shadow building-height)
(add-content building-shadow
(supported (make-interval 54.9 55.1) '(shadows)))
(add-content barometer-height
(supported (make-interval 0.3 0.32) '(shadows)))
(add-content barometer-shadow
(supported (make-interval 0.36 0.37) '(shadows)))
(run)
(content building-height)
(produces #(supported #(interval 44.514 48.978) (shadows)))
;; Test that writing a v&s doesn't break:
(check (equal?
(with-output-to-string
(lambda ()
(write (content building-height))))
"#(value=#[interval 44.51351351351351 48.977777777777774],
premises=(shadows),
informants=((*:p building-shadow cell125)))"))
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time
(supported (make-interval 2.9 3.3) '(lousy-fall-time)))
(run)
(content building-height)
(produces #(supported #(interval 44.514 48.978) (shadows)))
(add-content fall-time
(supported (make-interval 2.9 3.1) '(better-fall-time)))
(run)
(content building-height)
(produces #(supported #(interval 44.514 47.243)
(better-fall-time shadows)))
(add-content building-height (supported 45 '(superintendent)))
(run)
(content building-height)
(produces #(supported 45 (superintendent)))
(content barometer-height)
(produces #(supported #(interval .3 .30328)
(superintendent better-fall-time shadows)))
(content barometer-shadow)
(produces #(supported #(interval .366 .37)
(better-fall-time superintendent shadows)))
(content building-shadow)
(produces #(supported #(interval 54.9 55.1) (shadows)))
(content fall-time)
(produces #(supported #(interval 3.0255 3.0322) (superintendent)))
))
(define-test (tms-barometer)
(interaction
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles barometer-shadow barometer-height
building-shadow building-height)
(add-content building-shadow
(make-tms (supported (make-interval 54.9 55.1) '(shadows))))
(add-content barometer-height
(make-tms (supported (make-interval 0.3 0.32) '(shadows))))
(add-content barometer-shadow
(make-tms (supported (make-interval 0.36 0.37) '(shadows))))
(run)
(content building-height)
(produces #(tms (#(supported #(interval 44.514 48.978) (shadows)))))
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time
(make-tms (supported (make-interval 2.9 3.1) '(fall-time))))
(run)
(content building-height)
(produces #(tms (#(supported #(interval 44.514 47.243)
(fall-time shadows))
#(supported #(interval 44.514 48.978)
(shadows)))))
(tms-query (content building-height))
(produces #(supported #(interval 44.514 47.243) (fall-time shadows)))
(kick-out! 'fall-time)
(run)
(tms-query (content building-height))
(produces #(supported #(interval 44.514 48.978) (shadows)))
(kick-out! 'shadows)
(run)
(tms-query (content building-height))
(produces #(*the-nothing*))
(bring-in! 'fall-time)
(run)
(tms-query (content building-height))
(produces #(supported #(interval 41.163 47.243) (fall-time)))
(content building-height)
(produces #(tms (#(supported #(interval 41.163 47.243)
(fall-time))
#(supported #(interval 44.514 47.243)
(fall-time shadows))
#(supported #(interval 44.514 48.978)
(shadows)))))
(add-content building-height (supported 45 '(superintendent)))
(run)
(content building-height)
(produces #(tms (#(supported 45 (superintendent))
#(supported #(interval 41.163 47.243)
(fall-time))
#(supported #(interval 44.514 47.243)
(fall-time shadows))
#(supported #(interval 44.514 48.978)
(shadows)))))
(tms-query (content building-height))
(produces #(supported 45 (superintendent)))
(bring-in! 'shadows)
(run)
(tms-query (content building-height))
(produces #(supported 45 (superintendent)))
(content barometer-height)
(produces #(tms (#(supported #(interval .3 .30328)
(fall-time superintendent shadows))
#(supported #(interval .29401 .30328)
(superintendent shadows))
#(supported #(interval .3 .31839)
(fall-time shadows))
#(supported #(interval .3 .32) (shadows)))))
(tms-query (content barometer-height))
(produces #(supported #(interval .3 .30328)
(fall-time superintendent shadows)))
(kick-out! 'fall-time)
(run)
(tms-query (content barometer-height))
(produces #(supported #(interval .3 .30328) (superintendent shadows)))
(bring-in! 'fall-time)
(run)
(tms-query (content barometer-height))
(produces #(supported #(interval .3 .30328) (superintendent shadows)))
(content barometer-height)
(produces #(tms (#(supported #(interval .3 .30328)
(superintendent shadows))
#(supported #(interval .3 .31839)
(fall-time shadows))
#(supported #(interval .3 .32) (shadows)))))
))
(define-test (contradictory-barometer)
(interaction
;; Restore the state we had in the preceding example
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles barometer-shadow barometer-height
building-shadow building-height)
(add-content building-shadow
(make-tms (supported (make-interval 54.9 55.1) '(shadows))))
(add-content barometer-height
(make-tms (supported (make-interval 0.3 0.32) '(shadows))))
(add-content barometer-shadow
(make-tms (supported (make-interval 0.36 0.37) '(shadows))))
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time
(make-tms (supported (make-interval 2.9 3.1) '(fall-time))))
(run)
(tms-query (content building-height))
(kick-out! 'fall-time)
(run)
(tms-query (content building-height))
(bring-in! 'fall-time)
(kick-out! 'shadows)
(run)
(tms-query (content building-height))
(add-content building-height (supported 45 '(superintendent)))
(run)
(bring-in! 'shadows)
(run)
(tms-query (content building-height))
(tms-query (content barometer-height))
(kick-out! 'fall-time)
(run)
(tms-query (content barometer-height))
(bring-in! 'fall-time)
(run)
(tms-query (content barometer-height))
;; That was a long story!
(add-content building-height
(supported (make-interval 46. 50.) '(pressure)))
(run)
(produces '(contradiction (superintendent pressure)))
(tms-query (content building-height))
;; I don't like this answer... It should show the contradiction if
;; it is there.
(produces #(supported #(interval 46. 45) (superintendent pressure)))
;; From AXCH thesis -- I (GJS) think that the following is really
;; the right answer.
;; (produces #(supported *the-contradiction* (superintendent pressure)))
;; but then something has to prevent contradictions from getting
;; into propagators. This is done in generic definitions.
;; I tried to change tms-query to fix Micah's bug, but this was
;; not the best patch (produces #(*the-nothing*))
(tms-query (content barometer-height))
(produces #(supported #(interval .3 .30328) (superintendent shadows)))
(kick-out! 'superintendent)
(run)
(tms-query (content building-height))
(produces #(supported #(interval 46. 47.243)
(shadows fall-time pressure)))
(tms-query (content barometer-height))
(produces #(supported #(interval .30054 .31839)
(pressure fall-time shadows)))
(bring-in! 'superintendent)
(kick-out! 'pressure)
(run)
(tms-query (content building-height))
(produces #(supported 45 (superintendent)))
(tms-query (content barometer-height))
(produces #(supported #(interval .3 .30328) (superintendent shadows)))
))
(define-test (ternary-generic)
(interaction
(define (boolean/ro3 or-result i1 i2)
(if (and or-result (not i1) (not i2)) #t nothing))
(define generic-ro3 (make-generic-operator 3 'ro3 boolean/ro3))
((nary-mapping generic-ro3)
(make-tms (contingent #t '(a)))
(make-tms (contingent #f '(not-b)))
(make-tms (contingent #f '(not-c))))
(produces #(tms (#(supported #t (not-c a not-b)))))))
)
propagator/core/test/compound-merges-test.scm 0000664 0012467 0012467 00000010372 11432077362 020110 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
compound-merges
(define-each-check
(generic-match (cons nothing nothing) (merge (cons nothing nothing) nothing))
(generic-match (cons nothing nothing) (merge nothing (cons nothing nothing)))
(generic-match
(cons nothing nothing) (merge (cons nothing nothing) (cons nothing nothing)))
(generic-match (cons 4 nothing) (merge nothing (cons 4 nothing)))
(generic-match (cons 4 nothing) (merge (cons 4 nothing) nothing))
(generic-match (cons 4 nothing) (merge (cons 4 nothing) (cons 4 nothing)))
(generic-match the-contradiction (merge 4 (cons 5 6)))
(generic-match the-contradiction (merge 4 (cons 4 5)))
(generic-match the-contradiction (merge 4 (cons nothing nothing)))
(generic-match '(4 . 5) (merge (cons nothing 5) (cons 4 nothing)))
(generic-match '(4 . 5) (merge (cons 4 nothing) (cons nothing 5)))
(generic-match '(4 . 5) (merge (cons 4 5) (cons 4 nothing)))
(generic-match '(4 . 5) (merge (cons 4 nothing) (cons 4 5)))
(generic-match '(4 . 5) (merge (cons 4 5) (cons 4 5)))
;; This
#;
(merge (make-tms (supported (cons (make-tms (supported 4 '(fred))) nothing)
'(george)))
(make-tms (supported (cons nothing (make-tms (supported 3 '(bill))))
'())))
;; is mysterious because the result should, I think, look like
;; (4:fred,george . 3:bill), but I'm not sure how to make it do
;; that. Also,
#;
(merge (make-tms (supported (cons (make-tms (supported 4 '(fred))) nothing)
'(george)))
(make-tms (supported the-contradiction '(fred george))))
;; (or the moral equivalents thereof) should retain the fact that
;; george said there was a pair here (in case there's a pair?
;; propagator watching), but can probably afford to get rid of the
;; 4:fred inside, because if the pair is believed, then george is,
;; so fred isn't.
)
(define-test (recursive-tms-merge)
(check
(generic-match
#(effectful
#(tms
(#(supported
(#(tms (#(supported #(*the-contradiction*) (bill fred))
#(supported 4 (fred))
#(supported 3 (bill))))
.
#(*the-nothing*))
(george joe))
#(supported
(#(tms (#(supported 3 (bill)))) . #(*the-nothing*)) (joe))
#(supported
(#(tms (#(supported 4 (fred)))) . #(*the-nothing*))
(george))))
(#(nogood-effect (joe george bill fred))))
(merge (make-tms (supported
(cons (make-tms (supported 4 '(fred))) nothing)
'(george)))
(make-tms (supported
(cons (make-tms (supported 3 '(bill))) nothing)
'(joe)))))))
(define-test (recursive-tms-merge-2)
(check
(generic-match
#(effectful
#(tms
(#(supported
#(kons #(tms (#(supported #(*the-contradiction*) (bill fred))
#(supported 4 (fred))
#(supported 3 (bill))))
#(*the-nothing*))
(george joe))
#(supported
#(kons #(tms (#(supported 3 (bill)))) #(*the-nothing*)) (joe))
#(supported
#(kons #(tms (#(supported 4 (fred)))) #(*the-nothing*))
(george))))
(#(nogood-effect (joe george bill fred))))
(merge (make-tms (supported
(kons (make-tms (supported 4 '(fred))) nothing)
'(george)))
(make-tms (supported
(kons (make-tms (supported 3 '(bill))) nothing)
'(joe)))))))
)
propagator/core/test/switches-test.scm 0000664 0012467 0012467 00000011444 11421421707 016630 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
switches
(define switching-function (nary-unpacking switch-function))
(define-each-check
(generic-match nothing (switching-function nothing nothing))
(generic-match nothing (switching-function nothing 7))
(generic-match nothing (switching-function #f 7))
(generic-match 7 (switching-function #t 7))
(generic-match
#(supported 7 (bob))
(switching-function (supported #t '(bob)) 7))
(generic-match
#(supported 7 (harry bob))
(switching-function (supported #t '(bob)) (supported 7 '(harry))))
(generic-match
nothing
(switching-function (supported #t '(bob)) nothing))
(generic-match
nothing
(switching-function (supported #f '(bob)) 7))
(generic-match
nothing
(switching-function (supported #f '(bob)) (supported 7 '(harry))))
(generic-match
#(tms (#(supported 7 (bob))))
(switching-function (make-tms (supported #t '(bob))) 7))
(generic-match
nothing
(switching-function (make-tms (supported #t '(bob))) nothing))
(generic-match
#(tms (#(supported 7 (harry bob))))
(switching-function (make-tms (supported #t '(bob))) (supported 7 '(harry))))
(generic-match
#(tms (#(supported 7 (harry bob))))
(switching-function (make-tms (supported #t '(bob)))
(make-tms (supported 7 '(harry)))))
(generic-match
#(tms (#(supported #(interval 7 8) (harry bob))))
(switching-function (make-tms (supported #t '(bob)))
(make-tms (supported (make-interval 7 8) '(harry)))))
(generic-match
nothing
(switching-function (make-tms (supported #f '(bob))) nothing))
(generic-match
nothing
(switching-function (make-tms (supported #f '(bob))) 7))
(generic-match
nothing
(switching-function (make-tms (supported #f '(bob))) (supported 7 '(harry))))
(generic-match
nothing
(switching-function (make-tms (supported #f '(bob)))
(make-tms (supported 7 '(harry)))))
(generic-match
nothing
(disbelieving 'bob
(switching-function (make-tms (supported #t '(bob))) 7)))
(generic-match
nothing
(disbelieving 'harry
(switching-function (make-tms (supported #t '(bob)))
(make-tms (supported 7 '(harry))))))
(generic-match
nothing
(disbelieving 'harry
(switching-function (make-tms (supported #t '(bob)))
(make-tms (supported (make-interval 7 8) '(harry))))))
(generic-match
#(tms (#(supported 3 (bob joe))))
(disbelieving 'fred
(switching-function (make-tms (list (supported #f '(fred))
(supported #t '(joe))))
(make-tms (supported 3 '(bob))))))
(generic-match
nothing
(disbelieving 'joe
(switching-function (make-tms (list (supported #f '(fred))
(supported #t '(joe))))
(make-tms (supported 3 '(bob))))))
(generic-match
nothing
(disbelieving 'fred
(disbelieving 'bob
(switching-function (make-tms (list (supported #f '(fred))
(supported #t '(joe))))
(make-tms (supported 3 '(bob)))))))
(generic-match
#(tms (#(supported 4 (harry bob))))
(switching-function (supported #t '(bob))
(make-tms (supported 4 '(harry)))))
(generic-match
#(tms (#(supported 4 (harry bob))))
(disbelieving 'fred
(switching-function (supported #t '(bob))
(make-tms (list (supported 4 '(harry))
(supported 5 '(fred)))))))
(generic-match
#(tms (#(supported 4 (harry bob))))
(switching-function (supported #t '(bob))
(make-tms (list (supported 4 '(harry))
(supported 4 '(fred))))))
)
(define-test (propagator)
(interaction
(initialize-scheduler)
(define-cell input)
(define-cell control)
(define-cell output)
(switch control input output)
(add-content input 4)
(add-content control (supported #t '(fred)))
(run)
(content output)
(produces #(supported 4 (fred)))
))
)
propagator/core/test/barometer-test.scm 0000664 0012467 0012467 00000004557 11440033776 016774 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
barometer
(define-test (barometer-example)
(interaction
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles
barometer-shadow barometer-height building-shadow building-height)
(add-content building-shadow (make-interval 54.9 55.1))
(add-content barometer-height (make-interval 0.3 0.32))
(add-content barometer-shadow (make-interval 0.36 0.37))
(run)
(content building-height)
(produces #(interval 44.51351351351351 48.977777777777774))
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
(produces #(interval 44.51351351351351 47.24276000000001))
(content barometer-height)
(produces #(interval .3 .3183938287795994))
(content fall-time)
(produces #(interval 3.0091234174691017 3.1))
(add-content building-height 45)
(run)
(content barometer-height)
(produces #(interval .3 .30327868852459017))
(content barometer-shadow)
(produces #(interval .366 .37))
(content building-shadow)
(produces #(interval 54.9 55.1))
(content fall-time)
(produces #(interval 3.025522031629098 3.0321598338046556)))))
propagator/core/test/scheduler-test.scm 0000664 0012467 0012467 00000003542 11362361266 016764 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
scheduler
(define (with-every-scheduler thunk)
(for-each
(lambda (scheduler)
(fluid-let ((make-scheduler scheduler))
(thunk)))
(list make-round-robin-scheduler
make-stack-scheduler
make-two-stack-scheduler
make-robin-stack-scheduler
make-two-robin-scheduler)))
(define-test (smoke)
(with-every-scheduler
(lambda ()
(let ((run-count 0))
(define (run-me)
(set! run-count (+ run-count 1)))
(initialize-scheduler)
(check (= 0 (length (all-propagators))))
(check (= 0 run-count))
(alert-propagators run-me)
(check (= 1 (length (all-propagators))))
;; Running actually runs
(check (eq? 'done (run)))
(check (= 1 run-count))
(check (= 1 (length (all-propagators))))
;; No spurious reruns
(check (eq? 'done (run)))
(check (= 1 run-count))
(check (= 1 (length (all-propagators)))))))))
propagator/core/test/physical-closures-test.scm 0000664 0012467 0012467 00000024126 11542755010 020452 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
physical-closures
(define-test (neanderthalic-double)
(interaction
(initialize-scheduler)
(define-cell double
(make-closure
(lambda (x out)
(p:+ x x out))
'()))
(define-cell x 2)
(define-cell output)
(p:application double x output)
(run)
(content output)
(produces 4)
;; Stable under kicks:
(alert-all-propagators!)
(run)
(content output)
(produces 4)
))
(define-test (double)
(interaction
(initialize-scheduler)
(define-propagator (double x out)
(p:+ x x out))
(define-cell x 2)
(define-cell output)
(p:double x output)
(run)
(content output)
(produces 4)
;; Stable under kicks:
(alert-all-propagators!)
(run)
(content output)
(produces 4)
))
(define-test (double-again)
(interaction
(initialize-scheduler)
(define-e:propagator (ce:double x)
(ce:* x 2))
(define-cell answer (ce:double %% 2))
(run)
(content answer)
(produces 1)
;; Stable under kicks:
(alert-all-propagators!)
(run)
(content answer)
(produces 1)
))
(define-test (addn)
(interaction
(initialize-scheduler)
(define-cell addn
(make-closure
(lambda (n out)
((p:constant
(make-closure
(lambda (x out)
(p:+ n x out))
(list n)))
out))
'()))
(define-cell n 5)
(define-cell add5)
(p:application addn n add5)
(define-cell x 3)
(define-cell x-output)
(p:application add5 x x-output)
(define-cell y 5)
(define-cell y-output)
(p:application add5 y y-output)
(run)
(content x-output)
(produces 8)
(content y-output)
(produces 10)
;; Stable under kicks:
(alert-all-propagators!)
(run)
(content x-output)
(produces 8)
(content y-output)
(produces 10)
))
(define-test (neanderthalic-merge-addn)
(interaction
(initialize-scheduler)
(define-cell addn
(make-e:closure
(lambda (n)
(e:constant
(make-e:closure
(lambda (x)
(e:+ n x))
(list n))))
'()))
(define-cell n1 (make-interval 3 5))
(define-cell n2 (make-interval 4 7))
(define-cell add5 (e:application addn n1))
(p:application addn n2 add5)
(define-cell output (e:application add5 3))
(run)
(content output)
(produces #(interval 7 8))
(add-content n2 (make-interval 5 9))
(run)
(content output)
(produces 8)
))
(define-test (merge-addn)
(interaction
(initialize-scheduler)
(define-e:propagator (e:addn n)
(lambda-e:propagator (x)
(import n)
(e:+ n x)))
(define-cell n1 (make-interval 3 5))
(define-cell n2 (make-interval 4 7))
(define-cell add5 (e:addn n1))
(p:addn n2 add5)
(define-cell output (e:application add5 3))
(run)
(content output)
(produces #(interval 7 8))
(add-content n2 (make-interval 5 9))
(run)
(content output)
(produces 8)
))
(define-test (compose)
(interaction
(initialize-scheduler)
(define-cell double
(make-e:closure
(lambda (x)
(e:+ x x))
'()))
(define-cell square
(make-e:closure
(lambda (x)
(e:* x x))
'()))
(define-cell compose
(make-e:closure
(lambda (f g)
(e:constant
(make-e:closure
(lambda (x)
(e:application f (e:application g x)))
(list f g))))
'()))
(define-cell double-square (e:application compose double square))
(define-cell square-double (e:application compose square double))
(define-cell x 2)
(define-cell 2x^2 (e:application double-square x))
(define-cell 4x^2 (e:application square-double x))
(run)
(content 2x^2)
(produces 8)
(content 4x^2)
(produces 16)
;; Stable under kicks:
(alert-all-propagators!)
(run)
(content 2x^2)
(produces 8)
(content 4x^2)
(produces 16)
))
(define-test (repeat)
(interaction
(initialize-scheduler)
(define-e:propagator (e:double x)
(e:+ x x))
(define-e:propagator (e:compose f g)
(lambda-e:propagator (x)
(import f g)
(e:application f (e:application g x))))
(define-cell repeat
(let-cell (repeat)
((constant
(lambda-d:propagator (f n out)
(import e:compose repeat)
(let-cell (repeat? (e:> n 1))
(let-cell (done? (e:not repeat?))
(switch done? f out)
(let-cells ((n-1 (e:- n 1))
fn-1 f-again out-again n-1-again compose-again repeat-again)
(switch repeat? n-1 n-1-again)
(switch repeat? f f-again)
(switch repeat? out-again out)
(switch repeat? e:compose compose-again)
(switch repeat? repeat repeat-again)
(p:application compose-again fn-1 f-again out-again)
(p:application repeat-again f-again n-1-again fn-1))))))
repeat)
repeat))
(define-cell output
(e:application
(e:application repeat e:double 4) 2))
(run)
(content output)
(produces 32)
))
(define-test (tms-addn)
(interaction
(initialize-scheduler)
(define-propagator (addn n out)
((p:constant
(lambda-d:propagator (x out)
(import n)
(p:+ n x out)))
out))
(define-cell add5-fred (e:application p:addn (make-interval 3 5)))
(define-cell bill (make-interval 4 7))
(define-cell add5-bill (e:application p:addn bill))
(define-cell add5)
(p:switch (make-tms (supported #t '(fred))) add5-fred add5)
(p:switch (make-tms (supported #t '(bill))) add5-bill add5)
(define-cell output (e:application add5 (make-tms (supported 3 '(joe)))))
(run)
(tms-query (content output))
(produces #(supported #(interval 7 8) (joe fred bill)))
(kick-out! 'bill)
(run)
(tms-query (content output))
(produces #(supported #(interval 6 8) (joe fred)))
(kick-out! 'fred)
(run)
(tms-query (content output))
(produces nothing)
(bring-in! 'bill)
(run)
(tms-query (content output))
(produces #(supported #(interval 7 10) (joe bill)))
(add-content bill (make-tms (supported (make-interval 5 9) '(harry))))
(run)
(tms-query (content output))
(produces #(supported #(interval 8 10) (harry joe bill)))
))
(define-test (first-class-primitives)
(initialize-scheduler)
(define-cell output (e:application p:+ 3 4))
(run)
(check (= 7 (content output))))
(define-test (first-class-e:primitives)
(initialize-scheduler)
(define-cell output (e:application e:+ 3 4))
(run)
(check (= 7 (content output))))
(define-test (first-class-macro-primitives)
(initialize-scheduler)
(define-cell x)
(define-cell output (e:application c:+ 3 x))
(add-content output 7)
(run)
(check (= 4 (content x))))
(define-test (manual-example-unknown-operation)
(interaction
(initialize-scheduler)
(define-cell operation)
(define-cell answer)
(operation 3 4 answer)
(run)
(content answer)
(produces nothing)
(p:id p:* operation)
(run)
(content answer)
(produces 12)))
(define-test (manual-example-tms-apply)
(interaction
(initialize-scheduler)
(define-cell the-operation)
(define-cell the-answer (e@ the-operation 3 4))
(p:switch (make-tms (contingent #t '(bill))) e:+ the-operation)
(run)
(tms-query (content the-answer))
(produces #(supported 7 (bill)))
(kick-out! 'bill)
(tms-query (content the-answer))
(produces nothing)
(p:switch (make-tms (contingent #t '(fred))) e:* the-operation)
(run)
(tms-query (content the-answer))
(produces #(supported 12 (fred)))
))
(define-test (first-class-primitives-tms)
(interaction
(initialize-scheduler)
(define-cell bill-op p:+)
(define-cell fred-op e:*)
(define-cell the-op)
(switch (make-tms (supported #t '(bill))) bill-op the-op)
(switch (make-tms (supported #t '(fred))) fred-op the-op)
(define-cell output (e:application the-op 3 4))
(run)
(produces '(contradiction (fred bill)))
(check (equal? '(application) (map name (neighbors the-op))))
(kick-out! 'bill)
(run)
(tms-query (content output))
(produces #(supported 12 (fred)))
(check (equal? '(equivalent-closures?:p application)
(map name (neighbors the-op))))
(kick-out! 'fred)
(bring-in! 'bill)
(run)
(tms-query (content output))
(produces #(supported 7 (bill)))
(check (equal? '(equivalent-closures?:p equivalent-closures?:p application)
(map name (neighbors the-op))))
))
(define-test (returning-e:-vs-p:)
(interaction
(initialize-scheduler)
(define-e:propagator (addn n)
(define-e:propagator (the-adder x)
(import n)
(e:+ n x))
e:the-adder)
(define-cell answer ((e:addn 3) 2))
(run)
(content answer)
(produces 5)))
(define-test (returning-p:-vs-e:)
(interaction
(initialize-scheduler)
(define-e:propagator (addn n)
(define-e:propagator (the-adder x)
(import n)
(e:+ n x))
p:the-adder)
(define-cell answer)
((e:addn 3) 2 answer)
(run)
(content answer)
(produces 5)))
)
propagator/core/test/carrying-cells-test.scm 0000664 0012467 0012467 00000005375 11436300317 017722 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
carrying-cells
(define-test (smoke)
(interaction
(initialize-scheduler)
(define-cell bill (make-tms (supported 3 '(bill))))
(define-cell bill-cons (e:carry-cons nothing bill))
(define-cell answer)
(c:== bill-cons answer)
(define-cell fred (make-tms (supported 4 '(fred))))
(define-cell fred-cons (e:carry-cons fred nothing))
(define-cell george (make-tms (supported #t '(george))))
(conditional-wire george fred-cons answer)
(define-cell the-pair? (e:carry-pair? answer))
(define-cell the-car (e:carry-car answer))
(define-cell the-cdr (e:carry-cdr answer))
(run)
; (pp (content answer))
(content the-pair?)
(produces #t)
(content the-car)
(produces #(tms (#(supported 4 (fred george)))))
(content the-cdr)
(produces #(tms (#(supported 3 (bill)))))))
(define-test (early-access-test)
(interaction
(initialize-scheduler)
(define-cell source-car)
(define-cell source-cdr)
(define-cell the-pair (e:carry-cons source-car source-cdr))
(check (eq? source-car (e:carry-car the-pair)))
(check (eq? source-cdr (e:carry-cdr the-pair)))
))
(define-test (deposit)
(interaction
(initialize-scheduler)
(define-cell two-cell (e:deposit 2))
(run)
(check (cell? two-cell))
(check (cell? (content two-cell)))
(content (content two-cell))
(produces 2)
(define-cell examined (e:examine two-cell))
(content examined)
(produces 2)))
(define-test (examine)
(interaction
(initialize-scheduler)
(define-cell examinee)
(define-cell exam (e:examine examinee))
(add-content exam 2)
(run)
(check (cell? (content examinee)))
(content (content examinee))
(produces 2)))
)
propagator/core/test/copying-data-test.scm 0000664 0012467 0012467 00000006114 11421421707 017354 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;; The "copying data" strategy from the thesis is given by these
;;; definitions of the cons-car-cdr propagators:
#|
(define conser (function->propagator-constructor cons))
(define carer (function->propagator-constructor (nary-unpacking car)))
(define cdrer (function->propagator-constructor (nary-unpacking cdr)))
|#
;;; This strategy is tested here, with the definitions in question
;;; appearing inside the test scope below.
;;; The "carrying cells" strategy is elaborated in
;;; extensions/carrying-cells.scm. Since the merging is the same in
;;; both cases, the two strategies may be intermixed within the same
;;; network --- just make sure your propagators know what to expect
;;; (and there is as yet no good story for merging a piece of data and
;;; a cell, so merging a carrying cons with a copying cons will not do
;;; anything good).
(in-test-group
copying-data
(define-test (example)
(interaction
(define conser (function->propagator-constructor cons))
(define carer (function->propagator-constructor (nary-unpacking car)))
(define cdrer (function->propagator-constructor (nary-unpacking cdr)))
(initialize-scheduler)
(define-cell x)
(define-cell y)
(define-cell pair)
(conser x y pair)
(run)
(content pair)
(produces '( #(*the-nothing*) . #(*the-nothing*) ))
(define-cell control)
(define-cell switched-pair)
(switch control pair switched-pair)
(add-content control (make-tms (supported #t '(joe))))
(run)
(content switched-pair)
(produces #(tms (#(supported ( #(*the-nothing*) . #(*the-nothing*) ) (joe)))))
(define-cell x-again)
(carer switched-pair x-again)
(run)
(content x-again)
(produces #(*the-nothing*))
(add-content x (make-tms (supported 4 '(harry))))
(run)
(content pair)
(produces '( #(tms (#(supported 4 (harry)))) . #(*the-nothing*) ))
(content switched-pair)
(produces #(tms (#(supported ( #(tms (#(supported 4 (harry)))) . #(*the-nothing*) )
(joe)))))
(content x-again)
(produces #(tms (#(supported 4 (harry joe)))))
)))
propagator/core/test/metadata-test.scm 0000664 0012467 0012467 00000002646 11556106401 016563 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2011 Alexey Radul and Gerald Jay Sussman
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(in-test-group
metadata
(define-test (macrology-smoke)
(initialize-scheduler)
(let-cells ((foo (make-cell))
bar
(baz (make-cell)))
(check (eq? 'foo (name foo)))
(check (not (eq-get foo 'name)))
(check (eq? 'bar (name bar)))
(check (eq? 'bar (eq-get bar 'name)))
(check (eq? 'baz (name baz)))
(check (not (eq-get baz 'name)))
))
)
propagator/core/intervals.scm 0000664 0012467 0012467 00000015714 11543743675 015076 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
#|
(define-structure
(%interval (safe-accessors #t)
(print-procedure
(simple-unparser-method
'interval
(lambda (interval)
(list (interval-low interval)
(interval-high interval))))))
low high)
|#
(define (interval-printer state object)
(if (empty-interval? object)
(with-current-unparser-state state
(lambda (port)
(display "#[contradictory-interval " port)
(write (interval-low object) port)
(display " " port)
(write (interval-high object) port)
(display "]" port)))
(with-current-unparser-state state
(lambda (port)
(display "#[interval " port)
(write (interval-low object) port)
(display " " port)
(write (interval-high object) port)
(display "]" port)))))
(define-structure
(%interval (safe-accessors #t)
(print-procedure interval-printer))
low high)
(declare-type-tester %interval? rtd:%interval)
(declare-coercion-target %interval)
(declare-coercion ->%interval (lambda (x) (make-%interval x x)))
(define (%interval-> int)
(if (= (interval-low int) (interval-high int))
(interval-low int)
int))
(define (interval? x)
(or (%interval? x)
(%interval-able? x)))
(define (interval-low thing)
(%interval-low (->%interval thing)))
(define (interval-high thing)
(%interval-high (->%interval thing)))
(define (make-interval low high)
(%interval-> (make-%interval low high)))
(define (interval-equal? int1 int2)
(and (= (interval-low int1) (interval-low int2))
(= (interval-high int1) (interval-high int2))))
(define (add-interval x y)
(make-interval (+ (interval-low x) (interval-low y))
(+ (interval-high x) (interval-high y))))
(define (sub-interval x y)
(make-interval (- (interval-low x) (interval-high y))
(- (interval-high x) (interval-low y))))
(define (mul-interval x y)
(let ((p1 (* (interval-low x) (interval-low y)))
(p2 (* (interval-low x) (interval-high y)))
(p3 (* (interval-high x) (interval-low y)))
(p4 (* (interval-high x) (interval-high y))))
(make-interval (min p1 p2 p3 p4)
(max p1 p2 p3 p4))))
(define *error-on-zero-interval-division* #f)
(define (div-interval x y)
(if (<= (interval-low y) 0 (interval-high y))
(if *error-on-zero-interval-division*
(error "Cannot divide by interval spanning 0" x y)
nothing)
(mul-interval x
(make-interval (/ 1 (interval-high y))
(/ 1 (interval-low y))))))
(define (square-interval x)
(make-interval (square (interval-low x))
(square (interval-high x))))
(define (sqrt-interval x)
(make-interval (sqrt (interval-low x))
(sqrt (interval-high x))))
(define (log-interval x)
(make-interval (log (interval-low x))
(log (interval-high x))))
(define (exp-interval x)
(make-interval (exp (interval-low x))
(exp (interval-high x))))
(define (empty-interval? x)
(> (interval-low x) (interval-high x)))
#|
;;; This makes a floating-point disaster... UGH!
;;; MERGE does not consider intervals differing by roundoff to be EQUAL.
(define (intersect-intervals x y)
(define (exactness-max x y)
(if (>= x y) x y))
(define (exactness-min x y)
(if (<= x y) x y))
(make-interval
(exactness-max (interval-low x) (interval-low y))
(exactness-min (interval-high x) (interval-high y))))
|#
(define (intersect-intervals x y)
(define (exactness-max x y)
(if (or (num=? x y) (> x y)) x y))
(define (exactness-min x y)
(if (or (num=? x y) (< x y)) x y))
(make-interval
(exactness-max (interval-low x) (interval-low y))
(exactness-min (interval-high x) (interval-high y))))
;; This differs from interval-equal? because is has to be monotonic
;; with respect to the intervals shrinking.
(define (=-interval x y)
(or (= (interval-low x) (interval-high x)
(interval-low y) (interval-high y))
(and (not (empty-interval? (intersect-intervals x y)))
nothing)))
(define (<-interval x y)
(or (< (interval-high x) (interval-low y))
(and (< (interval-low x) (interval-high y))
nothing)))
(define (<=-interval x y)
(or (<= (interval-high x) (interval-low y))
(and (<= (interval-low x) (interval-high y))
nothing)))
(define (>-interval x y)
(or (> (interval-low x) (interval-high y))
(and (> (interval-high x) (interval-low y))
nothing)))
(define (>=-interval x y)
(or (>= (interval-low x) (interval-high y))
(and (>= (interval-high x) (interval-low y))
nothing)))
(defhandler-coercing generic-+ add-interval ->%interval)
(defhandler-coercing generic-- sub-interval ->%interval)
(defhandler-coercing generic-* mul-interval ->%interval)
(defhandler-coercing generic-/ div-interval ->%interval)
(defhandler-coercing generic-= =-interval ->%interval)
(defhandler-coercing generic-< <-interval ->%interval)
(defhandler-coercing generic-<= <=-interval ->%interval)
(defhandler-coercing generic-> >-interval ->%interval)
(defhandler-coercing generic->= >=-interval ->%interval)
(defhandler generic-square square-interval %interval?)
(defhandler generic-sqrt sqrt-interval %interval?)
(defhandler generic-log log-interval %interval?)
(defhandler generic-exp exp-interval %interval?)
(defhandler-coercing merge intersect-intervals ->%interval)
(defhandler-coercing equivalent? interval-equal? ->%interval)
(defhandler contradictory? empty-interval? %interval?)
(define (interval-non-zero? x)
(and (interval? x)
(or (< 0 (interval-low x)) (> 0 (interval-high x)))))
(declare-explicit-guard interval-non-zero? (guard rtd:%interval interval-non-zero?))
(defhandler generic-/ binary-contradiction
interval-non-zero? numerical-zero?)
(define (interval-contains-zero? x)
(and (interval? x)
(and (<= (interval-low x) 0) (>= (interval-high x) 0))))
(declare-explicit-guard interval-contains-zero? (guard rtd:%interval interval-contains-zero?))
(defhandler generic-/ binary-nothing
interval-contains-zero? numerical-zero?)
propagator/core/load.scm 0000664 0012467 0012467 00000004133 11657020262 013761 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(define (self-relatively thunk)
(let ((place (ignore-errors current-load-pathname)))
(if (pathname? place)
(with-working-directory-pathname
(directory-namestring place)
thunk)
(thunk))))
(define (load-relative filename)
(self-relatively (lambda () (load filename))))
(load-relative "../support/load")
(for-each load-relative-compiled
'("scheduler"
;"metadata"
"diagrams"
"merge-effects"
"cells"
"diagram-cells"
"cell-sugar"
"propagators"
"application"
"sugar"
"generic-definitions"
"compound-data"
"physical-closures"
"standard-propagators"
"carrying-cells"
;;Intervals must follow standard-propagators in the load order
;;because it depends on interval-non-zero?, numerical-zero?,
;;binary-nothing, and binary-contradiction previously defined.
"intervals"
"premises"
"supported-values"
"truth-maintenance"
"contradictions"
"search"
"amb-utils"
"ui"
"explain"
"example-networks"
"test-utils"))
(maybe-warn-low-memory)
(initialize-scheduler)
propagator/core/scheduler.scm 0000664 0012467 0012467 00000017711 11421421710 015016 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Basic scheduling system
;;; This scheduler maintains a list of jobs that need to be run. Each
;;; job is a thunk. Jobs are run serially and are not preempted.
;;; When a job exits (normally) it is forgotten and the next job is
;;; run. The jobs are permitted to schedule additional jobs,
;;; including rescheduling themselves. Jobs are presumed idempotent,
;;; and specifically it is assumed acceptable not to count how many
;;; times a given job (by eq?-ness) was scheduled, but merely that it
;;; was scheduled. When the scheduler runs out of jobs, it returns
;;; the symbol 'DONE to its caller.
;;; The scheduler supplies an escape mechanism: running the procedure
;;; ABORT-PROCESS, with a value, will terminate the entire job run,
;;; and return the supplied value to the scheduler's caller.
;;; Subsequent calls to the scheduler without first scheduling more
;;; jobs will also return that same value. If ABORT-PROCESS is called
;;; outside the dynamic extent of a run, it deschedules any jobs that
;;; might be scheduled and saves the value for future reference as
;;; above.
;;; This scheduler is meant as a low-level support for the propagator
;;; network in this prototype. In that use case, the jobs would be
;;; propagators that the network knows need to be run. Any cells in
;;; the network are invisible to the scheduler, but presumably help
;;; the network schedule more propagators to run (namely those that
;;; may be interested in the cell's goings on).
;;; The main public interface is
;;; (initialize-scheduler) clear all scheduler state
;;; (alert-propagators jobs) schedule a list (or set) of jobs
;;; (alert-all-propagators!) reschedule all jobs ever scheduled
;;; (run) run scheduled jobs until done
;;; (abort-process x) terminate the run returning x
;;; The scheduler also provides
;;; (with-independent-scheduler thunk)
;;; Run thunk in a fresh scheduler, then restore current scheduler.
;;; (make-scheduler)
;;; Mutation point that can be configured to expriment with
;;; different scheduling strategies.
;;; (execute-propagator propagator)
;;; Execute a propagator immediately rather than scheduling it for
;;; later. Use judiciously.
;;; (all-propagators)
;;; Returns a list of all known propagators. Mainly for debugging
;;; a propagator network.
(define *scheduler*)
(define *abort-process*)
(define *last-value-of-run*)
(define *propagators-ever-alerted*)
;; This is a mutation point, if one wants to play with different kinds
;; of schedulers. The default is round-robin, below.
(define (make-scheduler) (make-round-robin-scheduler))
(define (initialize-scheduler)
(set! *scheduler* (make-scheduler))
(set! *abort-process* #f)
(set! *last-value-of-run* 'done)
(set! *propagators-ever-alerted* (make-eq-oset))
'ok)
(define (with-independent-scheduler thunk)
(fluid-let ((*scheduler* #f)
(*abort-process* #f)
(*last-value-of-run* #f)
(*propagators-ever-alerted* #f))
(initialize-scheduler)
(thunk)))
(define (execute-propagator propagator)
(propagator))
(define (alert-propagators propagators)
(for-each
(lambda (propagator)
(if (not (procedure? propagator))
(error "Alerting a non-procedure" propagator))
(oset-insert *propagators-ever-alerted* propagator)
((*scheduler* 'alert-one) propagator))
(listify propagators))
#f)
(define alert-propagator alert-propagators)
(define (all-propagators)
(oset-members *propagators-ever-alerted*))
(define (alert-all-propagators!)
(for-each (*scheduler* 'alert-one) (all-propagators)))
(define (with-process-abortion thunk)
(call-with-current-continuation
(lambda (k)
(fluid-let ((*abort-process* k))
(thunk)))))
(define termination-trace #f)
(define (abort-process value)
(if termination-trace
(ppc `(calling abort-process with ,value and ,*abort-process*)))
(if *abort-process*
;; if the propagator is running
(begin (*scheduler* 'clear!)
(*abort-process* value))
;; if the user is setting up state
(begin (*scheduler* 'clear!)
(set! *last-value-of-run* value))))
(define (run)
(define (do-run)
(*scheduler* 'run))
(if (not (*scheduler* 'done?))
(set! *last-value-of-run* (with-process-abortion do-run)))
*last-value-of-run*)
(define (make-oset-scheduler policy)
(let ((propagators-left (make-eq-oset)))
(define (run-alerted)
(if (any-alerted?)
(begin
(policy propagators-left)
(run-alerted))
'done))
(define (alert-one propagator)
(oset-insert propagators-left propagator))
(define (clear!)
(oset-clear! propagators-left))
(define (any-alerted?)
(< 0 (oset-count propagators-left)))
(define (me message)
(cond ((eq? message 'run) (run-alerted))
((eq? message 'alert-one) alert-one)
((eq? message 'clear!) (clear!))
((eq? message 'done?) (not (any-alerted?)))))
me))
(define (round-robin-policy propagators-left)
(let ((temp (oset-members propagators-left)))
(oset-clear! propagators-left)
(for-each (lambda (propagator)
(execute-propagator propagator))
temp)))
(define (stack-policy propagators-left)
(execute-propagator (oset-pop! propagators-left)))
(define (make-round-robin-scheduler)
(make-oset-scheduler round-robin-policy))
(define (make-stack-scheduler)
(make-oset-scheduler stack-policy))
(define (make-fast-slow-scheduler fast-policy slow-policy)
(let ((propagators-left (make-eq-oset))
(slow-propagators (make-eq-oset)))
(define (run-alerted)
(cond ((any-normal?)
(fast-policy propagators-left)
(run-alerted))
((any-slow?)
(slow-policy slow-propagators)
(run-alerted))
(else 'done)))
(define (alert-one propagator)
(if (tagged-slow? propagator)
(oset-insert slow-propagators propagator)
(oset-insert propagators-left propagator)))
(define (clear!)
(oset-clear! propagators-left)
(oset-clear! slow-propagators))
(define (any-alerted?)
(or (any-normal?) (any-slow?)))
(define (any-normal?)
(< 0 (oset-count propagators-left)))
(define (any-slow?)
(< 0 (oset-count slow-propagators)))
(define (me message)
(cond ((eq? message 'run) (run-alerted))
((eq? message 'alert-one) alert-one)
((eq? message 'clear!) (clear!))
((eq? message 'done?) (not (any-alerted?)))))
me))
(define (tagged-slow? thing)
(eq-get thing 'slow))
(define (tag-slow! thing)
(eq-put! thing 'slow #t)
thing)
;;; These schedulers were much worse than round-robin on the slow
;;; examples when tagging amb-choose propagators as slow.
(define (make-two-stack-scheduler)
(make-fast-slow-scheduler stack-policy stack-policy))
(define (make-robin-stack-scheduler)
(make-fast-slow-scheduler round-robin-policy stack-policy))
(define (make-two-robin-scheduler)
(make-fast-slow-scheduler round-robin-policy round-robin-policy))
propagator/core/run-tests 0000775 0012467 0012467 00000000442 11555636032 014234 0 ustar gjs gjs #!/bin/sh
mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(set! load-debugging-info-on-demand? #t)' --eval '(begin (load "load") (load "test/load") (show-time run-registered-tests) (newline) (flush-output) (%exit 0))'
propagator/core/search.scm 0000664 0012467 0012467 00000012124 11654343561 014315 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define *false-premise-starts-out* #t)
(define *avoid-false-true-flips* #f)
(define (binary-amb cell)
(let ((true-premise (make-hypothetical 'true cell))
(false-premise (make-hypothetical 'false cell)))
(define (amb-choose)
(if (and *avoid-false-true-flips*
(or (premise-in? true-premise)
(premise-in? false-premise)))
'ok ; the some-premise-is-in invariant holds
(let ((reasons-against-true
(filter (lambda (nogood)
(and (all-premises-in? nogood)
(not (member false-premise nogood))))
(premise-nogoods true-premise)))
(reasons-against-false
(filter (lambda (nogood)
(and (all-premises-in? nogood)
(not (member true-premise nogood))))
(premise-nogoods false-premise))))
(cond ((null? reasons-against-true)
(if *contradiction-wallp*
(pp `(asserting-true ,true-premise
,false-premise
,cell)))
(kick-out! false-premise)
(bring-in! true-premise))
((null? reasons-against-false)
(if *contradiction-wallp*
(pp `(asserting-false ,true-premise
,false-premise
,cell)))
(kick-out! true-premise)
(bring-in! false-premise))
(else ; this amb must fail.
(if *contradiction-wallp*
(pp `(amb-fail ,true-premise ,false-premise ,cell)))
(kick-out! true-premise)
(kick-out! false-premise)
(process-contradictions
(pairwise-resolve reasons-against-true
reasons-against-false)))))))
(name! amb-choose 'amb-choose)
;; This only affects run order, and only in some experimental
;; schedulers
(tag-slow! amb-choose)
(if *false-premise-starts-out*
;; Let's have the false premise start unbelieved.
(mark-premise-out! false-premise))
;; The cell is a spiritual neighbor...
(propagator cell amb-choose)
(let ((diagram
(make-anonymous-i/o-diagram amb-choose '() (list cell))))
((constant (make-tms
(list (supported #t (list true-premise) (list diagram))
(supported #f (list false-premise) (list diagram)))))
cell)
(register-diagram diagram)
diagram)))
(define (pairwise-resolve nogoods1 nogoods2)
(append-map (lambda (nogood1)
(map (lambda (nogood2)
(lset-union eq? nogood1 nogood2))
nogoods2))
nogoods1))
(define (process-contradictions nogoods)
(process-one-contradiction
(car (sort-by nogoods
(lambda (nogood)
(length (filter hypothetical? nogood)))))))
(define (process-one-contradiction nogood)
(if *contradiction-wallp* (pp `(nogood ,@nogood)))
(let ((hyps (filter hypothetical? nogood)))
(if (null? hyps)
(begin
(if *contradiction-wallp* (pp 'nogood-aborted))
(abort-process `(contradiction ,nogood)))
(begin
(if *contradiction-wallp*
(pp `(kicking-out ,(car hyps))))
(kick-out! (car hyps))
(for-each (lambda (premise)
(assimilate-nogood! premise nogood))
nogood)))))
(define (assimilate-nogood! premise new-nogood)
(let ((item (delq premise new-nogood))
(set (premise-nogoods premise)))
(if (any (lambda (old) (lset<= eq? old item)) set)
#f
(let ((subsumed
(filter (lambda (old) (lset<= eq? item old))
set)))
(set-premise-nogoods! premise
(lset-adjoin eq?
(lset-difference eq? set subsumed) item))))))
(define *number-of-calls-to-fail* 0)
(define initialize-scheduler
(let ((initialize-scheduler initialize-scheduler))
(lambda ()
(initialize-scheduler)
(set! *number-of-calls-to-fail* 0))))
(define with-independent-scheduler
(let ((with-independent-scheduler with-independent-scheduler))
(lambda args
(fluid-let ((*number-of-calls-to-fail* #f))
(apply with-independent-scheduler args)))))
(define *contradiction-wallp* #f)
(define (process-nogood! nogood)
(set! *number-of-calls-to-fail*
(+ *number-of-calls-to-fail* 1))
(process-one-contradiction nogood))
propagator/core/supported-values.scm 0000664 0012467 0012467 00000014000 12106237272 016357 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define *depends-wallp* #f)
(define (depends-printer state object)
(with-current-unparser-state state
(lambda (port)
(display "#(value=" port)
(write (vector-ref object 1) port) ; Avoid checking the length
(display ",\n premises=" port)
(write (vector-ref object 2) port)
(if (>= (vector-length object) 4)
(begin
(display ",\n informants=" port)
(write
(map (lambda (inf)
(if (symbol? inf)
inf
(cons (name inf)
(map name
(diagram-inputs inf)))))
(vector-ref object 3))
port)))
(display ")" port))))
(define-structure
(v&s (named 'supported) (type vector)
(constructor %supported)
(print-procedure depends-printer)
(safe-accessors #t))
value support informants)
(define *active-diagram* 'user)
(define (supported value depends #!optional informants)
(%supported value depends
(if (default-object? informants)
(list *active-diagram*)
informants)))
;;; Aliases
(define make-dependent-value supported)
(define depends? v&s?)
(define depends-value v&s-value)
(define depends-premises v&s-support)
(define depends-informants v&s-informants)
(define contingent supported)
(define contingent? v&s?)
(define contingent-info v&s-value)
(define contingent-premises v&s-support)
(define contingent-informants v&s-informants)
(declare-coercion-target contingent
(lambda (thing)
(contingent thing '() '())))
(declare-coercion ->contingent)
(declare-coercion ->contingent)
(declare-coercion ->contingent)
(declare-coercion rtd:%interval ->contingent)
(declare-coercion propagator-constructor? ->contingent)
(declare-coercion closure? ->contingent)
(declare-coercion pair? ->contingent)
(declare-coercion null? ->contingent)
(define (more-informative-support? v&s1 v&s2)
(and (not (lset= eq? (v&s-support v&s1) (v&s-support v&s2)))
(lset<= eq? (v&s-support v&s1) (v&s-support v&s2))))
(define (merge-supports . v&ss)
(apply lset-union eq? (map v&s-support v&ss)))
(define (v&s-merge v&s1 v&s2)
(let* ((v&s1-value (v&s-value v&s1))
(v&s2-value (v&s-value v&s2))
(value-merge+effects (->effectful (merge v&s1-value v&s2-value))))
(let ((value-merge (effectful-info value-merge+effects))
(value-effects (effectful-effects value-merge+effects)))
(effectful->
(make-effectful
(cond ((eq? value-merge v&s1-value)
(if (implies? v&s2-value value-merge)
;; Confirmation of existing information
(if (more-informative-support? v&s2 v&s1)
v&s2
v&s1)
;; New information is not interesting
v&s1))
((eq? value-merge v&s2-value)
;; New information overrides old information
v&s2)
(else
;; Interesting merge, need both provenances
(supported value-merge
(merge-supports v&s1 v&s2)
(lset-union eq?
(v&s-informants v&s1)
(v&s-informants v&s2)))))
(map (attach-support-to-effect (merge-supports v&s1 v&s2))
value-effects))))))
(define ((attach-support-to-effect support) effect)
((generic-attach-premises effect) support))
(define generic-attach-premises (make-generic-operator 1 'attach-support))
(defhandler generic-attach-premises
(lambda (effect)
(lambda (support)
(make-cell-join-effect
(cell-join-effect-cell1 effect)
(cell-join-effect-cell2 effect)
(generic-flatten ;; TODO Do I need to do this by flattening?
(make-tms ;; TODO Get rid of this forward reference
(supported
(cell-join-effect-control effect)
support))))))
cell-join-effect?)
(defhandler-coercing merge v&s-merge ->contingent)
(define (v&s-equivalent? v&s1 v&s2)
(and (lset= eq? (v&s-support v&s1) (v&s-support v&s2))
(equivalent? (v&s-value v&s1) (v&s-value v&s2))))
(defhandler-coercing equivalent? v&s-equivalent? ->contingent)
(defhandler contradictory?
(lambda (v&s) (contradictory? (v&s-value v&s)))
v&s?)
(define (v&s-> v&s)
(if (nothing? (v&s-value v&s))
nothing
v&s))
(define (v&s-binary-map v&s1 v&s2)
(lambda (f)
(v&s->
(supported
(f (v&s-value v&s1) (v&s-value v&s2))
(merge-supports v&s1 v&s2)))))
(defhandler-coercing binary-map v&s-binary-map ->contingent)
(defhandler generic-unpack
(lambda (v&s function)
(supported
(generic-bind (v&s-value v&s) function)
(v&s-support v&s)))
v&s? any?)
;;; This particular predicate dispatch system doesn't actually do
;;; predicate specificity computations. However, defining the most
;;; general handler first has the desired effect.
(defhandler generic-flatten
(lambda (v&s) v&s)
v&s?)
(defhandler generic-flatten
(lambda (v&s) nothing)
(lambda (thing)
(and (v&s? thing)
(nothing? (v&s-value thing)))))
(defhandler generic-flatten
(lambda (v&s)
(generic-flatten
(supported
(v&s-value (v&s-value v&s))
(merge-supports v&s (v&s-value v&s)))))
(lambda (thing)
(and (v&s? thing) (v&s? (v&s-value thing)))))
propagator/core/contradictions.scm 0000664 0012467 0012467 00000006076 11650627371 016104 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define (tms-merge tms1 tms2)
(let ((candidate (tms-assimilate tms1 tms2)))
(effectful-bind (strongest-consequence candidate)
(lambda (consequence)
(if (not (contradictory? consequence)) ; **
(tms-assimilate candidate consequence)
(make-effectful
(tms-assimilate candidate consequence)
(list (make-nogood-effect
(v&s-support consequence)))))))))
;;; TODO TMS-QUERY is still hopelessly broken. The problem is that
;;; the effect of signaling a contradiction is being deferred from the
;;; point at which the worldview changes to the point at which some
;;; propagator tries to get the result.
(define (tms-query tms)
(let ((answer (strongest-consequence tms)))
(let ((better-tms (tms-assimilate tms answer)))
(if (not (eq? tms better-tms))
(set-tms-values! tms (tms-values better-tms)))
(check-consistent! answer) ; **
answer)))
(define (check-consistent! v&s)
(if (contradictory? v&s)
(process-nogood! (v&s-support v&s))))
#|
;;; Sussman's tentative and unpleasant patch for Micah's bug.
;;; Required change to core/test/dependencies-test.scm.
(define (tms-query tms)
(let ((answer (strongest-consequence tms)))
(let ((better-tms (tms-assimilate tms answer)))
(if (not (eq? tms better-tms))
(set-tms-values! tms (tms-values better-tms)))
(if (contradictory? answer)
(begin (process-nogood! (v&s-support answer))
nothing)
answer))))
|#
;; Will be replaced by process-nogood! in search.scm
(define (process-nogood! nogood)
(abort-process `(contradiction ,nogood)))
(define-structure nogood-effect
nogood)
(defhandler execute-effect
(lambda (nogood-effect)
(if (all-premises-in? (nogood-effect-nogood nogood-effect))
(process-nogood! (nogood-effect-nogood nogood-effect))))
nogood-effect?)
(defhandler generic-attach-premises
(lambda (effect)
(lambda (support)
(make-nogood-effect
(lset-union eq? (nogood-effect-nogood effect) support))))
nogood-effect?)
propagator/core/amb-utils.scm 0000664 0012467 0012467 00000004114 11542731612 014737 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define-propagator (require cell)
((constant #t) cell))
(define require p:require)
(define-propagator (forbid cell)
((constant #f) cell))
(define forbid p:forbid)
(define-propagator-syntax (require-distinct cells)
(for-each-distinct-pair
(lambda (c1 c2)
(forbid (e:eqv? c1 c2)))
cells))
(define-propagator-syntax (one-of . cells)
(let ((output (ensure-cell (car (last-pair cells))))
(inputs (map ensure-cell (except-last-pair cells))))
(cond ((= (length inputs) 2)
(conditional (e:amb) (car inputs) (cadr inputs) output))
((> (length inputs) 2)
(conditional (e:amb) (car inputs)
(apply e:one-of (cdr inputs)) output))
(else
(error "Inadequate choices for one-of"
inputs output)))))
(propagator-constructor! one-of)
(define p:one-of one-of)
(define e:one-of (expression-style-variant one-of))
(define p:amb binary-amb)
(define (e:amb)
(let ((answer (make-named-cell (generate-cell-name))))
(binary-amb answer)
(eq-put! answer 'subexprs '())
answer))
propagator/core/propagators.scm 0000664 0012467 0012467 00000012705 11556130775 015420 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Propagators
;;; A propagator is represented as a Scheme thunk that does that
;;; propagator's job every time the scheduler invokes it. The thunk
;;; presumably reads the contents of some cells when doing its job;
;;; the system needs to know what those cells are, so that it can wake
;;; the propagator up if the contents of those cells change. The
;;; thunk also presumably writes to cells (though it can also create
;;; more network structure if needed), but the system doesn't need to
;;; know anything about that.
(define (propagator neighbors to-do)
(for-each (lambda (cell)
(new-neighbor! cell to-do))
(listify neighbors))
(eq-put! to-do 'propagator #t)
(alert-propagator to-do)
to-do)
(define (propagator? thing)
(eq-get thing 'propagator))
;;;; Propagator constructors
;;; A propagator constructor is a Scheme procedure that can attach
;;; some network structure to supplied cells. These are used during
;;; the build portion of the read-build-run propagator execution
;;; model. To allow for infinite (to wit, dynamically expandable)
;;; networks, run and build can be interleaved.
(define (propagator-constructor? thing)
(or (eq-get thing 'propagator-constructor)
;; TODO This is such a hack! I probably should not represent
;; propagator constructors quite this directly as Scheme
;; procedures...
(and (not (eq-get thing 'not-propagator-constructor))
(procedure? thing)
(not (cell? thing))
(not (propagator? thing))
(not (closure? thing)) ; TODO Forward reference :(
(warn "Imputing propagator-constructor-hood" thing)
#t)))
(define (propagator-constructor! thing)
(eq-put! thing 'propagator-constructor #t)
thing)
;;; Returns a propagator constructor that builds single propagators
;;; that execute the supplied Scheme function.
#;
(define (function->propagator-constructor f)
(lambda cells
(let ((output (ensure-cell (car (last-pair cells))))
(inputs (map ensure-cell (except-last-pair cells))))
(propagator inputs ; The output isn't a neighbor!
(lambda ()
(add-content output
(apply f (map content inputs))))))))
;;; This version has additional metadata to allow the propagator
;;; network to be effectively traversed (see extensions/draw.scm)
(define (function->propagator-constructor f)
(let ((n (name f)))
(define (the-constructor . cells)
(let ((output (ensure-cell (last cells)))
(inputs (map ensure-cell (except-last-pair cells)))
(the-diagram #f))
(define (the-propagator)
(fluid-let ((*active-diagram* the-diagram))
(add-content output
(apply f (map content inputs))
the-propagator)))
(name! the-propagator (if (symbol? n)
(symbol n ':p)
f))
(propagator inputs the-propagator)
(set! the-diagram (make-anonymous-i/o-diagram
the-propagator inputs (list output)))
(register-diagram the-diagram)))
(if (symbol? n) (name! the-constructor (symbol 'p: n)))
(propagator-constructor! the-constructor)))
;;; Returns a version of the supplied propagator constructor that
;;; creates a propagator that will wait until at least one of the
;;; boundary cells has a non-nothing content and then perform the
;;; indicated construction once.
(define (delayed-propagator-constructor prop-ctor)
(eq-clone! prop-ctor
(lambda args
;; TODO Can I autodetect "inputs" that should not trigger
;; construction?
(let ((args (map ensure-cell args))
(answer-diagram #f))
(define the-propagator
(one-shot-propagator
args
(lambda ()
(fluid-let ((register-diagram
(lambda (diagram #!optional name)
(replace-diagram! answer-diagram diagram)
diagram)))
(apply prop-ctor args)))))
;; This is the analogue of (compute-aggregate-metadata
;; prop-ctor args) TODO much work can be saved by use of the
;; diagram made by MAKE-COMPOUND-DIAGRAM.
(set! answer-diagram
(make-diagram-for-compound-constructor
the-propagator prop-ctor args))
(register-diagram answer-diagram)))))
;; This is a peer of PROPAGATOR
(define (one-shot-propagator neighbors action)
(let ((done? #f) (neighbors (map ensure-cell (listify neighbors))))
(define (test)
(if done?
'ok
(if (every nothing? (map content neighbors))
'ok
(begin (set! done? #t)
(action)))))
(propagator neighbors test)))
propagator/core/example-networks.scm 0000664 0012467 0012467 00000010077 11475462442 016363 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;; Example usages of propagator networks
;;; Unidirectional Fahrenheit to Celsius conversion
(define-e:propagator (e:fahrenheit->celsius f)
(e:* (e:- f 32) 5/9))
#|
(initialize-scheduler)
(define-cell f)
(define-cell c)
(p:fahrenheit->celsius f c)
(add-content f 77)
(run)
(content c)
;Value: 25
|#
#|
;;; Here is a much more explicit way to write the same program
(define-propagator (fahrenheit->celsius f c)
(let-cells (thirty-two f-32 five c*9 nine)
((constant 32) thirty-two)
((constant 5) five)
((constant 9) nine)
(p:- f thirty-two f-32)
(p:* f-32 five c*9)
(p:/ c*9 nine c)))
|#
;;; Multidirectional Fahrenheit to Celsius to Kelvin conversion
(define-propagator (c:fahrenheit-celsius f c)
(c:== (ce:+ (ce:* c 9/5) 32) f))
(define-propagator (c:celsius-kelvin c k)
(c:+ c 273.15 k))
#|
(initialize-scheduler)
(define-cell f)
(define-cell c)
(c:fahrenheit-celsius f c)
(add-content c 25)
(run)
(content f)
;Value: 77
(define-cell k)
(c:celsius-kelvin c k)
(run)
(content k)
;Value: 298.15
|#
#|
;;; Same as above, but in diagram style
(define-propagator (fahrenheit-celsius f c)
(let-cells (f-32 c*9)
(c:+ 32 f-32 f)
(c:* f-32 5 c*9)
(c:* c 9 c*9)))
|#
;;; Measuring the height of a building using a barometer
(define-e:propagator (ce:fall-duration t)
(let-cell (g (make-interval 9.789 9.832))
(ce:* 1/2 (ce:* g (ce:square t)))))
#|
(initialize-scheduler)
(define-cell fall-time)
(define-cell building-height)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
;Value: #(interval 41.163 47.243)
|#
;;; In more ways than one
(define-propagator (c:similar-triangles s-ba h-ba s h)
(c:== (ce:* s-ba %% h-ba)
(ce:* s %% h)))
#|
(initialize-scheduler)
(define-cell barometer-height)
(define-cell barometer-shadow)
(define-cell building-height)
(define-cell building-shadow)
(c:similar-triangles barometer-shadow barometer-height
building-shadow building-height)
(add-content building-shadow (make-interval 54.9 55.1))
(add-content barometer-height (make-interval 0.3 0.32))
(add-content barometer-shadow (make-interval 0.36 0.37))
(run)
(content building-height)
;Value: #(interval 44.514 48.978)
(define-cell fall-time)
(c:fall-duration fall-time building-height)
(add-content fall-time (make-interval 2.9 3.1))
(run)
(content building-height)
;Value: #(interval 44.514 47.243)
(content barometer-height)
;Value: #(interval .3 .31839)
;; Refining the (make-interval 0.3 0.32) we put in originally
(content fall-time)
;Value: #(interval 3.0091 3.1)
;; Refining (make-interval 2.9 3.1)
(add-content building-height (make-interval 45 45))
(run)
(content barometer-height)
;Value: #(interval .3 .30328)
(content barometer-shadow)
;Value: #(interval .366 .37)
(content building-shadow)
;Value: #(interval 54.9 55.1)
(content fall-time)
;Value: #(interval 3.0255 3.0322)
|#
;;; More goodies in ../examples/*
propagator/core/generic-definitions.scm 0000664 0012467 0012467 00000010365 11650627371 017002 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; General generic applicative functor machinery
;;; If a group of partial information structures fit into the
;;; applicative functor (TODO: Reference Paterson and McBride)
;;; paradigm, the network can be mechanically extended to handle them
;;; and their compositions.
(define (binary-mapping f)
(define (loop x y)
(let ((mapper (binary-map x y)))
(if (procedure? mapper)
(mapper loop)
(f x y))))
(name! loop f)
loop)
(define binary-map
(make-generic-operator 2 'binary-map
(lambda (x y) 'done!)))
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
nothing? any?)
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
any? nothing?)
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
contradictory? any?)
(defhandler binary-map
(lambda (x y) (lambda (f) nothing))
any? contradictory?)
(define (unary-mapping f)
(name!
(lambda (x)
((binary-mapping (lambda (x y) (f x)))
;; TODO Make this 1 a real "object that can be coerced into anything"
x 1))
f))
(define (nary-mapping f)
(name!
(lambda args
(case (length args)
((0) (f))
((1) ((unary-mapping f) (car args)))
((2) ((binary-mapping f) (car args) (cadr args)))
(else
(let loop ((args '()) (rest args))
(if (null? (cdr rest))
((binary-mapping (lambda (lst item)
(apply f (reverse (cons item lst)))))
args (car rest))
(loop ((binary-mapping cons) (car rest) args) (cdr rest)))))))
f))
;;;; General generic-monadic machinery
;;; If a partial information structure fits into the monad paradigm,
;;; the portions of the network that are necessarily monadic rather
;;; than applicative-functorial can be automatically extended to that
;;; structure. Of course, since monads do not compose naturally, it
;;; is up to the user to effectively treat a group of partial
;;; information structures as forming a single monad where
;;; appropriate, and define corresponding cross-structure methods for
;;; these operations.
;;; TODO Does anything other than IF really need monads?
(define (generic-bind thing function)
(generic-flatten (generic-unpack thing function)))
(define generic-unpack
(make-generic-operator 2 'unpack
(lambda (object function)
(function object))))
(define generic-flatten
(make-generic-operator 1 'flatten (lambda (object) object)))
(define (%nary-unpacking function)
(lambda args
(let loop ((args args)
(function function))
(if (null? args)
(function)
(generic-bind
(car args)
(lambda (arg)
(loop (cdr args)
(lambda remaining-args
(apply function (cons arg remaining-args))))))))))
;; This version also attaches the name information, for debugging and
;; drawing networks.
(define (nary-unpacking function)
(eq-label! (%nary-unpacking function) 'name function))
(defhandler generic-unpack
(lambda (object function) nothing)
nothing? any?)
(defhandler generic-unpack
(lambda (object function) nothing)
contradictory? any?)
;;; This handler is redundant but harmless
(defhandler generic-flatten
(lambda (thing) nothing)
nothing?)
propagator/core/truth-maintenance.scm 0000664 0012467 0012467 00000014425 11544114762 016501 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
#|
;;; This causes real trouble with pretty-printing
(define-structure
(tms (type vector) (named 'tms)
(constructor %make-tms) (print-procedure #f)
(safe-accessors #t))
values)
|#
(define (%make-tms values)
(vector 'tms values))
(define (tms? x)
(and (vector? x) (eq? (vector-ref x 0) 'tms)))
(define (tms-values tms)
(if (not (tms? tms)) (error "Bad tms -- TMS-VALUES" tms))
(vector-ref tms 1))
(define (set-tms-values! tms new-values)
(if (not (tms? tms)) (error "Bad tms -- SET-TMS-VALUES!" tms))
(vector-set! tms 1 new-values))
(define (make-tms arg)
(%make-tms (listify arg)))
;; Will be replaced by tms-merge in contradictions.scm
(define (tms-merge tms1 tms2)
(let ((candidate (tms-assimilate tms1 tms2)))
(effectful-bind (strongest-consequence candidate)
(lambda (consequence)
(tms-assimilate candidate consequence)))))
(define (tms-assimilate tms stuff)
(cond ((nothing? stuff) tms)
((v&s? stuff) (tms-assimilate-one tms stuff))
((tms? stuff)
(fold-left tms-assimilate-one
tms
(tms-values stuff)))
(else (error "This should never happen" stuff))))
(define (subsumes? v&s1 v&s2)
(and (lset<= eq? (v&s-support v&s1) (v&s-support v&s2))
(implies? (v&s-value v&s1) (v&s-value v&s2))))
(define (tms-assimilate-one tms v&s)
(if (any (lambda (old-v&s) (subsumes? old-v&s v&s))
(tms-values tms))
tms
(let ((subsumed
(filter (lambda (old-v&s) (subsumes? v&s old-v&s))
(tms-values tms))))
(make-tms
(lset-adjoin eq?
(lset-difference eq? (tms-values tms) subsumed)
v&s)))))
(define (strongest-consequence tms)
(let ((cached (cached-consequence tms)))
(or cached
(cache-consequence! tms (compute-strongest-consequence tms)))))
(define *consequence-cache* (make-eq-hash-table))
(define (cached-consequence tms)
(let ((answer (hash-table/get *consequence-cache* tms #f)))
(and answer
(= (car answer) *worldview-number*)
(cdr answer))))
(define (cache-consequence! tms consequence)
(hash-table/put! *consequence-cache* tms
;; Caching the data, not the effect (if any)
(cons *worldview-number* (effectful-info (->effectful consequence))))
consequence)
(define (compute-strongest-consequence tms)
(let ((relevant-v&ss
(filter v&s-believed? (tms-values tms))))
(merge* relevant-v&ss)))
(define (v&s-believed? v&s)
(all-premises-in? (v&s-support v&s)))
(define contingency-object-believed? v&s-believed?)
(define (all-premises-in? premise-list)
(every premise-in? premise-list))
(define initialize-scheduler
(let ((initialize-scheduler initialize-scheduler))
(lambda ()
(initialize-scheduler)
(set! *consequence-cache* (make-eq-hash-table)))))
(define with-independent-scheduler
(let ((with-independent-scheduler with-independent-scheduler))
(lambda args
(fluid-let ((*consequence-cache* #f))
(apply with-independent-scheduler args)))))
;; Will be replaced by tms-query in contradictions.scm
(define (tms-query tms)
(let ((answer (strongest-consequence tms)))
(let ((better-tms (tms-assimilate tms answer)))
(if (not (eq? tms better-tms))
(set-tms-values! tms (tms-values better-tms)))
answer)))
(define (kick-out! premise)
(if (premise-in? premise)
(begin
(set! *worldview-number* (+ *worldview-number* 1))
(alert-all-propagators!)))
(mark-premise-out! premise))
(define (bring-in! premise)
(if (not (premise-in? premise))
(begin
(set! *worldview-number* (+ *worldview-number* 1))
(alert-all-propagators!)))
(mark-premise-in! premise))
(defhandler generic-unpack
(lambda (tms function)
(let ((relevant-information (tms-query tms)))
(make-tms (list (generic-bind relevant-information function)))))
tms? any?)
(defhandler generic-flatten
(lambda (tms)
(tms->
(make-tms
(append-map tms-values
(map ->tms
(map generic-flatten (tms-values tms)))))))
tms?)
(defhandler generic-flatten
(lambda (v&s)
(generic-flatten
(make-tms
(generic-flatten
(supported (tms-query (v&s-value v&s))
(v&s-support v&s)
(v&s-informants v&s))))))
(lambda (thing) (and (v&s? thing) (tms? (v&s-value thing)))))
(declare-coercion-target tms
(lambda (thing)
(make-tms (list (->contingent thing)))))
(declare-coercion v&s? ->tms)
(declare-coercion contingent-able? ->tms)
(defhandler ->tms (lambda (nothing) (make-tms '())) nothing?)
(define (tms-equivalent? tms1 tms2)
(lset= v&s-equivalent? (tms-values tms1) (tms-values tms2)))
(defhandler-coercing equivalent? tms-equivalent? ->tms)
(define (the-tms-handler thing1 thing2)
(tms-merge thing1 thing2))
(defhandler-coercing merge the-tms-handler ->tms)
(define (tms-> tms)
(let ((values (filter v&s? (map v&s-> (map ->contingent (tms-values tms))))))
(cond ((null? values)
nothing)
((and (= 1 (length values))
(v&s? (car values))
(null? (v&s-support (car values))))
(v&s-value (car values)))
(else
(make-tms values)))))
(define (tms-binary-map tms1 tms2)
(lambda (f)
(tms-> (make-tms (list (f (tms-query tms1) (tms-query tms2)))))))
(defhandler-coercing binary-map tms-binary-map ->tms)
propagator/core/premises.scm 0000664 0012467 0012467 00000006654 11535447266 014717 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define (hypothetical-printer state object)
(with-current-unparser-state state
(lambda (port)
(write `(hypothetical
,(hash object)
,(hypothetical-sign object)
,(if (premise-in? object) 'in 'out)
,@(name-stack (hypothetical-cell object)))
port))))
(define-structure
(hypothetical (type vector) (named 'hypothetical)
;;(print-procedure #f)
(print-procedure hypothetical-printer)
(safe-accessors #t))
sign
cell)
(define *worldview-number* 0)
(define *premise-outness* (make-eq-hash-table))
(define (premise-in? premise)
(not (hash-table/get *premise-outness* premise #f)))
(define (mark-premise-in! premise)
(hash-table/remove! *premise-outness* premise))
(define (mark-premise-out! premise)
(hash-table/put! *premise-outness* premise #t))
(define *premise-nogoods* (make-eq-hash-table))
(define (premise-nogoods premise)
(hash-table/get *premise-nogoods* premise '()))
(define (set-premise-nogoods! premise nogoods)
(hash-table/put! *premise-nogoods* premise nogoods))
(define (reset-premise-info!)
(set! *worldview-number* 0)
(set! *premise-outness* (make-eq-hash-table))
(set! *premise-nogoods* (make-eq-hash-table)))
;;; We also need to arrange for the premise states to be reset for
;;; every new example. Better creativity having failed me, I will
;;; hang that action onto the initialize-scheduler procedure.
;;; TODO Can one do better than redefining initialize-scheduler?
(define initialize-scheduler
(let ((initialize-scheduler initialize-scheduler))
(lambda ()
(initialize-scheduler)
(reset-premise-info!))))
(define with-independent-scheduler
(let ((with-independent-scheduler with-independent-scheduler))
(lambda args
(fluid-let ((*worldview-number* #f)
(*premise-outness* #f)
(*premise-nogoods* #f))
(apply with-independent-scheduler args)))))
(define (disbelieving-func premise thunk)
(let ((old-belief (premise-in? premise)))
(kick-out! premise)
(let ((answer (thunk)))
(if old-belief
(bring-in! premise)
(kick-out! premise))
answer)))
;; (disbelieving premise body)
;; Syntax that executes the given body in a dynamic environment
;; where the given premise is not believed.
(define-syntax disbelieving
(syntax-rules ()
((_ premise body ...)
(disbelieving-func premise (lambda () body ...)))))
propagator/core/compound-data.scm 0000664 0012467 0012467 00000005357 11436556343 015617 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Compound data
;;; The code for merging compound data turns out not to depend on the
;;; choice between the "copying data" or "carrying cells" strategies
;;; --- those are dependent entirely on what the constructor
;;; and accessor propagators do.
;;; Cons looks like this:
#|
(define (pair-equivalent? pair1 pair2)
(and (equivalent? (car pair1) (car pair2))
(equivalent? (cdr pair1) (cdr pair2))))
(define (pair-merge pair1 pair2)
(effectful-bind (merge (car pair1) (car pair2))
(lambda (car-answer)
(effectful-bind (merge (cdr pair1) (cdr pair2))
(lambda (cdr-answer)
(cons car-answer cdr-answer))))))
(defhandler merge pair-merge pair? pair?)
(defhandler equivalent? pair-equivalent? pair? pair?)
|#
;;; The generalization to arbitrary product types:
(define (slotful-information-type predicate? constructor . accessors)
(define (slotful-equivalent? thing1 thing2)
(apply boolean/and
(map (lambda (accessor)
(equivalent? (accessor thing1) (accessor thing2)))
accessors)))
(define (slotful-merge thing1 thing2)
(let* ((slots1 (map (lambda (accessor) (accessor thing1))
accessors))
(slots2 (map (lambda (accessor) (accessor thing2))
accessors)))
(effectful-list-bind (map merge slots1 slots2)
(lambda (submerges)
(apply constructor submerges)))))
(define (slotful-contradiction? thing)
(any contradictory? (map (lambda (accessor) (accessor thing)) accessors)))
(defhandler merge slotful-merge predicate? predicate?)
(defhandler equivalent? slotful-equivalent? predicate? predicate?)
(defhandler contradictory? slotful-contradiction? predicate?))
(slotful-information-type pair? cons car cdr)
propagator/core/metadata.scm 0000664 0012467 0012467 00000027215 11425610116 014624 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Network Metadata
;;; The purpose of this steaming pile is to allow the collection of
;;; metadata sufficient to traverse and inspect a running propagator
;;; network, for the purpose of debugging it. As an extreme case,
;;; extensions/draw.scm uses the collected metadata to draw pictures
;;; of (small, simple) networks in dot and yFiles.
(define (propagator-inputs propagator)
(or (eq-get propagator 'inputs)
(eq-get propagator 'neighbors)
'()))
(define (propagator-outputs propagator)
(or (eq-get propagator 'outputs)
(eq-get propagator 'neighbors)
'()))
(define (cell-non-readers cell)
(or (eq-get cell 'shadow-connections)
'()))
(define (cell-connections cell)
;; The neighbors are the ones that need to be woken up; the
;; connections are the ones that touch the cell at all. This
;; concept is useful for walking the graph structure of the network.
(append (neighbors cell) (cell-non-readers cell)))
(define-structure (network-group (safe-accessors #t))
elements
names)
(define *current-network-group* #f)
(define (network-group-named name)
(name! (make-network-group '() (make-eq-hash-table)) name))
(define (name-in-group! group thing name)
(hash-table/put! (network-group-names group) thing name)
thing)
(define (name-in-group group thing)
(and group
(hash-table/get (network-group-names group) thing #f)))
(define (network-register thing)
(if (memq thing (network-group-elements *current-network-group*))
'ok
(set-network-group-elements! *current-network-group*
(cons thing (network-group-elements *current-network-group*))))
(eq-put! thing 'network-group *current-network-group*))
(define (network-unregister thing)
(let ((group (network-group-of thing)))
(if group
(set-network-group-elements! group
(delq thing (network-group-elements group)))))
(eq-rem! thing 'network-group))
(define (network-group-of thing)
(eq-get thing 'network-group))
(define (network-group-contains? group thing)
(or (eq? group (network-group-of thing))
(and (network-group-of thing)
(network-group-contains? group (network-group-of thing)))))
(define (in-network-group group thunk)
(if group
(fluid-let ((*current-network-group* group))
(thunk))
(thunk) ;; TODO What should I really do if there is no group?
))
(define (with-network-group group thunk)
(network-register group)
(in-network-group group thunk))
(define (name-locally! thing name)
(name-in-group! *current-network-group* thing name))
(define (local-name thing)
(name-in-group *current-network-group* thing))
(define name
(let ((name name))
(lambda (thing)
(let ((group-name (name-in-group (network-group-of thing) thing)))
(if group-name
(name group-name)
(name thing))))))
(define (clear-network-group thing)
(eq-rem! thing 'shadow-connections 'inputs 'outputs 'network-group)
(if (network-group? thing)
(for-each clear-network-group (network-group-elements thing))))
(define (reset-network-groups!)
(clear-network-group *current-network-group*)
(set! *current-network-group* (network-group-named 'top-group)))
(define initialize-scheduler
(let ((initialize-scheduler initialize-scheduler))
(lambda ()
(initialize-scheduler)
(reset-network-groups!))))
(define with-independent-scheduler
(let ((with-independent-scheduler with-independent-scheduler))
(lambda args
(fluid-let ((*current-network-group* #f))
(apply with-independent-scheduler args)))))
;;; Oof!
;;; TODO Figure out what network-group-expression-substructure is
;;; really doing and refactor it.
(define (network-group-expression-substructure group)
;; Produce the collection of cells, propagators, network groups, and
;; expression network groups that should be visible at this group
;; level. This may involve constructing network groups that
;; represent expressions made with e: constructs, on the logic that
;; the cells they create are implicit, and therefore should be
;; hidden (unless the use explicitly expands the autogenerated
;; expression group that contains them).
(define (should-hide? thing)
(and (cell? thing)
(eq? group (network-group-of thing))
(not (name-in-group group thing))))
(define (should-not-hide? thing)
(and (cell? thing)
(or (not (eq? group (network-group-of thing)))
(name-in-group group thing))))
(define (may-hide? thing)
(and (not (should-hide? thing))
(not (should-not-hide? thing))))
(define (connected? thing1 thing2)
(define (connected-to-cell? cell thing)
(and (cell? cell)
(or (memq thing (cell-connections cell))
(and (network-group? thing)
(any (lambda (conn)
(network-group-contains? thing conn))
(cell-connections cell))))))
(or (connected-to-cell? thing1 thing2)
(connected-to-cell? thing2 thing1)))
(define (make-subgroup elements)
(name!
(make-network-group elements (make-eq-hash-table))
(compute-expression-name elements)))
(define (compute-expression-name elements)
(define functionalized-tags (make-eq-hash-table))
(define (connections-of thing)
(if (cell? thing)
(cell-connections thing)
(filter (lambda (other)
(connected? thing other))
(delete-duplicates
(append (network-group-elements group)
;; TODO Oops! Travesing keys of a weak table!
(hash-table/key-list
(network-group-names group)))))))
(define (functionalized-to thing)
(and (not (cell? thing))
(let ((connections (connections-of thing)))
;; TODO Heuristic, and only works on single-output
;; functionalized things. It wouldn't have worked to
;; just tag them at functionalization time because
;; functionalize sees the propagator constructor, but
;; these things are the constructed propagators.
#;
(pp (list (name thing)
(hash thing)
(map (lambda (c)
(list (name c) (hash c)
(and (eq-get c 'subexprs)
(map (lambda (s)
(list (name s) (hash s)))
(eq-get c 'subexprs)))))
connections)))
(any (lambda (connection)
(and (eq-get connection 'subexprs)
(lset= eq? (eq-get connection 'subexprs)
(delq connection connections))
connection))
connections))))
(define (functionalized-tag! thing)
(let ((target (functionalized-to thing)))
(if target
(hash-table/put! functionalized-tags thing target))))
(define (functionalized? thing)
(memq (hash-table/get functionalized-tags thing #f)
elements))
(define (functionalized-to-me cell)
(and (cell? cell)
(find (lambda (thing)
(eq? cell (hash-table/get functionalized-tags thing #f)))
elements)))
(for-each functionalized-tag! elements)
#; (pp (hash-table->alist functionalized-tags))
(let loop ((head (find (lambda (thing)
(and (not (cell? thing))
(not (functionalized? thing))))
elements)))
#; (pp `(,(name head) ,(hash head)))
(if (cell? head)
(if (and (memq head elements)
(eq-get head 'subexprs))
(cons (name (functionalized-to-me head))
(map loop (eq-get head 'subexprs)))
(name-in-group group head))
(cons (name head) (map loop (lset-intersection eq?
(connections-of head)
elements))))))
(let loop ((target-subgroups
(map list (filter should-hide?
(network-group-elements group))))
(hidable-elements
(map list (filter may-hide?
(network-group-elements group))))
(shown-elements
(filter should-not-hide? (network-group-elements group))))
(define (find-pair-to-merge)
(let per-subgroup ((subgroups target-subgroups))
(if (null? subgroups)
#f
(let per-element ((elements (car subgroups)))
(if (null? elements)
(per-subgroup (cdr subgroups))
(let ()
(define (wanted? pile)
(any (lambda (thing)
(connected? (car elements) thing))
pile))
(cond ((find wanted? (cdr subgroups)) =>
(lambda (wanted-subgroup)
(cons elements wanted-subgroup)))
((find wanted? hidable-elements) =>
(lambda (wanted-subgroup)
(cons elements wanted-subgroup)))
(else (per-element (cdr elements))))))))))
(let ((pair-to-merge (find-pair-to-merge)))
(if pair-to-merge
(loop (cons (delete-duplicates
;; I don't get why I need this delete-duplicates,
;; but without it the substructure mysteriously
;; repeats elements.
(append (car pair-to-merge)
(cdr pair-to-merge)))
(delq (car pair-to-merge)
(delq (cdr pair-to-merge)
target-subgroups)))
(delq (car pair-to-merge)
(delq (cdr pair-to-merge)
hidable-elements))
shown-elements)
(append (map make-subgroup target-subgroups)
(map car hidable-elements)
shown-elements)))))
;;; Stuff for automatically determining the i/o characteristics of a
;;; compound box by expanding it out (in a sandbox) and looking at the
;;; i/o characteristics of its structure.
(define *interesting-cells* #f)
(define (compute-aggregate-metadata prop-ctor arg-cells)
;; This check is here to keep recursive compounds from computing
;; their internal metadata forever. The reason this is ok is that
;; to learn the metadata of an unexpanded box, I only need to
;; observe what propagators want to attach to its interior boundary,
;; not to the entire interior.
(if (or (not *interesting-cells*)
(not (null? (lset-intersection eq?
*interesting-cells* arg-cells))))
(do-compute-aggregate-metadata prop-ctor arg-cells)
'()))
(define (do-compute-aggregate-metadata prop-ctor arg-cells)
;; Assumes the prop-ctor is stateless!
(with-independent-scheduler
(lambda ()
(let ((test-cell-map (map (lambda (arg)
(cons arg (make-cell)))
arg-cells)))
(fluid-let ((*interesting-cells* (map cdr test-cell-map)))
(apply prop-ctor (map cdr test-cell-map)))
(let* ((the-props (all-propagators))
(inputs (apply append (map (lambda (prop)
(or (eq-get prop 'inputs)
'()))
the-props)))
(outputs (apply append (map (lambda (prop)
(or (eq-get prop 'outputs)
'()))
the-props)))
(my-inputs (map car
(filter (lambda (arg-test)
(memq (cdr arg-test) inputs))
test-cell-map)))
(my-outputs (map car
(filter (lambda (arg-test)
(memq (cdr arg-test) outputs))
test-cell-map)))
(constructed-objects ;; Should only be one
(filter (lambda (x) (not (cell? x)))
(network-group-elements *current-network-group*))))
`(name ,(name (car constructed-objects))
inputs ,my-inputs outputs ,my-outputs))))))
propagator/core/standard-propagators.scm 0000664 0012467 0012467 00000021200 11553130603 017167 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Standard primitive propagators
(define (p:constant value)
(function->propagator-constructor #; (lambda () value)
(eq-label! (lambda () value) 'name `(constant ,(name value)))))
(define (e:constant value)
(let ((answer (make-named-cell 'cell)))
((constant value) answer)
(eq-put! answer 'subexprs '())
answer))
(propagatify abs)
(propagatify square)
(propagatify sqrt)
(propagatify not)
(propagatify negate)
(propagatify invert)
(propagatify sin)
(propagatify cos)
(propagatify tan)
(propagatify asin)
(propagatify acos)
(propagatify exp)
(propagatify log)
(propagatify +)
(propagatify -)
;;;(propagatify *) ;See below, to make more sophisticated version
;;;(propagatify /) ;See below, to make more sophisticated version
;;;(propagatify =) ;See below, to support floating comparisons...
(propagatify <)
(propagatify >)
(propagatify <=)
(propagatify >=)
(propagatify atan2)
; see ../support/utils for num=?
(define generic-= (make-generic-operator 2 '= default-equal?))
(define-cell p:=
(function->propagator-constructor (binary-mapping generic-=)))
(define-cell e:= (expression-style-variant p:=))
;; Not using propagatify because the name AND names syntax, and I want
;; the procedure BOOLEAN/AND. Also, see more sophisticated version
;; below.
(define generic-and (make-generic-operator 2 'and boolean/and))
(define-cell p:and-dumb
(function->propagator-constructor (binary-mapping generic-and)))
(define-cell e:and-dumb (expression-style-variant p:and-dumb))
(define generic-or (make-generic-operator 2 'or boolean/or))
(define-cell p:or-dumb
(function->propagator-constructor (binary-mapping generic-or)))
(define-cell e:or-dumb (expression-style-variant p:or-dumb))
;;; DNA is to AND as division is to multiplication
(define (boolean/dna c x)
(if (and (not c) x) #f nothing))
(define generic-dna (make-generic-operator 2 'dna boolean/dna))
(define-cell p:dna
(function->propagator-constructor (binary-mapping generic-dna)))
(define-cell e:dna
(expression-style-variant p:dna))
(define (boolean/imp a) (if a #t nothing))
(define generic-imp (make-generic-operator 1 'imp boolean/imp))
(define-cell p:imp
(function->propagator-constructor (unary-mapping generic-imp)))
(define-cell e:imp
(expression-style-variant p:imp))
;;; RO is to OR as division is to multiplication
(define (boolean/ro c x)
(if (and c (not x)) #t nothing))
(define generic-ro (make-generic-operator 2 'ro boolean/ro))
(define-cell p:ro
(function->propagator-constructor (binary-mapping generic-ro)))
(define-cell e:ro
(expression-style-variant p:ro))
(define (boolean/pmi a) (if (not a) #f nothing))
(define generic-pmi (make-generic-operator 1 'pmi boolean/pmi))
(define-cell p:pmi
(function->propagator-constructor (unary-mapping generic-pmi)))
(define-cell e:pmi
(expression-style-variant p:pmi))
(propagatify eq?)
(propagatify eqv?)
(propagatify expt)
;; I want a name for the function that does the switch job
(define (switch control input)
(if control input nothing))
(define switch-function switch)
(propagatify switch)
(name! identity 'identity)
; These two are almost the same, but the difference doesn't matter
(define-cell p:id (function->propagator-constructor identity))
; (define-cell p:id (function->propagator-constructor (nary-mapping identity)))
(define-cell e:id (expression-style-variant p:id))
(define same identity)
(propagatify same)
;; TODO Do I still want to provide these old names for these things?
(define constant p:constant) (define switch p:switch)
;;;; Standard compound propagators
(define-propagator (conditional control if-true if-false output)
(switch control if-true output)
(switch (e:not control) if-false output))
(define-propagator (conditional-router control input if-true if-false)
(switch control input if-true)
(switch (e:not control) input if-false))
(define-propagator (conditional-wire control end1 end2)
(switch control end1 end2)
(switch control end2 end1))
(define conditional p:conditional)
(define conditional-router p:conditional-router)
(define conditional-wire p:conditional-wire)
;;; Clever Propagators that know about short cuts.
(define-propagator (p:or p1 p2 p)
(p:or-dumb p1 p2 p)
;; Short cuts
(p:imp p1 p)
(p:imp p2 p))
(define-propagator (p:and p1 p2 p)
(p:and-dumb p1 p2 p)
;; Short cuts
(p:pmi p1 p)
(p:pmi p2 p))
(define generic-* (make-generic-operator 2 '* *))
(define-cell p:*-dumb
(function->propagator-constructor (binary-mapping generic-*)))
(define-cell e:*-dumb (expression-style-variant p:*-dumb))
(define-propagator (p:* m1 m2 product)
(p:*-dumb m1 m2 product)
;; Short cuts
(p:switch (e:= m1 0) m1 product)
(p:switch (e:= m2 0) m2 product))
(define generic-/ (make-generic-operator 2 '/ /))
(define (numerical-zero? x) (and (number? x) (zero? x)))
(declare-explicit-guard numerical-zero? (guard zero?))
(define (binary-nothing a b) nothing)
(defhandler generic-/ binary-nothing numerical-zero? numerical-zero?)
(define (numerical-non-zero? x) (and (number? x) (not (zero? x))))
(declare-explicit-guard numerical-non-zero? (guard numerical-non-zero?))
(define (binary-contradiction a b) the-contradiction)
(defhandler generic-/ binary-contradiction
numerical-non-zero? numerical-zero?)
(define-cell p:/-dumb
(function->propagator-constructor (binary-mapping generic-/)))
(define-cell e:/-dumb (expression-style-variant p:/-dumb))
(define-propagator (p:/ product m1 m2)
(p:/-dumb product m1 m2)
;; Short cut
(p:switch (e:and (e:= product 0)
(e:not (e:= m1 0)))
product m2))
;;; Constraining propagators
(define-propagator (c:+ a1 a2 sum)
(p:+ a1 a2 sum) (p:- sum a1 a2) (p:- sum a2 a1))
;; This generates a useful ce:-
(define-propagator (c:- sum a1 a2)
(c:+ a1 a2 sum))
(define-propagator (c:* m1 m2 product)
(p:* m1 m2 product) (p:/ product m1 m2) (p:/ product m2 m1))
;; This generates a useful ce:/
(define-propagator (c:/ product m1 m2)
(c:* m1 m2 product))
(define-propagator (c:square x x^2)
(p:square x x^2) (p:sqrt x^2 x))
;; This generates a useful ce:sqrt
(define-propagator (c:sqrt x^2 x)
(p:square x x^2) (p:sqrt x^2 x))
(define-propagator (c:not p1 p2)
(p:not p1 p2) (p:not p2 p1))
(define-propagator (c:and p1 p2 p)
(p:and p1 p2 p)
(p:dna p p1 p2)
(p:dna p p2 p1)
(p:imp p p1)
(p:imp p p2))
(define-propagator (c:or p1 p2 p)
(p:or p1 p2 p)
(p:ro p p1 p2)
(p:ro p p2 p1)
(p:pmi p p1)
(p:pmi p p2))
(define-propagator (c:id c1 c2)
(p:id c1 c2) (p:id c2 c1))
(define-propagator (c:same c1 c2)
(p:same c1 c2) (p:same c2 c1))
(define-cell p:==
(propagator-constructor!
(lambda args
(let ((target (car (last-pair args))))
(for-each (lambda (arg)
(p:id arg target))
(except-last-pair args))
target))))
(define-cell e:== (expression-style-variant p:==))
(define-cell c:==
(propagator-constructor!
(lambda args
(let ((lead (car args)))
(for-each (lambda (arg)
(c:id lead arg))
(cdr args))
lead))))
(define-cell ce:== (expression-style-variant c:==))
(define-propagator (c:negate x y)
(p:negate x y)
(p:negate y x))
(define-propagator (c:invert x y)
(p:invert x y)
(p:invert y x))
(define-propagator (c:sin x y)
(p:sin x y)
(p:asin y x))
(define-propagator (c:cos x y)
(p:cos x y)
(p:acos y x))
(define-propagator (c:tan x y)
(p:tan x y)
(p:atan2 y 1 x))
(define-propagator (c:exp x y)
(p:exp x y)
(p:log y x))
(define-propagator (c:eq? a b truth)
(p:eq? a b truth)
(conditional-wire truth a b))
(define-propagator (c:eqv? a b truth)
(p:eqv? a b truth)
(conditional-wire truth a b))
propagator/core/application.scm 0000664 0012467 0012467 00000031712 11654330224 015347 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Applying the contents of cells
;;; APPLICATION is to the propagator world what APPLY is to Scheme.
;;; Just as putting a Scheme variable into operator position produces
;;; a call to APPLY, putting a cell into operator position produces a
;;; call to APPLICATION. APPLICATION is a distinguished propagator
;;; constructor that collects a propagator constructor from a cell
;;; and invokes it on argument cells.
;;; The propagator constructors found in cells may either be
;;; primitive, as defined for example by
;;; FUNCTION->PROPAGATOR-CONSTRUCTOR, or may be closures, per the
;;; closure data structure in physical-closures.scm. That distinction
;;; is the same as the distinction between primitive and compound
;;; Scheme procedures.
;;; The important thing for APPLICATION to deal with, which is new to
;;; the propagator world and is not found in Scheme, is the fact that
;;; the available information about the propagator constructor being
;;; applied may be partial; and that the propagator created by
;;; APPLICATION needs to be properly idempotent, because it may be
;;; called multiple times as that partial information is refined.
;;; This is done by making the transfer of information across the call
;;; boundary conditional on the propagator constructor being applied,
;;; with the effect that both the arguments and the return values
;;; inherit any partialness of that particular propagator constructor.
;;; APPLICATION is the locus of a nontrivial optimization: if the cell
;;; containing the object to be applied is fully determined at network
;;; construction time, the appropriate propagator can be extracted
;;; therefrom and attached immediately, without creating an additional
;;; propagator whose only job would be to pull it out and apply it.
;;; There is also a linguistic matter that APPLICATION needs to deal
;;; with, that doesn't happen in Scheme. This matter is the
;;; distinction between diagram-style and expression-style propagator
;;; constructors:
;;; The most general propagator notation supplies all the input and
;;; output cells to the desired propagator constructor explicitly:
;;; (p:+ x y subtotal)
;;; (p:+ subtotal z total)
;;; This "diagram style" notation is very flexible, because it
;;; allows easy handling of multiple propagators writing to the same
;;; cells, propagators having multiple output cells, having cells that
;;; are ambiguous as to input vs output, etc.
;;; A nested expression notation can be very convenient for simple
;;; cases, however, because it allows the outputs of one propagator to
;;; be piped directly into the inputs to another, without even naming
;;; the intermediate value:
;;; (e:+ (e:+ x y) z)
;;; APPLICATION comes in the user-callable flavors d@ and e@, which
;;; force diagram-style or expression-style application, respectively.
;;; The native APPLICATION will respect the preferred style of the
;;; propagator being applied if that propagator is completely
;;; determined at network-construction time; otherwise it defaults to
;;; diagram-style.
(define (application object . arg-cells)
(try-eager-application object
(lambda (object)
(if (prefers-diagram-style? object)
(eager-diagram-apply object arg-cells)
(eager-expression-apply object arg-cells)))
(lambda (cell)
(general-propagator-apply cell arg-cells))))
;;; General application
(define (general-propagator-apply prop-cell arg-cells)
(define done-props '())
(define (done? prop)
(member prop done-props equivalent-closures?))
(define (arg-copier pass?)
(lambda (arg)
(let-cell arg-copy
(conditional-wire pass? (ensure-cell arg) arg-copy)
arg-copy)))
;; This assumes that closures are "carrying cells" compound
;; structures rather than "copying data".
(define (apply-diagram-style prop pass? arg-cells)
(do-apply-prop prop (map (arg-copier pass?) arg-cells)))
(define (apply-expression-style prop pass? arg-cells)
(let ((input-cells (except-last-pair arg-cells))
(output-cell (car (last-pair arg-cells))))
(conditional-wire pass? output-cell
(ensure-cell
(do-apply-prop
prop (map (arg-copier pass?) input-cells))))))
(define (attach prop)
(set! done-props (cons prop done-props))
(let-cells (pass? key)
(add-content key prop)
(p:equivalent-closures? prop-cell key pass?)
(if (diagram-style? prop)
(apply-diagram-style prop pass? arg-cells)
(apply-expression-style prop pass? arg-cells))
unspecific))
(let ((the-propagator
(lambda ()
((unary-mapping
(lambda (prop)
(if (done? prop)
unspecific
(attach prop))))
(content prop-cell)))))
(name! the-propagator 'application)
(propagator prop-cell the-propagator)
(register-diagram
(make-anonymous-i/o-diagram
the-propagator (list prop-cell) arg-cells))))
;;; Eager application of objects that are fully known at network
;;; construction time.
(define (eager-diagram-apply prop arg-cells)
(if (diagram-style? prop)
(do-apply-prop prop arg-cells)
(handle-explicit-output arg-cells
(lambda (inputs)
(do-apply-prop prop inputs)))))
(define (eager-expression-apply prop arg-cells)
(if (diagram-style? prop)
(handle-implicit-cells arg-cells
(lambda (boundary)
(do-apply-prop prop boundary)))
(if (any implicit-cell? arg-cells)
(handle-implicit-cells arg-cells
(lambda (boundary)
(handle-explicit-output boundary
(lambda (inputs)
(do-apply-prop prop inputs)))))
(do-apply-prop prop arg-cells))))
(define (directly-applicable? thing)
(or (closure? thing)
(propagator-constructor? thing)))
(define (try-eager-application object direct-apply general-apply)
(if (cell? object)
(if (directly-applicable? (content object))
(direct-apply (content object))
(general-apply object))
(if (directly-applicable? object)
(direct-apply object)
(general-apply (ensure-cell object)))))
;;; Massaging boundary shapes
;;; Propagators can be defined either in diagram style (with explicit
;;; cells for their entire boundary) or in expression style (where the
;;; body of the propagator is expected to return one additional cell,
;;; which is in the boundary implicitly). Propagators can also be
;;; applied in diagram style or in expression style. So a mismatch
;;; can occur if a propagator is defined one way and applied the other
;;; way. The procedure HANDLE-EXPLICIT-OUTPUT applies a diagram-style
;;; application to a procedure that expects to be applied in
;;; expression style, and the procedure HANDLE-IMPLICIT-CELLS applies
;;; an expression-style application to a procedure that expects to be
;;; applied in diagram style. HANDLE-IMPLICIT-CELLS is hairy because
;;; expression-style applications support the %% syntax for selecting
;;; the position of the implicit cell in the supplied argument list,
;;; and because I felt like having it support expression-style
;;; applications that want to return multiple implicit cells.
(define (handle-explicit-output boundary proc)
(c:== (car (last-pair boundary))
(proc (except-last-pair boundary))))
(define generate-cell-name
(let ((cell-counter 0))
(lambda ()
(set! cell-counter (+ cell-counter 1))
(symbol 'cell cell-counter))))
(define (handle-implicit-cells inputs proc #!optional num-outputs)
(if (default-object? num-outputs)
(set! num-outputs 1))
(define (manufacture-cell)
(eq-put! (make-named-cell (generate-cell-name)) 'subexprs inputs))
(define outputs (map (lambda (k) (manufacture-cell))
(iota num-outputs)))
(define true-inputs
(let loop ((inputs inputs)
(outputs outputs))
(cond ((null? inputs)
outputs)
((implicit-cell? (car inputs))
(if (null? outputs)
(error "Too many implicit cells" inputs)
(cons (car outputs)
(loop (cdr inputs) (cdr outputs)))))
(else
(cons (car inputs) (loop (cdr inputs) outputs))))))
(proc (map ensure-cell true-inputs))
(if (= 1 (length outputs))
(car outputs)
(apply values outputs)))
(define %% (list 'the-implicit-cell))
(define (implicit-cell? thing)
(eq? thing %%))
(name! %% '%%)
;;; User-facing frontend for forcing application style
(define (p:application object . arg-cells)
(try-eager-application object
(lambda (object)
(eager-diagram-apply object arg-cells))
(lambda (cell)
(general-propagator-apply cell arg-cells))))
(define (functionalize propagator #!optional num-outputs)
(propagator-constructor!
(eq-label!
(lambda inputs
(handle-implicit-cells inputs
(lambda (boundary)
(apply propagator boundary))
num-outputs))
'expression-style #t
'preferred-style 'expression)))
(define e:application (functionalize p:application))
(define d@ p:application)
(define @d d@)
(define e@ e:application)
(define @e e@)
;;; Guts of applying things
(define (do-apply-prop prop real-args)
(let ((real-args (map ensure-cell real-args)))
(cond ((closure? prop)
((if (diagram-style? prop)
diagram-style-with-diagram
expression-style-with-diagram)
(empty-diagram-cell prop)
(lambda ()
(apply (closure-code prop) real-args))))
((propagator-constructor? prop)
(apply prop real-args))
(else (error "Not an applicable propagator" thing)))))
(define (diagram-style-with-diagram target-diagram-cell thunk)
(let ((explicit-diagram #f)
(target-diagram-cell
(fluid-let ((register-diagram (diagram-inserter *metadiagram*)))
(ensure-cell target-diagram-cell))))
(register-diagram
(fluid-let
((register-diagram (diagram-cell-inserter target-diagram-cell))
(diagram
(lambda args
(let ((answer (apply make-compound-diagram args)))
(set! explicit-diagram answer)
answer))))
(thunk)
(or explicit-diagram
;; But the content hasn't updated yet!
(compute-derived-promises! (content target-diagram-cell)))))))
#|
(define (expression-style-with-diagram target-diagram-cell thunk)
(let ((target-diagram-cell
(let ((register-diagram (diagram-inserter *metadiagram*)))
(ensure-cell target-diagram-cell))))
(fluid-let
((register-diagram (diagram-cell-inserter target-diagram-cell)))
(let ((answer (thunk)))
(register-diagram
(compute-derived-promises! (content target-diagram-cell)))
answer))))
|#
;;; Previous version led to circular structure.
(define (expression-style-with-diagram target-diagram-cell thunk)
(let ((target-diagram-cell
(fluid-let ((register-diagram (diagram-inserter *metadiagram*)))
(ensure-cell target-diagram-cell))))
(let ((answer
(fluid-let
((register-diagram (diagram-cell-inserter target-diagram-cell)))
(let ((answer (thunk)))
;; But the content hasn't updated yet!
(compute-derived-promises! (content target-diagram-cell))
answer))))
(register-diagram (content target-diagram-cell))
answer)))
(define (diagram-style? thing)
(cond ((closure? thing)
(closure-diagram-style? thing))
((propagator-constructor? thing)
(not (eq-get thing 'expression-style)))
(else (error "Propagator style question not applicable" thing))))
;;; Preferred application styles
(define (prefers-diagram-style? thing)
(let ((preference-tag (eq-get thing 'preferred-style)))
(cond (preference-tag
(not (eq? preference-tag 'expression)))
((closure? thing)
(closure-diagram-style? thing))
(else #t))))
(define ((tag-preferred-style style) thing)
(cond ((cell? thing)
(let ((answer (make-cell)))
(eq-clone! thing answer)
(add-content answer ((tag-preferred-style style) (content thing)))
answer))
((propagator-constructor? thing)
(let ((answer (lambda args (apply thing args))))
(eq-clone! thing answer)
(eq-put! answer 'preferred-style style)
answer))
((closure? thing)
(eq-put! (closure-copy thing) 'preferred-style style))
(else
(warn "Ignoring" thing)
thing)))
(define (diagram-style-variant thing)
(ensure-cell ((tag-preferred-style 'diagram) thing)))
(define (expression-style-variant thing)
(ensure-cell ((tag-preferred-style 'expression) thing)))
propagator/core/cells.scm 0000664 0012467 0012467 00000024054 11657020262 014150 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Merging
;;; My original thought was that merge answers the question:
;;;
;;; "What is the least-commitment information structure that captures
;;; all the knowledge in these two information structures?"
;;;
;;; That was a pretty good place to start, but it turns out not to be
;;; quite adequate. What's the problem with it, you might ask? The
;;; problem is that this question cannot have any side-effects. But
;;; side-effects appear necessary: when merging two TMSes, one must
;;; check the result for consistency, and maybe signal a nogood set if
;;; one discovers a supported contradiction. Worse, the
;;; carrying-cells strategy for compound data means that you might
;;; have to merge cells, and the only way to do that is to attach
;;; identity propagators between them, which is most definitely an
;;; effect.
;;;
;;; After long thought, I understand that the real question that a
;;; cell asks (whether or not "merge" is a good name for the function
;;; that computes the answer) is:
;;;
;;; "What do I need to do to the network in order to make it reflect
;;; the discovery that these two information structures are about the
;;; same object?"
;;;
;;; In the common case, the answer to this question is going to amount
;;; to just an answer to the previous question, namely "You must
;;; record that that object is best described by this information
;;; structure, which is the least-commitment information structure
;;; that captures all the knowledge in the given information
;;; structures." (That "you must record" is the set! in add-content).
;;; Also consistent with the simpler idea is the answer "These two
;;; information structures cannot describe the same object." (This is
;;; the contradictory? test in add-content.) However, this refined
;;; question provides the opening for more nuanced answers. For
;;; example, with TMSes, it becomes possible to answer "The object is
;;; described by the following information structure, and you should
;;; record the following nogood set." Or, with carrying cells, the
;;; answer can be "The object is described by the following
;;; information structure, and you should identify these two cells."
;;;
;;; The advantage of thinking about it this way is that merge can be a
;;; pure function, which is allowed to return requests for these
;;; effects in addition to refined information structures. Then places
;;; where merge is called recursively have a chance to intercept and
;;; modify these requests for effects (for example noting that they
;;; must be considered conditional on certain premises), and only
;;; add-content actually executes the effects that come to it.
;;;; Propagator cells
(define (%make-cell merge) ; message-accepter style
(let ((neighbors '()) (content nothing)
(whoiam #f) (history '())
(probe #f))
(define (add-content increment informant)
(let ((info+effects (->effectful (merge content increment))))
(let ((effects (effectful-effects info+effects))
(new-content (effectful-info info+effects)))
(if probe (probe))
(cond ((eq? new-content content) 'ok)
((contradictory? new-content)
(error "Ack! Inconsistency!"
(name-stack whoiam) increment)
'this-is-not-a-tail-call)
(else
(set! content new-content)
;; A debugging aid.
(augment-history! whoiam informant new-content
history
(lambda (new)
(set! history new)))
(alert-propagators neighbors)))
(for-each execute-effect effects))))
(define (new-neighbor! new-neighbor)
(if (not (memq new-neighbor neighbors))
(begin
(set! neighbors (cons new-neighbor neighbors))
(alert-propagators new-neighbor))))
(define (me message)
(cond ((eq? message 'content) content)
((eq? message 'add-content) add-content)
((eq? message 'neighbors) neighbors)
((eq? message 'new-neighbor!) new-neighbor!)
((eq? message 'iam!)
(lambda (who)
(if whoiam (error "Psychotic cell!" who whoiam))
(set! whoiam who)))
((eq? message 'who?) whoiam)
((eq? message 'history) history)
;; See ui.scm for probes.
((eq? message 'probe!) (lambda (p) (set! probe p)))
((eq? message 'unprobe!) (set! probe #f))
(else (error "Unknown message" message))))
me))
(define (make-cell #!optional merger)
(define me
(make-entity
(lambda (self . args)
(apply application self args))
(%make-cell
(if (default-object? merger) ;Sussman's crock escape hatch.
merge
merger))))
(eq-put! me 'cell #t)
(((entity-extra me) 'iam!) me)
(register-diagram me)
me)
(define (content cell)
((entity-extra cell) 'content))
(define (add-content cell increment #!optional informant)
(((entity-extra cell) 'add-content) increment informant))
(define (neighbors cell)
((entity-extra cell) 'neighbors))
(define (new-neighbor! cell neighbor)
(((entity-extra cell) 'new-neighbor!) neighbor))
(define (who? cell)
((entity-extra cell) 'who?))
(define (history cell)
((entity-extra cell) 'history))
(define (cell? thing)
(eq-get thing 'cell))
;;; Default history collector collects the most recent informant only
(define (augment-history! cell informant new-content old-history permission-to-set)
(permission-to-set `(,informant ,new-content)))
(define (make-named-cell name)
(name! (make-cell) name))
(define *ensure-cell-generates-constant-propagators* #f)
(define (ensure-cell thing)
(if (cell? thing)
thing
(if *ensure-cell-generates-constant-propagators*
;; TODO Retain forward reference to e:constant? Copy the code?
(let ((answer (e:constant thing)))
(add-content answer thing) ; Enables early access
answer)
(let ((answer (make-named-cell (name thing))))
(add-content answer thing)
answer))))
;;;; Cellular Generics
(define (merge info1 info2)
(if (equivalent? info1 info2)
info1
(let ((answer (generic-merge info1 info2)))
(cond ((effectful? answer) answer)
((equivalent? answer info1) info1)
((equivalent? answer info2) info2)
(else answer)))))
(define generic-merge
(make-generic-operator 2 'merge
(lambda (content increment)
(if (default-equal? content increment)
content
the-contradiction))))
(set-operator-record! merge (get-operator-record generic-merge))
(define (equivalent? info1 info2)
(or (eqv? info1 info2)
(generic-equivalent? info1 info2)))
(define generic-equivalent?
(make-generic-operator 2 'equivalent? default-equal?))
(set-operator-record! equivalent? (get-operator-record generic-equivalent?))
(define the-contradiction #(*the-contradiction*))
(define contradictory?
(make-generic-operator 1 'contradictory?
(lambda (thing) (eq? thing the-contradiction))))
(define execute-effect
(make-generic-operator 1 'execute-effect (lambda (effect) (effect))))
;;; Merging utilities
(define (implies? v1 v2)
;; This is right on the assumption that trivial effects are squeezed
;; out (for example by using effectful->).
(eq? v1 (merge v1 v2)))
;;; This is the n-ary merge
(define (merge* infos-list)
(fold-left effectful-merge nothing infos-list))
;;; The nothing partial information structure
(define nothing #(*the-nothing*))
(define (nothing? thing)
(eq? thing nothing))
(defhandler merge
(lambda (content increment) content)
any? nothing?)
(defhandler merge
(lambda (content increment) increment)
nothing? any?)
;;;; Cells as partial information
(define (equivalent-cells? cell1 cell2)
(or (eq? cell1 cell2)
(let ((candidate-bridge-control (eq-get cell1 cell2)))
(and candidate-bridge-control
(equivalent? #t (content candidate-bridge-control))))))
(defhandler equivalent? equivalent-cells? cell? cell?)
(define (cell-merge cell1 cell2)
(effectful->
(make-effectful
cell1
(list (make-cell-join-effect cell1 cell2 #t)))))
(defhandler merge cell-merge cell? cell?)
;;; Cell joining effects
(define-structure cell-join-effect
cell1
cell2
control)
(define (execute-cell-join effect)
(let ((cell1 (cell-join-effect-cell1 effect))
(cell2 (cell-join-effect-cell2 effect))
(control-info (cell-join-effect-control effect)))
(let ((control (the-bridge-control cell1 cell2)))
(add-content control control-info))))
(defhandler execute-effect
execute-cell-join
cell-join-effect?)
(define (the-bridge-control cell1 cell2)
(let ((candidate (eq-get cell1 cell2)))
(or candidate
(let ((control (make-named-cell 'bridge-control)))
;; TODO Think about whether this really needs to be
;; symmetric
(switch control cell1 cell2)
(switch control cell2 cell1)
(eq-put! cell1 cell2 control)
(eq-put! cell2 cell1 control)
control))))
(define (boring-cell-join? effect)
(let ((cell1 (cell-join-effect-cell1 effect))
(cell2 (cell-join-effect-cell2 effect))
(control-info (cell-join-effect-control effect)))
(or (eq? cell1 cell2)
(let ((candidate (eq-get cell1 cell2)))
(and candidate
(implies? (content candidate)
control-info))))))
(defhandler redundant-effect? boring-cell-join? cell-join-effect?)
propagator/core/sugar.scm 0000664 0012467 0012467 00000036207 11653601341 014171 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Carcinogens for the semicolon part 2: Defining propagators
;;; Here be macros that provide syntactic sugar for playing with the
;;; propagator language as embedded in Scheme. Syntactic regularities
;;; in patterns of definition of propagator constructors are captured.
;;;; Paired propagator definitions
;;; Propagator objects are usually defined in pairs, one preferring to
;;; be applied diagram-style, and one preferring to be applied
;;; expression-style. These two macros define such pairs of
;;; propagator objects, with the given names. Said names are
;;; presumably computed by PROPAGATOR-NAMING-CONVENTION, below
(define-syntax define-by-diagram-variant
(syntax-rules ()
((define-by-diagram-variant (diagram-name expression-name) form)
(begin
(define-cell diagram-name form)
(define-cell expression-name
(expression-style-variant diagram-name))))))
(define-syntax define-by-expression-variant
(syntax-rules ()
((define-by-diagram-variant (diagram-name expression-name) form)
(begin
(define-cell expression-name form)
(define-cell diagram-name
(diagram-style-variant expression-name))))))
;;;; Propagator naming convention
;;; The naming convention is:
;;; p:foo the propagator version of foo
;;; e:foo the expression-style variant of p:foo
;;; c:foo the constraint-propagator version of foo
;;; ce:foo the expression-style variant of c:foo
;;; For convenience, this convention includes constraint-propagator
;;; versions of the various propagators. The procedure
;;; PROPAGATOR-NAMING-CONVENTION is a macro-helper; it constructs a
;;; pair of names derived from the given name, one to name the
;;; diagram-style variant and one to name the expression-style
;;; variant. This is calibrated for use with
;;; DEFINE-BY-DIAGRAM-VARIANT and DEFINE-BY-EXPRESSION-VARIANT, above.
(define (propagator-naming-convention name)
(let* ((name-string (symbol->string name))
(long-named? (and (>= (string-length name-string) 3)
(equal? "ce:" (substring name-string 0 3))))
(propagator-named?
(and (>= (string-length name-string) 2)
(or (equal? "p:" (substring name-string 0 2))
(equal? "e:" (substring name-string 0 2)))))
(constraint-named?
(and (>= (string-length name-string) 2)
(or (equal? "c:" (substring name-string 0 2))
long-named?)))
(prefix-length
(cond (long-named? 3)
((or constraint-named? propagator-named?) 2)
(else 0)))
(base-name (string-tail name-string prefix-length)))
(if constraint-named?
(list (symbol 'c: base-name)
(symbol 'ce: base-name))
(list (symbol 'p: base-name)
(symbol 'e: base-name)))))
;;;; Defining primitive propagators
;;; The PROPAGATIFY macro automates the process of defining extensible
;;; propagators whose basic operations are Scheme procedures.
;;; FUNCTION->PROPAGATOR-CONSTRUCTOR turns Scheme procedures into
;;; propagator constructors (that make primitive propagators). In
;;; principle, that's good enough; but two things can be done to make
;;; the resulting propagator easier to extend to different partial
;;; information structures. First, a generic operation can be defined
;;; and second, the nary-mapping wrapper from generic-definitions.scm
;;; can be applied. Finally, to complete the definition, an
;;; expression version of the propagator constructor is usually
;;; defined. PROPAGATIFY does these things:
;;; (propagatify +)
;;; is equivalent to
;;; (define generic-+ (make-generic-operator 2 '+ +))
;;; (define-cell p:+
;;; (function->propagator-constructor (nary-mapping generic-+)))
;;; (define-cell e:+ (expression-style-variant p:+))
;;; Note that the generic machinery needs to know the arity of the
;;; generic operation to define. PROPAGATIFY will make an educated
;;; guess for what that arity should be, but an explicit second
;;; argument can be supplied to fix the arity. In addition, if the
;;; second argument is present but is not an arity, PROPAGATIFY will
;;; interpret that as a request not to define the generic procedure at
;;; all. So
;;; (propagatify + 'no-generic)
;;; would be equivalent to
;;; (define-cell p:+ (function->propagator-constructor (nary-mapping +)))
;;; (define-cell e:+ (expression-style-variant p:+))
;;; Finally, sometimes it is appropriate to propagatify a Scheme
;;; procedure directly, without any provision for extensibility. The
;;; PROPAGATIFY-RAW macro is helpful for this.
;;; (propagatify-raw +)
;;; would be equivalent to
;;; (define-cell p:+ (function->propagator-constructor +))
;;; (define-cell e:+ (expression-style-variant p:+)
;;; Compare (propagatify + 'no-generic).
(define-syntax propagatify-raw
(rsc-macro-transformer
(lambda (form defn-env)
(let* ((propagatee-name (cadr form)))
`(define-by-diagram-variant
,(propagator-naming-convention propagatee-name)
(function->propagator-constructor
(name! ,propagatee-name ',propagatee-name)))))))
(define-syntax propagatify
(rsc-macro-transformer
(lambda (form defn-env)
(let* ((propagatee-name (cadr form))
(generic-name (symbol 'generic- propagatee-name)))
`(begin
(define ,generic-name
(make-arity-detecting-operator
',propagatee-name ,propagatee-name ,@(cddr form)))
(define-by-diagram-variant
,(propagator-naming-convention propagatee-name)
(function->propagator-constructor
(nary-mapping ,generic-name))))))))
(define (make-arity-detecting-operator
name default-operation #!optional arity)
(if (default-object? arity)
(set! arity (procedure-arity default-operation)))
;; The generic machinery only likes fixed arity operations; assume
;; that a fully variadic input operation is really the associative
;; version of a binary one, and the binary one will do for
;; extensibility.
(cond ((not (procedure-arity? arity))
;; This allows the user to explictly prevent the construction
;; of the generic operation by specifying a bogus arity for
;; it.
default-operation)
((eqv? (procedure-arity-min arity)
(procedure-arity-max arity))
(make-generic-operator arity name default-operation))
((and (or (eqv? 0 (procedure-arity-min arity))
(eqv? 1 (procedure-arity-min arity)))
(eqv? #f (procedure-arity-max arity)))
(make-generic-operator 2 name default-operation))
(else default-operation)))
;;; This is throwback to days of yore, when I still thought that
;;; monads were a good idea. This is just like PROPAGATIFY, except
;;; that it wraps the propagatee in NARY-UNPACKING instead of
;;; NARY-MAPPING.
(define-syntax propagatify-monadic
(sc-macro-transformer
(lambda (form use-env)
(let* ((propagatee-name (cadr form))
(generic-name (symbol 'generic- propagatee-name))
(propagatee (close-syntax propagatee-name use-env)))
`(begin
(define ,generic-name
(make-arity-detecting-operator
',propagatee-name ,propagatee ,@(cddr form)))
(define-by-diagram-variant
,(propagator-naming-convention propagatee-name)
(function->propagator-constructor
(nary-unpacking ,generic-name))))))))
;;;; Defining "propagator macros"
;;; Scheme is the macro language of this embedded propagator system.
;;; Therefore defining "propagator macros" is just a matter of
;;; defining Scheme procedures. Some patterns are common, however, so
;;; merit a little macro support.
;;; DEFINE-PROPAGATOR-SYNTAX is (meant to be) just like define, except
;;; that it wraps the body being defined in a DIAGRAM-STYLE-WITH-DIAGRAM
;;; which is a hook for tagging all cells and propagators created
;;; inside the call with a common identity, which can then be passed
;;; on to the graph drawing tools used to inspect the network.
;;; DEFINE-PROPAGATOR-SYNTAX also assigns the formal parameter names
;;; as names to the incoming arguments. The latter is most useful in
;;; the regime where all the passed arguments are actually cells (as
;;; opposed to, say, Scheme-lists of cells).
(define-syntax define-propagator-syntax
(syntax-rules ()
((define-propagator-syntax (name arg-form ...) body-form ...)
(define name
(named-propagator-syntax (name arg-form ...)
body-form ...)))
;; N.B. This is the clause that will match dot-notation argument lists
((define-propagator-syntax name body-form ...)
(define name
(expression-style-with-diagram (empty-diagram-cell 'name)
(lambda ()
body-form ...))))))
;;; This is the "lambda" to define-propagator-syntax's "define".
(define-syntax named-propagator-syntax
(syntax-rules ()
((named-propagator-syntax (name arg-form ...) body-form ...)
(propagator-constructor!
(named-lambda (name arg-form ...)
(expression-style-with-diagram (empty-diagram-cell 'name)
(lambda ()
(register-diagram arg-form 'arg-form) ...
body-form ...)))))))
;;;; Defining compound propagators
;;; DEFINE-PROPAGATOR is to the propagator language what DEFINE is to
;;; Scheme. These macros make closures --- see physical-closures.scm.
;;; This one defines propagators in diagram style --- that is, all
;;; boundary cells are explicitly named.
(define-syntax define-propagator
(rsc-macro-transformer
(lambda (form defn-env)
(let ((name (caadr form))
(formals (cdadr form))
(body (cddr form)))
`(define-%propagator ,(propagator-naming-convention name)
,formals ,@body)))))
(define-syntax define-d:propagator define-propagator)
(define-syntax define-%propagator
(syntax-rules ()
((define-%propagator names (arg ...)
body ...)
(define-by-diagram-variant names
(name!
(lambda-d:propagator (arg ...)
body ...)
(car 'names))))))
(define-syntax lambda-d:propagator
(syntax-rules (import)
((lambda-d:propagator (arg ...)
(import cell ...)
body ...)
(make-closure
(naming-lambda (arg ...)
body ...)
(list cell ...)))
((lambda-d:propagator (arg ...)
body ...)
(lambda-d:propagator (arg ...)
(import)
body ...))))
;;; This is a convenience for defining closures (with make-closure)
;;; that track the Scheme names given to the incoming cells.
(define-syntax naming-lambda
(syntax-rules ()
((naming-lambda (arg-form ...) body-form ...)
(lambda (arg-form ...)
(register-diagram arg-form 'arg-form) ...
body-form ...))))
;;; DEFINE-E:PROPAGATOR is just like DEFINE-PROPAGATOR, except that
;;; there is one more implicit boundary cell, which is expected to be
;;; returned by the last form in the body being defined.
(define-syntax define-e:propagator
(rsc-macro-transformer
(lambda (form defn-env)
(let ((name (caadr form))
(formals (cdadr form))
(body (cddr form)))
`(define-%e:propagator ,(propagator-naming-convention name)
,formals ,@body)))))
(define-syntax define-%e:propagator
(syntax-rules ()
((define-%e:propagator names (arg ...)
body ...)
(define-by-expression-variant names
(name!
(lambda-e:propagator (arg ...)
body ...)
(cadr 'names))))))
(define-syntax lambda-e:propagator
(syntax-rules (import)
((lambda-e:propagator (arg ...)
(import cell ...)
body ...)
(make-e:closure
(naming-lambda (arg ...)
body ...)
(list cell ...)))
((lambda-e:propagator (arg ...)
body ...)
(lambda-e:propagator (arg ...)
(import)
body ...))))
;;; TODO I need variable arity propagator constructors; this can
;;; be taken from the story for compound data.
;;; TODO Here's an idea: maybe the arguments to the Scheme
;;; procedures produced by define-propagator and company should
;;; be optional. If any are not supplied, that procedure can just
;;; generate them. It may also be fun to standardize on a mechanism
;;; like E:INSPECTABLE-OBJECT and THE from the circuits exploration
;;; for reaching in and grabbing such cells from the outside.
;;; TODO Consider rewriting p:when and company in terms of
;;; constructing and applying closures that correspond to the bodies
;;; of the branches. Then the introduction of switches becomes
;;; automatic, and the possible zero-inputs bug is avoided.
#;
(define-syntax p:when
(syntax-rules ()
((p:when (shieldee ...) conditional body ...)
(let-cells ((shieldee (e:conditional-wire conditional shieldee)) ...)
((delayed-propagator-constructor
(lambda (shieldee ...)
body ...))
shieldee ...)))))
(define-syntax p:when
(syntax-rules ()
((p:when (shieldee ...) conditional body ...)
(application
(e:conditional-wire conditional
(make-closure
(delayed-propagator-constructor
(lambda (shieldee ...)
body ...))
(list)))
shieldee ...))))
(define-syntax p:unless
(syntax-rules ()
((p:unless shieldees conditional stuff ...)
(p:when shieldees (e:not conditional) stuff ...))))
(define-syntax p:if
(syntax-rules ()
((p:if shieldees conditional consequent alternate)
(let-cell (conditional-value conditional)
(p:when shieldees conditional-value consequent)
(p:unless shieldees conditional-value alternate)))))
#;
(define-syntax e:when
(syntax-rules ()
((e:when (shieldee ...) conditional body ...)
(let-cells ((shieldee (e:conditional-wire conditional shieldee)) ...)
(let-cell output
((delayed-propagator-constructor
(lambda boundary
(handle-explicit-output boundary
(lambda (args)
(apply
(lambda (shieldee ...)
body ...)
args)))))
shieldee ... output)
(e:conditional-wire conditional output))))))
(define-syntax e:when
(syntax-rules ()
((e:when (shieldee ...) conditional body ...)
(e:application
(e:conditional-wire conditional
(make-closure
(delayed-propagator-constructor
(lambda boundary
(handle-explicit-output boundary
(lambda (args)
(apply
(lambda (shieldee ...)
body ...)
args)))))
(list)))
shieldee ...))))
(define-syntax e:unless
(syntax-rules ()
((e:unless shieldees conditional stuff ...)
(e:when shieldees (e:not conditional) stuff ...))))
(define-syntax e:if
(syntax-rules ()
((e:if shieldees conditional consequent alternate)
(let-cell (conditional-value conditional)
(ce:== (e:when shieldees conditional-value consequent)
(e:unless shieldees conditional-value alternate))))))
propagator/core/physical-closures.scm 0000664 0012467 0012467 00000012166 11433066264 016524 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Closures, physical-copies style
;;; A normal propagator constructor in the physical copies style is a
;;; Scheme procedure that, when given some cells, will build some
;;; quantity of network structure onto those cells. As stated, these
;;; are expected not to be closed (in Scheme) over anything
;;; interesting.
;;; A closure in the physical copies style is a propagator constructor
;;; that may be closed over some cells, together with an explicit list
;;; of those cells. The list needs to be explicit because in order to
;;; merge closures, I have to merge the cells they are closed over.
;;; (Cell merging is such that the underlying Scheme closures that
;;; implement the propagator construction do not need to be modified
;;; when this happens).
;;; Requiring physical-copies closures to close only over cells
;;; amounts to specifying the "carrying cells" strategy for compound
;;; data, at least with regard to closures. This feels like the right
;;; thing; but in principle there is no reason to insist on it. To do
;;; "copying data", MAKE-CLOSURE would need to construct a propagator
;;; that would rebuild the closure every time any of the cells the
;;; environment grabs experienced any changes, and APPLICATION, below,
;;; would need to be adjusted accordingly (how, exactly?) All this
;;; would be perfectly plausible, with the same pros and cons as the
;;; regular "carrying" vs "copying" debate. Note that the actual
;;; closure data structure, except for MAKE-CLOSURE, is completely
;;; independent of the carrying vs copying choice, just like the
;;; actual partial information type definition for CONS.
;;; The code-tag field is a hack to let me detect "equality" between
;;; two Scheme closures that have the same code but are closed over
;;; different cells. Such are the moral equivalent of identical data
;;; structures with different contents, and so are mergeable; whereas
;;; Scheme closures with different code are like data structures of
;;; different types and so are not mergeable.
(define-structure
(closure (constructor %make-closure) (safe-accessors #t))
code
environment
diagram-style?)
(define (closure-code-tag thing)
(procedure-lambda (closure-code thing)))
(define (closure-copy closure)
(eq-clone! closure
(%make-closure (closure-code closure)
(closure-environment closure)
(closure-diagram-style? closure))))
;; The ensure-cell here makes these be "carrying cells" structures.
(define (make-closure code environment)
(name-closure!
(%make-closure code (map ensure-cell environment) #t)))
(define (make-e:closure code environment)
(name-closure!
(%make-closure code (map ensure-cell environment) #f)))
(define (name-closure! closure)
(cond ((eq-get closure 'name) closure) ; ok
((eq-get (closure-code closure) 'name)
(name! closure (closure-code closure)))
((symbol? (closure-code-tag closure))
(name! closure (closure-code-tag closure)))
(else ; nothing works
closure)))
(define (same-code? closure1 closure2)
(and (eq? (closure-code-tag closure1) (closure-code-tag closure2))
(eqv? (closure-diagram-style? closure1)
(closure-diagram-style? closure2))))
(define (closure-merge closure1 closure2)
(if (not (same-code? closure1 closure2))
the-contradiction
(effectful-bind (merge (closure-environment closure1)
(closure-environment closure2))
(lambda (new-env)
(%make-closure
(closure-code closure1)
new-env
(closure-diagram-style? closure1))))))
(define (equivalent-closures? closure1 closure2)
(or (eqv? closure1 closure2)
(and (closure? closure1)
(closure? closure2)
(eq? (closure-code-tag closure1) (closure-code-tag closure2))
(equivalent? (closure-environment closure1)
(closure-environment closure2)))))
(define (contradictory-closure? closure)
(contradictory? (closure-environment closure)))
(defhandler merge closure-merge closure? closure?)
(defhandler equivalent? equivalent-closures? closure? closure?)
(defhandler contradictory? contradictory-closure? closure?)
(initialize-scheduler) ; propagatify makes cells!
(propagatify equivalent-closures?)
propagator/core/merge-effects.scm 0000664 0012467 0012467 00000005744 11432307221 015561 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;; Data structure to represent a merge result that may have effects.
(define-structure effectful
info
effects)
(define (effectful-return info)
(make-effectful info '()))
(define (->effectful thing)
(if (effectful? thing)
thing
(effectful-return thing)))
(define (effectful-> effectful)
(let ((effectful (remove-redundant-effects effectful)))
(if (null? (effectful-effects effectful))
(effectful-info effectful)
effectful)))
(define (remove-redundant-effects effectful)
(make-effectful
(effectful-info effectful)
(filter (lambda (effect)
(not (redundant-effect? effect)))
(effectful-effects effectful))))
(define redundant-effect?
(make-generic-operator 1 'redundant-effect? (lambda (thing) #f)))
(define (effectful-flatten effectful)
(let ((subeffectful (->effectful (effectful-info effectful))))
(let ((subinfo (effectful-info subeffectful))
(subeffects (effectful-effects subeffectful))
(effects (effectful-effects effectful)))
(make-effectful subinfo (append effects subeffects)))))
(define (effectful-merge e1 e2)
(let ((e1 (->effectful e1))
(e2 (->effectful e2)))
(let ((info-merge (->effectful (merge (effectful-info e1)
(effectful-info e2)))))
(effectful->
(make-effectful
(effectful-info info-merge)
(append (effectful-effects e1)
(effectful-effects info-merge)
(effectful-effects e2)))))))
(define (effectful-bind effectful func)
(let ((effectful (->effectful effectful)))
(effectful->
(effectful-flatten
(make-effectful
(->effectful (func (effectful-info effectful)))
(effectful-effects effectful))))))
(define (effectful-list-bind effectfuls func)
(let ((effectfuls (map ->effectful effectfuls)))
(effectful->
(effectful-flatten
(make-effectful
(->effectful (func (map effectful-info effectfuls)))
(apply append (map effectful-effects effectfuls)))))))
propagator/core/ui.scm 0000664 0012467 0012467 00000020627 11552064052 013464 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
;;; Some nice user interface code, to be improved.
(declare (usual-integrations make-cell cell?))
;;; This removes those annoying hash numbers after ;Value:
(set! repl:write-result-hash-numbers? #f)
;;; Make for nice transcripts.
(define (cpp x)
(display "#|\n")
(pp x)
(display "|#\n"))
;;; This is part of paranoid programming.
(define (assert p #!optional error-comment irritant)
(if (not p)
(begin
(if (not (default-object? irritant))
(pp irritant))
(error
(if (default-object? error-comment)
"Failed assertion"
error-comment)))))
;;; This is required because (run) returns old value if there is
;;; nothing to do. This is a problem if a contradiction is resolved
;;; by a kick-out! with no propagation.
(define (tell! cell information . premises)
(assert (cell? cell) "Can only tell something to a cell.")
(set! *last-value-of-run* 'done)
(add-content cell
(make-tms
(contingent information premises)))
(run))
(define (retract! premise)
(set! *last-value-of-run* 'done)
(kick-out! premise)
(run))
(define (assert! premise)
(set! *last-value-of-run* 'done)
(bring-in! premise)
(run))
(define (inquire cell)
(assert (cell? cell) "Can only inquire of a cell.")
(let ((v (run)))
(if (not (eq? v 'done)) (write-line v)))
(list (name-of cell)
'has
(tms-query (->tms (content cell)))))
(define (name-of thing)
(let ((n (eq-get thing 'given-name)))
(if n
(let ((n (if (list? n) (map name-of n) n))
(p (eq-get thing 'parent)))
(if p
(cons n (name-of p))
(list n)))
(list (name thing)))))
;;; For debugging purposes
(define (probe! cell thunk)
;; thunk = (lambda () (lambda (cell) ...))
(define (the-probe)
((thunk) cell))
((cell 'probe!) thunk))
(define (unprobe! cell)
(cell 'unprobe))
#|
;;; Superseded by explain.scm
(define (explain cell)
(assert (cell? cell) "Can only explain a cell.")
(let ((mark (make-eq-hash-table)))
(define (explain-cell cell c)
`(,(name-of cell)
has-value ,(v&s-value c)
,@(let ((infs (v&s-informants c)))
(if (null? infs)
'()
(cons 'by
(map (lambda (inf)
(if (symbol? inf)
(list inf)
(cons (name-of inf)
(map name-of
(eq-get inf 'inputs)))))
infs))))
,@(if (null? (v&s-support c))
'()
(cons 'with-premises (v&s-support c)))))
(define (explain cell)
(let ((seen (hash-table/get mark cell #f)))
(if (not seen)
(let* ((c (tms-query (->tms (content cell))))
(infs (v&s-informants c)))
(hash-table/put! mark cell #t)
(cons (explain-cell cell c)
(append-map
(lambda (inf)
(if (symbol? inf)
'()
(append-map explain
(eq-get inf 'inputs))))
infs)))
'())))
(explain cell)))
|#
#|
;;;; A Small Financial Example
;;; First, we need a small database mechanism
;;; Parent and child here do not refer to biological
;;; things, but rather the relationships of parts
;;; of a database.
(define (add-branch! parent child name)
(eq-put! parent name child)
(eq-put! child 'parent parent)
(eq-put! child 'given-name name)
'done)
;;; e.g. (thing-of Gaggle-salary gross-income Ben)
(define (thing-of name-path)
(let lp ((path name-path))
(cond ((= (length path) 1) (car path))
(else
(eq-get (lp (cdr path))
(car path))))))
;;; A financial entity has three cells
(define (make-financial-entity entity)
(eq-put! entity 'kind-of-entity 'financial)
(let-cells (gross-income expenses net-income)
(add-branch! entity gross-income 'gross-income)
(add-branch! entity net-income 'net-income)
(add-branch! entity expenses 'expenses)
(c:+ expenses net-income gross-income)
'done
))
(define (financial-entity? thing)
(eq? (eq-get thing 'kind-of-entity) 'financial))
(define (gross-income entity)
(assert (financial-entity? entity))
(eq-get entity 'gross-income))
(define (net-income entity)
(assert (financial-entity? entity))
(eq-get entity 'net-income))
(define (expenses entity)
(assert (financial-entity? entity))
(eq-get entity 'expenses))
(define (breakdown sum-node . part-names)
(for-each (lambda (part-name)
(let-cell part
(add-branch! sum-node part part-name)))
part-names)
(cond ((= (length part-names) 2)
(c:+ (eq-get sum-node (car part-names))
(eq-get sum-node (cadr part-names))
sum-node)
'done)
(else
(error "I don't know how to sum multiple parts"))))
(define (combine-financial-entities compound . parts)
(assert (every financial-entity? parts))
(cond ((= (length parts) 2)
(let ((p1 (car parts)) (p2 (cadr parts)))
(c:+ (gross-income p1) (gross-income p2) (gross-income compound))
(c:+ (net-income p1) (net-income p2) (net-income compound))
(c:+ (expenses p1) (expenses p2) (expenses compound))
'done))
(else
(error "I don't know how to combine multiple parts"))))
#|
(initialize-scheduler)
(make-financial-entity 'Alyssa)
(make-financial-entity 'Ben)
;;; Ben and Alyssa are married
(make-financial-entity 'Ben-Alyssa)
(combine-financial-entities 'Ben-Alyssa 'Ben 'Alyssa)
;;; Ben and Alyssa file income tax jointly
(tell! (gross-income 'Ben-Alyssa) 427000 'IRS)
;;; Ben works at Gaggle as a software engineer.
(breakdown (gross-income 'Ben) 'Gaggle-salary 'investments)
;;; He gets paid alot to make good apps.
(tell! (thing-of '(Gaggle-salary gross-income Ben)) 200000 'Gaggle)
;;; Alyssa works as a PhD biochemist in big pharma.
(breakdown (gross-income 'Alyssa) 'GeneScam-salary 'investments)
;;; Biochemists are paid poorly.
(tell! (thing-of '(GeneScam-salary gross-income Alyssa)) 70000 'GeneScam)
(tell! (thing-of '(investments gross-income Alyssa))
(make-interval 30000 40000) 'Alyssa)
(cpp (inquire (thing-of '(investments gross-income Ben))))
#|
((investments gross-income ben)
has
#(value=#[interval 117000 127000], premises=(gaggle genescam alyssa irs), informants=((-:p gross-income part))))
|#
;;; Ben is a tightwad
(tell! (thing-of '(expenses Ben)) (make-interval 10000 20000) 'Ben)
(cpp (inquire (thing-of '(net-income Ben))))
#|
((net-income ben)
has
#(value=#[interval 297000 317000], premises=(ben genescam alyssa irs), informants=((-:p gross-income expenses))))
|#
;;; But Alyssa is not cheap. She likes luxury.
(tell! (thing-of '(expenses Alyssa)) (make-interval 200000 215000) 'Alyssa)
(cpp (inquire (thing-of '(net-income Alyssa))))
#|
((net-income alyssa)
has
#(value=#[interval -115000 -90000], premises=(alyssa genescam), informants=((-:p gross-income expenses))))
|#
;;; But they are doing OK anyway!
(cpp (inquire (thing-of '(net-income Ben-Alyssa))))
#|
((net-income ben-alyssa)
has
#(value=#[interval 192000 217000], premises=(ben alyssa irs), informants=((-:p gross-income expenses))))
|#
;;; Notice that this conclusion does not depend on the details, such
;;; as Gaggle or GeneScam!
(cpp (explain (thing-of '(net-income Ben-Alyssa))))
#|
(((net-income ben-alyssa) has-value #[interval 192000 217000] by ((-:p) (gross-income ben-alyssa) (expenses ben-alyssa)) with-premises ben alyssa irs)
((gross-income ben-alyssa) has-value 427000 by (user) with-premises irs)
((expenses ben-alyssa) has-value #[interval 210000 235000] by ((+:p) (expenses ben) (expenses alyssa)) with-premises alyssa ben)
((expenses ben) has-value #[interval 10000 20000] by (user) with-premises ben)
((expenses alyssa) has-value #[interval 200000 215000] by (user) with-premises alyssa))
|#
|#
|# propagator/core/cell-sugar.scm 0000664 0012467 0012467 00000014317 11555634625 015120 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Carcinogens for the semicolon part 1: Defining cells
;;; Here be macros that provide syntactic sugar for playing with the
;;; propagator language as embedded in Scheme. Syntactic regularities
;;; in patterns of definition of cells are captured.
;; (define-cell foo form)
;; is the same as
;; (define foo (ensure-cell form))
;; except it grabs the name foo and associates it with the
;; cell that form constructs.
;;
;; For the frequent case when you want a fresh cell
;; (define-cell foo)
;; expands into
;; (define-cell foo (make-named-cell 'foo))
;; The metadata is then available two ways.
(define-syntax define-cell
(syntax-rules ()
((define-cell symbol form)
(define symbol (register-diagram (ensure-cell form) 'symbol)))
((define-cell symbol)
(define-cell symbol (make-named-cell 'symbol)))))
;; (let-cells ((foo foo-form)
;; (bar bar-form)
;; (baz baz-form))
;; stuff)
;; is the same as
;; (let ((foo (ensure-cell foo-form))
;; (bar (ensure-cell bar-form))
;; (baz (ensure-cell baz-form)))
;; stuff)
;; except that it captures the names foo bar and baz and associates
;; them with the cells that the corresponding forms return.
;;
;; For the frequent case when you want fresh cells
;; (let-cells (foo bar baz)
;; stuff)
;; expands into
;; (let-cells ((foo (make-named-cell 'foo))
;; (bar (make-named-cell 'bar))
;; (baz (make-named-cell 'baz)))
;; stuff)
;; The metadata is then available two ways.
;; The following would suffice for the above:
#;
(define-syntax let-cells
(syntax-rules ()
((let-cells ((name form) ...)
form ...)
(let ((name (register-diagram (ensure-cell form) 'name)) ...)
form ...))
((let-cells (name ...)
form ...)
(let-cells ((name (make-named-cell 'name))...)
form ...))))
;; The much more horrible LET-CELLS macro below allows the two use
;; patterns above to mix, as follows,
;; (let-cells ((foo foo-form)
;; bar
;; (baz baz-form))
;; stuff)
;; and have the right thing happen. It also interprets the
;; slightly more traditional
;; (let-cells ((foo foo-form)
;; (bar)
;; (baz baz-form))
;; stuff)
;; in agreement with Scheme's let.
(define-syntax let-cells
(syntax-rules ()
((let-cells (cell-binding ...)
form ...)
(normalize-let-clauses let-cells
(cell-binding ...)
()
form ...))
((let-cells "done"
((cell-name cell-form) ...)
form ...)
(let ((cell-name (register-diagram (ensure-cell cell-form) 'cell-name)) ...)
form ...))))
(define-syntax normalize-let-clauses
(syntax-rules ()
((normalize-let-clauses let-form
((cell-name cell-form) clause ...)
(done-clause ...)
form ...)
(normalize-let-clauses let-form
(clause ...)
((cell-name cell-form) done-clause ...)
form ...))
((normalize-let-clauses let-form
((cell-name) clause ...)
(done-clause ...)
form ...)
(normalize-let-clauses let-form
(cell-name clause ...)
(done-clause ...)
form ...))
((normalize-let-clauses let-form
(cell-name clause ...)
(done-clause ...)
form ...)
(normalize-let-clauses let-form
(clause ...)
((cell-name (make-named-cell 'cell-name)) done-clause ...)
form ...))
((normalize-let-clauses let-form
()
done-clauses
form ...)
(let-form "done" done-clauses
form ...))))
;; let-cell is a grammatical convenience if there is only one cell.
;; (let-cell (foo foo-form) stuff) and (let-cell foo stuff) are both
;; ok and equivalent to (let-cells ((foo foo-form)) stuff) and
;; (let-cells (foo) stuff), respectively, but less awkward to read.
(define-syntax let-cell
(syntax-rules ()
((let-cell cell-binding
form ...)
(let-cells (cell-binding)
form ...))))
;; And here is the moral equivalent of let*
(define-syntax let-cells*
(syntax-rules ()
((let-cells* (binding bindings ...)
form ...)
(let-cell binding
(let-cells* (bindings ...)
form ...)))
((let-cells* ()
form ...)
(let-cells ()
form ...))))
;; Here is the moral equivalent of letrec, with the same hairy clause
;; processing as let. This is actually nicer than Scheme letrec,
;; because "uninitialized" cells have a perfectly good initial state:
;; they contain nothing. So names introduced by let-cells-rec can be
;; used in defining forms for those same names directly, without
;; having to insist on an intervening delaying form the way Scheme's
;; letrec does. In a sense, the cells themselves are the needed
;; delaying form.
(define-syntax let-cells-rec
(syntax-rules ()
((let-cells-rec (cell-binding ...)
form ...)
(normalize-let-clauses let-cells-rec
(cell-binding ...)
()
form ...))
((let-cells-rec "done"
((cell-name cell-form) ...)
form ...)
(let-cells (cell-name ...)
(c:id cell-name cell-form) ...
form ...))))
(define-syntax let-cell-rec
(syntax-rules ()
((let-cell-rec cell-binding
form ...)
(let-cells-rec (cell-binding)
form ...))))
propagator/core/test-utils.scm 0000664 0012467 0012467 00000003621 11423656175 015171 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009-2010 Alexey Radul.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define-method generic-match ((pattern ) (object rtd:effectful))
(generic-match
pattern
(vector 'effectful (effectful-info object)
(effectful-effects object))))
;;; Test slotful structure
(define-structure (kons (constructor kons))
kar
kdr)
(declare-type-tester kons? rtd:kons)
(slotful-information-type kons? kons kons-kar kons-kdr)
(define-method generic-match ((pattern ) (object rtd:kons))
(generic-match
pattern
(vector 'kons (kons-kar object) (kons-kdr object))))
(define-method generic-match ((pattern ) (object rtd:%interval))
(generic-match
pattern
(vector 'interval (interval-low object) (interval-high object))))
(define-method generic-match ((pattern ) (object rtd:nogood-effect))
(generic-match
pattern
(vector 'nogood-effect (nogood-effect-nogood object))))
propagator/core/carrying-cells.scm 0000664 0012467 0012467 00000014345 11555637571 016004 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;;; Propagators implementing the carrying cells strategy
;;; for compound data structures.
;;; CONS looks like this:
#;
(define (p:cons a-cell d-cell output)
((constant (cons a-cell d-cell)) output))
;;; The general version for arbitrary constructors:
(define (function->cell-carrier-constructor f)
(propagator-constructor!
(lambda cells
(let ((output (ensure-cell (car (last-pair cells))))
(inputs (map ensure-cell (except-last-pair cells))))
(let ((answer-diagram ((constant (apply f inputs)) output)))
(execute-propagator ; To enable the early-access-hack below
(diagram-identity
answer-diagram))
answer-diagram)))))
;;; Type testers like pair? are just normal propagators.
;;; Accessors are just constructors in reverse, like this:
#;
(define-propagator (p:car pair-cell output)
(p:cons output nothing pair-cell))
;;; Expression-style accessors offer an opportunity for a performance
;;; hack: if the cell holding the accessed item is already present in
;;; the compound when the accessor propagator is constructed (and no
;;; partialness of information intervenes), then it's ok to just grab
;;; that cell and return it. The version for CAR looks like this:
#|
(define (e:carry-car pair-cell)
(if (and (cell? pair-cell)
(pair? (content pair-cell))
(cell? (car (content pair-cell))))
(car (content pair-cell))
(%e:carry-car pair-cell)))
|#
;;; The general version looks like this:
(define (early-access-hack type? accessor fallback)
(propagator-constructor!
(lambda (structure-cell)
(if (and (cell? structure-cell)
(type? (content structure-cell))
(cell? (accessor (content structure-cell))))
(accessor (content structure-cell))
(fallback structure-cell)))))
;;; To actually define those propagators, you would write
#|
(define-cell p:cons (function->cell-carrier-constructor cons))
(define-cell e:cons (expression-style-variant p:cons))
(propagatify pair?)
(define-propagator (p:car pair-cell output)
(p:cons output nothing pair-cell))
(define-propagator (p:cdr pair-cell output)
(p:cons nothing output pair-cell))
(define-cell e:car (early-access-hack pair? car e:car))
(define-cell e:cdr (early-access-hack pair? cdr e:cdr))
|#
;;; That's what the define-propagator-structure macro is for.
(define-syntax define-structure-propagators
(rsc-macro-transformer
(lambda (form defn-env)
(let* ((type-name (cadr form))
(constructor-name (caddr form))
(defined-constructor-names
(propagator-naming-convention constructor-name))
(accessor-names (cdddr form))
(accessor-count (length accessor-names)))
(define (attach-% name)
(symbol '% name))
(define (accessor-definition hidden-name name index)
(define (output-reference)
(let ((answer (make-vector accessor-count 'nothing)))
(vector-set! answer index 'output)
(vector->list answer)))
`(define-propagator (,hidden-name structure-cell output)
(,(car defined-constructor-names)
,@(output-reference)
structure-cell)))
(define (early-access-hack-definition hidden-name name)
(let ((expression-variant (cadr (propagator-naming-convention name))))
`(define-cell ,expression-variant
(early-access-hack
,type-name ,name ,(cadr (propagator-naming-convention hidden-name))))))
(define (name-fix-definition hidden-name name)
`(define-cell ,(car (propagator-naming-convention name))
,(car (propagator-naming-convention hidden-name))))
`(begin
(propagatify ,type-name)
(define-by-diagram-variant ,defined-constructor-names
(function->cell-carrier-constructor ,constructor-name))
,@(map accessor-definition
(map attach-% accessor-names)
accessor-names
(iota accessor-count))
,@(map name-fix-definition
(map attach-% accessor-names)
accessor-names)
,@(map early-access-hack-definition
(map attach-% accessor-names)
accessor-names))))))
(define-structure-propagators pair? cons car cdr)
;;; Here are the old names of these until I sweep them out of the code
(define p:carry-cons p:cons)
(define e:carry-cons e:cons)
(define p:carry-pair? p:pair?)
(define e:carry-pair? e:pair?)
(define p:carry-car p:car)
(define e:carry-car e:car)
(define p:carry-cdr p:cdr)
(define e:carry-cdr e:cdr)
;;; To make lists out of conses, we need empty lists too.
(propagatify null?)
(define p:carry-null? p:null?)
(define e:carry-null? e:null?)
;;; These guys are really the primitive container devices, from which
;;; everything else can be made.
(define-cell p:deposit (function->cell-carrier-constructor identity))
(define-cell e:deposit (expression-style-variant p:deposit))
(define-propagator (p:examine place cell)
(p:deposit cell place))
(define-cell e:examine
(early-access-hack cell? identity e:examine))
(define-syntax define-propagator-structure
(syntax-rules ()
((define-propagator-structure arg ...)
(begin
(define-structure-propagators arg ...)
(slotful-information-type arg ...)))))
(define-propagator (c:pair? thing truth)
(p:pair? thing truth)
(p:switch truth (cons nothing nothing) thing))
(define-propagator (c:null? thing truth)
(p:null? thing truth)
(p:switch truth '() thing))
propagator/core/diagrams.scm 0000664 0012467 0012467 00000036031 11657020262 014633 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2011 Alexey Radul and Gerald Jay Sussman
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define-structure
(%diagram
safe-accessors
(constructor %make-%diagram)
(print-procedure
(simple-unparser-method '%diagram
(lambda (object)
(list (name (diagram-identity object)))))))
identity
parts
promises
clubs) ; These are the diagrams that have me as a part
;; Cells are also diagrams, with trivial identity, no parts, and no
;; promises.
(define (diagram? thing)
(or (%diagram? thing)
(cell? thing)))
(define (diagram-identity thing)
(if (%diagram? thing)
(%diagram-identity thing)
thing))
(define (diagram-parts thing)
(if (%diagram? thing)
(%diagram-parts thing)
(or (eq-get thing 'parts) '())))
(define (set-diagram-parts! thing new-parts)
(if (%diagram? thing)
(set-%diagram-parts! thing new-parts)
(eq-put! thing 'parts new-parts)))
(define (clear-diagram-parts! thing)
(set-diagram-parts! thing '()))
(define (diagram-promises thing)
(if (%diagram? thing)
(%diagram-promises thing)
(or (eq-get thing 'promises) '())))
(define (set-diagram-promises! thing new-promises)
(if (%diagram? thing)
(set-%diagram-promises! thing new-promises)
(eq-put! thing 'promises new-promises)))
(define (clear-diagram-promises! thing)
(set-diagram-promises! thing '()))
(define (diagram-clubs thing)
(if (%diagram? thing)
(%diagram-clubs thing)
(or (eq-get thing 'clubs) '())))
(define (set-diagram-clubs! thing new-clubs)
(if (%diagram? thing)
(set-%diagram-clubs! thing new-clubs)
(eq-put! thing 'clubs new-clubs)))
(define (clear-diagram-clubs! thing)
(set-diagram-clubs! thing '()))
(define (add-diagram-club! thing club)
(set-diagram-clubs! thing (lset-adjoin eq? (diagram-clubs thing) club)))
(define (remove-diagram-club! thing club)
;; delq == lset-delete eq?
(set-diagram-clubs! thing (delq club (diagram-clubs thing))))
;;; Abstraction barrier
;;; Invariants:
;;; - Every part of a diagram should be a (possibly implicit) diagram.
;;; - Every club a diagram particiaptes in should be a (possibly
;;; implicit) diagram.
;;; - The clubs list of a diagram X should always contain exactly the
;;; diagrams that contain X as a part.
(define (make-%diagram identity parts promises)
(let ((answer (%make-%diagram identity parts promises '())))
;; produces (eq-adjoin! output 'shadow-connections the-propagator)
(for-each (lambda (part)
(add-diagram-club! part answer))
(map cdr parts))
answer))
(define (empty-diagram identity)
(make-%diagram identity '() '()))
(define (make-compound-diagram identity parts)
(make-%diagram identity parts (compute-derived-promises parts)))
(define (compute-derived-promises! diagram)
(set-diagram-promises!
diagram
(lset-union
diagram-promise-equal?
(diagram-promises diagram)
(compute-derived-promises (diagram-parts diagram))))
diagram)
(define (compute-derived-promises parts)
;; For every part that's a cell, I can promise not to read
;; (resp. write) it if every part either doesn't mention it or
;; promises not to read (resp. write) it. I just have to take due
;; care to make sure that recursive parts are properly taken care
;; of.
(append-map
(lambda (promised? make-promise)
(map make-promise
(filter
(lambda (cell)
(every (lambda (part)
(recursively-promises? promised? part cell))
(map cdr parts)))
(filter cell? (map cdr parts)))))
(list promises-not-to-read? promises-not-to-write?)
(list promise-not-to-read promise-not-to-write)))
(define diagram make-compound-diagram)
(define (add-diagram-named-part! diagram name part)
(set-diagram-parts!
diagram
(lset-adjoin equal? (diagram-parts diagram) (cons name part)))
(add-diagram-club! part diagram))
(define (delete-diagram-part! diagram part)
(set-diagram-parts!
diagram
(filter (lambda (name.part)
(not (eq? (cdr name.part) part)))
(diagram-parts diagram)))
(remove-diagram-club! part diagram))
(define (names-in-diagram diagram part)
(map car (filter (lambda (name.part)
(eq? part (cdr name.part)))
(diagram-parts diagram))))
(define (diagram-creator diagram)
;; The creator is the oldest club membership.
(if (null? (diagram-clubs diagram))
#f
(last (diagram-clubs diagram))))
;;;; Implicit diagram production
(define *toplevel-diagram* (empty-diagram 'toplevel))
(define (diagram-inserter target-diagram)
(lambda (subdiagram #!optional name)
(if (default-object? name)
(note-diagram-part! target-diagram subdiagram)
(add-diagram-named-part! target-diagram name subdiagram))
subdiagram))
;;; Every propagator constructor is expected to call the procedure
;;; REGISTER-DIAGRAM exactly once on a diagram describing the network
;;; it just constructed. This procedure is a fluid-bindable hook. In
;;; addition, a diagram-style propagator constructor is expected to
;;; return that same diagram, whereas an expression-style propagator
;;; constructor is expected to return the cell containing its return
;;; value.
(define (register-diagram subdiagram #!optional name)
((diagram-inserter *toplevel-diagram*) subdiagram name))
(define (note-diagram-part! diagram part)
(if (memq part (map cdr (diagram-parts diagram)))
'ok
(add-diagram-named-part! diagram (generate-uninterned-symbol) part)))
(define (delete-diagram-parts! diagram)
(for-each
(lambda (part)
(delete-diagram-part! diagram part)
(if (null? (diagram-clubs part))
(network-unregister part)))
(map cdr (diagram-parts diagram))))
(define (network-unregister thing)
(for-each
(lambda (club)
(delete-diagram-part! club thing))
(diagram-clubs thing))
(delete-diagram-parts! thing))
(define (replace-diagram! diagram new-diagram)
(delete-diagram-parts! diagram)
(for-each
(lambda (name.part)
(add-diagram-named-part! diagram (car name.part) (cdr name.part)))
(diagram-parts new-diagram))
(network-unregister new-diagram))
;;; Getting rid of diagrams when they are no longer needed requires
;;; eliminating appropriate entries in the eq-properties table,
;;; because those values would otherwise point back to themselves.
(define (destroy-diagram! diagram)
(clear-diagram-clubs! diagram)
(clear-diagram-promises! diagram)
(for-each destroy-diagram! (map cdr (diagram-parts diagram)))
(clear-diagram-parts! diagram))
(define (reset-diagrams!)
(destroy-diagram! *toplevel-diagram*)
(set! *toplevel-diagram* (empty-diagram 'toplevel))
(set! register-diagram (diagram-inserter *toplevel-diagram*)))
;;; Restarting requires resetting the toplevel diagram
(define initialize-scheduler
(let ((initialize-scheduler initialize-scheduler))
(lambda ()
(initialize-scheduler)
(reset-diagrams!))))
(define with-independent-scheduler
(let ((with-independent-scheduler with-independent-scheduler))
(lambda args
(fluid-let ((*toplevel-diagram* #f)
(register-diagram #f))
(apply with-independent-scheduler args)))))
;;;; New transmitters at the primitive-diagram level
(define-structure diagram-promise
type
target)
(define (diagram-promise-equal? prom1 prom2)
(and (eq? (diagram-promise-type prom1)
(diagram-promise-type prom2))
(eq? (diagram-promise-target prom1)
(diagram-promise-target prom2))))
(define (retarget-promise promise new-target)
(make-diagram-promise (diagram-promise-type promise)
new-target))
(define (promise-not-to-write thing)
(make-diagram-promise 'no-write thing))
(define (promise-not-to-read thing)
(make-diagram-promise 'no-read thing))
(define (make-anonymous-i/o-diagram identity inputs outputs)
(define (with-synthetic-names lst base)
(map cons
(map symbol (make-list (length lst) base)
(iota (length lst)))
lst))
(let* ((parts (append (with-synthetic-names inputs 'input)
(with-synthetic-names outputs 'output)))
(boundary (append inputs outputs))
(un-read (lset-difference eq? boundary inputs))
(un-written (lset-difference eq? boundary outputs)))
(make-%diagram
identity
parts
(append (map promise-not-to-write un-written)
(map promise-not-to-read un-read)))))
;;; Stuff for automatically determining the i/o characteristics of a
;;; compound box by expanding it out (in a sandbox) and looking at the
;;; i/o characteristics of its structure.
(define *interesting-cells* #f)
(define (make-diagram-for-compound-constructor identity prop-ctor args)
;; This check is here to keep recursive compounds from computing
;; their internal metadata forever. The reason this is ok is that
;; to learn the metadata of an unexpanded box, I only need to
;; observe what propagators want to attach to its interior boundary,
;; not to the entire interior.
(if (or (not *interesting-cells*)
(not (null? (lset-intersection eq?
*interesting-cells* args))))
(do-make-diagram-for-compound-constructor identity prop-ctor args)
(empty-diagram identity)))
(define (do-make-diagram-for-compound-constructor identity prop-ctor args)
(with-independent-scheduler
(lambda ()
(let ((test-cell-map (map (lambda (arg)
(cons (make-cell) arg))
args)))
(fluid-let ((*interesting-cells* (map car test-cell-map)))
(apply prop-ctor (map car test-cell-map)))
(let ((prop-ctor-diagram
(car
;; There should only be one of these
(filter (lambda (x) (not (cell? x)))
(map cdr (diagram-parts *toplevel-diagram*))))))
(make-%diagram
identity
(map (lambda (name.part)
(cons (car name.part)
(cdr (assq (cdr name.part) test-cell-map))))
(filter (lambda (name.part)
(assq (cdr name.part) test-cell-map))
(diagram-parts prop-ctor-diagram)))
(map (lambda (promise)
(retarget-promise
promise
(cdr (assq (diagram-promise-target promise)
test-cell-map))))
(filter (lambda (promise)
(assq (diagram-promise-target promise)
test-cell-map))
(diagram-promises prop-ctor-diagram)))))))))
;; Various inspectors should use the diagram-clubs facility instead of
;; the cell neighbors field, which, though somewhat redundant, is used
;; for the scheduler and for a different purpose.
;; Also, all analogues of function->propagator-constructor should be
;; adjusted, and a new one made for compound propagators.
;; ./core/propagators.scm:(define (propagator neighbors to-do)
;; ./core/propagators.scm: (propagator inputs ; The output isn't a neighbor!
;; ./core/propagators.scm: (propagator inputs the-propagator)))
;; ./core/propagators.scm: (propagator neighbors test)))
;; ./core/application.scm: (propagator prop-cell the-propagator)))
;; ./core/search.scm: (propagator cell amb-choose)))
;; ./extensions/virtual-environments.scm: (propagator cells
;; ./extensions/virtual-environments.scm: (propagator cells
;; ./extensions/virtual-closures.scm: (propagator outside
;; ./extensions/virtual-closures.scm: (propagator (cons frame-map-cell outside)
;; ./extensions/virtual-closures.scm: (propagator (list frame-map-cell outside)
;; ./extensions/virtual-closures.scm: (propagator (list frame-map-cell inside outside)
;; ./extensions/virtual-closures.scm: (propagator (cons* frame-map-cell closure-cell outside-cells)
;; ./extensions/virtual-closures.scm: (propagator output
;; ./examples/masyu.scm: (propagator neighbors
;; ./examples/masyu.scm: (propagator cells
;; ./examples/masyu.scm: (propagator (list far-left left right far-right)
;; ./examples/masyu.scm: (propagator (list far-left left right far-right)
;; ./examples/selectors/selectors.scm: (propagator inputs the-propagator)))
;; ./examples/selectors/selectors.scm: (propagator inputs the-propagator)))
;; ./examples/selectors/selectors.scm: (propagator inputs the-propagator)))
(defhandler name
(lambda (diagram)
(let ((own-name (default-name (diagram-identity diagram))))
(if (not (eq? own-name diagram))
own-name
(let ((my-names
(filter
(lambda (x)
(not (uninterned-symbol? x)))
(append-map
(lambda (club)
(names-in-diagram club diagram))
(diagram-clubs diagram)))))
(if (null? my-names)
diagram
(last my-names))))))
diagram?)
(define (promises-not-to-read? diagram part)
(any (lambda (promise)
(and (eq? part (diagram-promise-target promise))
(eq? 'no-read (diagram-promise-type promise))))
(diagram-promises diagram)))
(define (promises-not-to-write? diagram part)
(any (lambda (promise)
(and (eq? part (diagram-promise-target promise))
(eq? 'no-write (diagram-promise-type promise))))
(diagram-promises diagram)))
(define (recursively-promises? direct-promise? diagram part)
(cond ((direct-promise? diagram part)
#t)
((memq part (map cdr (diagram-parts diagram)))
#f)
(else
(every (lambda (subdiagram)
(recursively-promises? direct-promise? subdiagram part))
(map cdr (diagram-parts diagram))))))
;;; The inputs of a diagram X, really, are cells Y that X may read
;;; such that there is a clubs-path from Y to the top that does not go
;;; through X.
(define (internal-to-diagram? diagram subdiagram)
;; TODO Avoid losing via loops in the clubs graph
(cond ((eq? diagram subdiagram)
#t)
((null? (diagram-clubs subdiagram))
#f)
(else
(every (lambda (club)
(internal-to-diagram? diagram club))
(diagram-clubs subdiagram)))))
(define (diagram-external-parts diagram)
(filter (lambda (name.part)
(not (internal-to-diagram? diagram (cdr name.part))))
(diagram-parts diagram)))
(define (diagram-inputs diagram)
(filter (lambda (part)
(not (promises-not-to-read? diagram part)))
(map cdr (diagram-external-parts diagram))))
(define (diagram-outputs diagram)
(filter (lambda (part)
(not (promises-not-to-write? diagram part)))
(map cdr (diagram-external-parts diagram))))
(define (diagram-expression-substructure diagram)
;; TODO Stub
(append
(filter cell? (map cdr (diagram-parts diagram)))
(filter (lambda (x) (not (cell? x)))
(map cdr (diagram-parts diagram)))))
(define (primitive-diagram? diagram)
(every cell? (map cdr (diagram-parts diagram))))
propagator/core/explain.scm 0000664 0012467 0012467 00000011676 11562073370 014517 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2009 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
(define *explain-debug* #f)
(define (explain cell #!optional depth)
(assert (cell? cell) "Can only explain a cell.")
(if (default-object? depth) (set! depth 100))
(let ((n (+ (diagram-depth cell) depth))
(mark (make-eq-hash-table)))
(define (reason diagram)
(cond ((symbol? diagram) (list diagram))
((diagram? diagram)
(let ((eadiagram (explanation-ancestor diagram depth)))
(cons (name-of eadiagram)
(map name-of
(diagram-inputs eadiagram)))))
(else
(error "Unknown informant type -- EXPLAIN"
(name cell)))))
(define (explain-cell cell c)
(if (and (< (diagram-depth cell) n)
(or (not (= (length (name-of cell)) 1))
(not (number? (car (name-of cell))))))
(if (nothing? c)
`(,(name-of cell) has ,c)
`(,(name-of cell)
,@(if *explain-debug* (list (hash cell)) '())
has-value ,(v&s-value c)
,@(let ((infs (v&s-informants c)))
(if (null? infs)
'()
(cons 'by (map reason infs))))
,@(if (null? (v&s-support c))
'()
(cons 'with-premises (v&s-support c)))))
#f))
(define (explain cell)
(let ((seen (hash-table/get mark cell #f)))
(if (not seen)
(let ((c (tms-query (->tms (content cell)))))
(let ((infs (if (nothing? c) '() (v&s-informants c))))
(hash-table/put! mark cell #t)
(let ((e (explain-cell cell c))
(r (append-map
(lambda (inf)
(if (symbol? inf)
'()
(append-map explain
(diagram-inputs
(explanation-ancestor inf depth)))))
infs)))
(if e (cons e r) r))))
'())))
(explain cell)))
(define (diagram-depth thing)
(cond ((diagram-creator thing)
=> (lambda (d)
(+ 1 (diagram-depth d))))
(else 0)))
(define (explanation-ancestor thing n)
(let lp ((thing thing) (m (- (diagram-depth thing) n)))
(if (<= m 0)
thing
(lp (diagram-creator thing) (- m 1)))))
#|
;;; Here is an example:
(what-is M87:distance)
#| ((+- 19.5 2.678) depends-on VanDenBergh1985) |#
(cpp (explain M87:distance 1))
#|
(((m87:distance) has-value #[interval 16.83 22.18] by ((c:mu<->d) (m87:distance-modulus)) with-premises vandenbergh1985)
((m87:distance-modulus) has-value #[interval 31.13 31.73] by (user) with-premises vandenbergh1985))
|#
(cpp (explain M87:distance 2))
#|
(((m87:distance) has-value #[interval 16.83 22.18] by ((p:mu->d) (m87:distance-modulus)) with-premises vandenbergh1985)
((m87:distance-modulus) has-value #[interval 31.13 31.73] by (user) with-premises vandenbergh1985))
|#
(cpp (explain M87:distance 3))
#|
(((m87:distance) has-value #[interval 16.83 22.18] by ((p:/) (1000000.) (cell160)) with-premises vandenbergh1985)
((cell160) has-value #[interval 16830000. 22180000.] by ((exp:p) (cell157)) with-premises vandenbergh1985)
((cell157) has-value #[interval 16.64 16.91] by ((p:*) (l10) (cell156)) with-premises vandenbergh1985)
((cell156) has-value #[interval 7.226 7.346] by ((+:p) (cell151) (1)) with-premises vandenbergh1985)
((cell151) has-value #[interval 6.226 6.346] by ((p:/) (5) (m87:distance-modulus)) with-premises vandenbergh1985)
((m87:distance-modulus) has-value #[interval 31.13 31.73] by (user) with-premises vandenbergh1985)
((l10) has-value 2.303))
|#
(cpp (explain M87:distance 4))
#|
(((m87:distance) has-value #[interval 16.83 22.18] by ((/:p) (cell160) (1000000.)) with-premises vandenbergh1985)
((cell160) has-value #[interval 16830000. 22180000.] by ((exp:p) (cell157)) with-premises vandenbergh1985)
((cell157) has-value #[interval 16.64 16.91] by ((*:p) (cell156) (l10)) with-premises vandenbergh1985)
((cell156) has-value #[interval 7.226 7.346] by ((+:p) (cell151) (1)) with-premises vandenbergh1985)
((cell151) has-value #[interval 6.226 6.346] by ((/:p) (m87:distance-modulus) (5)) with-premises vandenbergh1985)
((m87:distance-modulus) has-value #[interval 31.13 31.73] by (user) with-premises vandenbergh1985)
((l10) has-value 2.303))
|#
|#
propagator/core/diagram-cells.scm 0000664 0012467 0012467 00000016536 11657020262 015560 0 ustar gjs gjs ;;; ----------------------------------------------------------------------
;;; Copyright 2011 Massachusetts Institute of Technology.
;;; ----------------------------------------------------------------------
;;; This file is part of Propagator Network Prototype.
;;;
;;; Propagator Network Prototype is free software; you can
;;; redistribute it and/or modify it under the terms of the GNU
;;; General Public License as published by the Free Software
;;; Foundation, either version 3 of the License, or (at your option)
;;; any later version.
;;;
;;; Propagator Network Prototype is distributed in the hope that it
;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Propagator Network Prototype. If not, see
;;; .
;;; ----------------------------------------------------------------------
(declare (usual-integrations make-cell cell?))
;;; What does it mean to merge a diagram into another diagram?
;;; The identity (name) of the merged diagram is that of the target
;;;
;;; The parts of the merged diagram is the set-union of the parts of
;;; the target and increment.
;;;
;;; If a promise is present and the same in both the target and
;;; increment, then keep the promise.
;;;
;;; If a promise is present in either the target or the increment but
;;; not both, and the part to which the promise applies is present
;;; only in the diagram in which the promise is made, keep the
;;; promise.
;;; QUESTIONS:
;;;
;;; - Should the existence of the previous diagrams be removed?
;;; (i.e. should parts replace their membership in the clubs of the
;;; target and increment with membership in the merge?)
;;; [CURRENTLY: YES]
;;; - Should it be possible to merge cells? [CURRENTLY: NO]
(define (merge-diagram target increment)
(let ((merged target))
;; Merge parts/clubs
;; What if the name is the same?
(for-each (lambda (part)
;; The position of the club is significant
(let ((club.clubs (memq increment (diagram-clubs (cdr part)))))
(set-car! club.clubs merged))
(add-diagram-named-part! merged (car part) (cdr part)))
(diagram-parts increment))
;; Merge promises
(let ((merged-promises
(lset-union
;; Can parts ever be equal? but not eq?
(lset-intersection diagram-promise-equal?
(diagram-promises merged)
(diagram-promises increment))
(filter (lambda (promise)
(not (eq? (memq (diagram-promise-target promise)
(map cdr (diagram-parts increment)))
#f)))
(diagram-promises merged))
(filter (lambda (promise)
(not (eq? (memq (diagram-promise-target promise)
(map cdr (diagram-parts merged)))
#f)))
(diagram-promises increment)))))
(set-diagram-promises! merged merged-promises))
;; Finish unregistering the increment.
(clear-diagram-parts! increment)
(network-unregister increment)
(clear-diagram-promises! increment)
merged))
(define (diagram-equivalent? target increment)
(and (= (length (lset-xor diagram-promise-equal?
(diagram-promises target)
(diagram-promises increment)))
0)
(= (length (lset-xor eq?
;; We just need parts, not names to be the
;; same.
(map cdr (diagram-parts target))
(map cdr (diagram-parts increment))))
0)
(= (length (lset-xor eq?
(diagram-clubs target)
(diagram-clubs increment)))
0)))
;;; Diagram merging
(defhandler merge merge-diagram %diagram? %diagram?)
(defhandler equivalent? diagram-equivalent? %diagram? %diagram?)
;;; *metadiagram* is the toplevel-diagram for diagram cells. It is
;;; the only diagram that is not in a cell, and its only purpose is to
;;; hold cells in which diagrams are contained to keep them out of
;;; visualizations of the toplevel-diagram.
(define *metadiagram* (empty-diagram 'metadiagram))
;(define (toplevel-merge content increment)
; (if (eq? increment *toplevel-diagram*)
; increment
; (merge content increment)))
;;; *toplevel-diagram-cell* is the cell containing the
;;; toplevel-diagram. It belongs to the *metadiagram*
(define *toplevel-diagram-cell*
(fluid-let ((register-diagram (diagram-inserter *metadiagram*)))
(make-cell)))
(add-content *toplevel-diagram-cell* *toplevel-diagram*)
;;; Redefine diagram insertion in terms of operations on the
;;; *toplevel-diagram-cell*
(define (diagram-cell-inserter target-diagram-cell)
(lambda (subdiagram #!optional name)
;;; Wrap the subdiagram in a diagram in a cell.
(let ((subdiagram-wrapper (empty-diagram 'wrapper)))
(if (default-object? name)
(note-diagram-part! subdiagram-wrapper subdiagram)
(add-diagram-named-part! subdiagram-wrapper name subdiagram))
(add-content target-diagram-cell subdiagram-wrapper))
subdiagram))
(define (register-diagram subdiagram #!optional name)
((diagram-cell-inserter *toplevel-diagram-cell*) subdiagram name))
(define (reset-diagrams!)
;; Clean out the metadiagram.
(destroy-diagram! *metadiagram*)
(set! *metadiagram* (empty-diagram 'metadiagram))
(fluid-let ((register-diagram (diagram-inserter *metadiagram*)))
;; And then, reset the toplevel diagram.
(set! *toplevel-diagram-cell* (make-cell)))
;; Hmmm... This doesn't look monotonic.
(destroy-diagram! *toplevel-diagram*)
(set! *toplevel-diagram* (empty-diagram 'toplevel))
(set! register-diagram (diagram-cell-inserter *toplevel-diagram-cell*))
(add-content *toplevel-diagram-cell* *toplevel-diagram*))
(define (empty-diagram-cell identity)
(let ((diagram-cell
(fluid-let ((register-diagram (diagram-inserter *metadiagram*)))
(make-cell))))
(add-content diagram-cell (make-%diagram identity '() '()))
diagram-cell))
(define (do-make-diagram-for-compound-constructor identity prop-ctor args)
(with-independent-scheduler
(lambda ()
(let ((test-cell-map (map (lambda (arg)
(cons (make-cell) arg))
args)))
(fluid-let ((*interesting-cells* (map car test-cell-map)))
(apply prop-ctor (map car test-cell-map)))
;; The following code shouldn't execute until the diagram
;; registrations from prop-ctor are reflected in the
;; *toplevel-diagram-cell*
(propagator *toplevel-diagram-cell*
(lambda ()
;; Specifically, we assume that there are parts to the
;; *toplevel-diagram*, so we need to wait until this is
;; true.
(if (null? (diagram-parts (contents *toplevel-diagram-cell*)))
'ok
(let ((prop-ctor-diagram
(car
;; There should only be one of these
(filter (lambda (x) (not (cell? x)))
(map cdr
(diagram-parts
(contents *toplevel-diagram-cell*)))))))
(make-%diagram
identity
(map (lambda (name.part)
(cons (car name.part)
(cdr (assq (cdr name.part) test-cell-map))))
(filter (lambda (name.part)
(assq (cdr name.part) test-cell-map))
(diagram-parts prop-ctor-diagram)))
(map (lambda (promise)
(retarget-promise
promise
(cdr (assq (diagram-promise-target promise)
test-cell-map))))
(filter (lambda (promise)
(assq (diagram-promise-target promise)
test-cell-map))
(diagram-promises prop-ctor-diagram))))))))))))
propagator/core/.directory 0000600 0040401 0040401 00000000062 12017443345 014252 0 ustar elg elg [Dolphin]
Timestamp=2012,8,29,12,44,21
ViewMode=1
propagator/doc/ 0000775 0012467 0012467 00000000000 11540204324 012144 5 ustar gjs gjs propagator/doc/html4css1.css 0000664 0012467 0012467 00000012470 11367316336 014522 0 ustar gjs gjs /*
:Author: David Goodger (goodger@python.org)
:Id: $Id: html4css1.css 5196 2007-06-03 20:25:28Z wiemann $
:Copyright: This stylesheet has been placed in the public domain.
Default cascading style sheet for the HTML output of Docutils.
See http://docutils.sf.net/docs/howto/html-stylesheets.html for how to
customize this style sheet.
*/
/* used to remove borders from tables and images */
.borderless, table.borderless td, table.borderless th {
border: 0 }
table.borderless td, table.borderless th {
/* Override padding for "table.docutils td" with "! important".
The right padding separates the table cells. */
padding: 0 0.5em 0 0 ! important }
.first {
/* Override more specific margin styles with "! important". */
margin-top: 0 ! important }
.last, .with-subtitle {
margin-bottom: 0 ! important }
.hidden {
display: none }
a.toc-backref {
text-decoration: none ;
color: black }
blockquote.epigraph {
margin: 2em 5em ; }
dl.docutils dd {
margin-bottom: 0.5em }
/* Uncomment (and remove this text!) to get bold-faced definition list terms
dl.docutils dt {
font-weight: bold }
*/
div.abstract {
margin: 2em 5em }
div.abstract p.topic-title {
font-weight: bold ;
text-align: center }
div.admonition, div.attention, div.caution, div.danger, div.error,
div.hint, div.important, div.note, div.tip, div.warning {
margin: 2em ;
border: medium outset ;
padding: 1em }
div.admonition p.admonition-title, div.hint p.admonition-title,
div.important p.admonition-title, div.note p.admonition-title,
div.tip p.admonition-title {
font-weight: bold ;
font-family: sans-serif }
div.attention p.admonition-title, div.caution p.admonition-title,
div.danger p.admonition-title, div.error p.admonition-title,
div.warning p.admonition-title {
color: red ;
font-weight: bold ;
font-family: sans-serif }
/* Uncomment (and remove this text!) to get reduced vertical space in
compound paragraphs.
div.compound .compound-first, div.compound .compound-middle {
margin-bottom: 0.5em }
div.compound .compound-last, div.compound .compound-middle {
margin-top: 0.5em }
*/
div.dedication {
margin: 2em 5em ;
text-align: center ;
font-style: italic }
div.dedication p.topic-title {
font-weight: bold ;
font-style: normal }
div.figure {
margin-left: 2em ;
margin-right: 2em }
div.footer, div.header {
clear: both;
font-size: smaller }
div.line-block {
display: block ;
margin-top: 1em ;
margin-bottom: 1em }
div.line-block div.line-block {
margin-top: 0 ;
margin-bottom: 0 ;
margin-left: 1.5em }
div.sidebar {
margin: 0 0 0.5em 1em ;
border: medium outset ;
padding: 1em ;
background-color: #ffffee ;
width: 40% ;
float: right ;
clear: right }
div.sidebar p.rubric {
font-family: sans-serif ;
font-size: medium }
div.system-messages {
margin: 5em }
div.system-messages h1 {
color: red }
div.system-message {
border: medium outset ;
padding: 1em }
div.system-message p.system-message-title {
color: red ;
font-weight: bold }
div.topic {
margin: 2em }
h1.section-subtitle, h2.section-subtitle, h3.section-subtitle,
h4.section-subtitle, h5.section-subtitle, h6.section-subtitle {
margin-top: 0.4em }
h1.title {
text-align: center }
h2.subtitle {
text-align: center }
hr.docutils {
width: 75% }
img.align-left {
clear: left }
img.align-right {
clear: right }
ol.simple, ul.simple {
margin-bottom: 1em }
ol.arabic {
list-style: decimal }
ol.loweralpha {
list-style: lower-alpha }
ol.upperalpha {
list-style: upper-alpha }
ol.lowerroman {
list-style: lower-roman }
ol.upperroman {
list-style: upper-roman }
p.attribution {
text-align: right ;
margin-left: 50% }
p.caption {
font-style: italic }
p.credits {
font-style: italic ;
font-size: smaller }
p.label {
white-space: nowrap }
p.rubric {
font-weight: bold ;
font-size: larger ;
color: maroon ;
text-align: center }
p.sidebar-title {
font-family: sans-serif ;
font-weight: bold ;
font-size: larger }
p.sidebar-subtitle {
font-family: sans-serif ;
font-weight: bold }
p.topic-title {
font-weight: bold }
pre.address {
margin-bottom: 0 ;
margin-top: 0 ;
font-family: serif ;
font-size: 100% }
pre.literal-block, pre.doctest-block {
margin-left: 2em ;
margin-right: 2em }
span.classifier {
font-family: sans-serif ;
font-style: oblique }
span.classifier-delimiter {
font-family: sans-serif ;
font-weight: bold }
span.interpreted {
font-family: sans-serif }
span.option {
white-space: nowrap }
span.pre {
white-space: pre }
span.problematic {
color: red }
span.section-subtitle {
/* font-size relative to parent (h1..h6 element) */
font-size: 80% }
table.citation {
border-left: solid 1px gray;
margin-left: 1px }
table.docinfo {
margin: 2em 4em }
table.docutils {
margin-top: 0.5em ;
margin-bottom: 0.5em }
table.footnote {
border-left: solid 1px black;
margin-left: 1px }
table.docutils td, table.docutils th,
table.docinfo td, table.docinfo th {
padding-left: 0.5em ;
padding-right: 0.5em ;
vertical-align: top }
table.docutils th.field-name, table.docinfo th.docinfo-name {
font-weight: bold ;
text-align: left ;
white-space: nowrap ;
padding-left: 0 }
h1 tt.docutils, h2 tt.docutils, h3 tt.docutils,
h4 tt.docutils, h5 tt.docutils, h6 tt.docutils {
font-size: 100% }
ul.auto-toc {
list-style-type: none }
propagator/doc/art.pdf 0000664 0012467 0012467 00001173035 11334635503 013447 0 ustar gjs gjs %PDF-1.4
7 0 obj <<
/Length 121
/Filter /FlateDecode
>>
stream
xÚŒ±
Ã0Dw…~Àêe¢z/„Žý†™BÈÿ/U]‚‡R$8ñîtÄP2”µz׫›<×${pé‚ßh
Ú:?Ýáîiˆ_îk•Û–INû
ÑL2µ¢¥½ KXó±jê$?u£›;O(êÖüÿ’WÔ6endstream
endobj
6 0 obj <<
/Type /Page
/Contents 7 0 R
/Resources 5 0 R
/MediaBox [0 0 611.9985 791.9981]
/Parent 8 0 R
>> endobj
4 0 obj <<
/Type /XObject
/Subtype /Form
/FormType 1
/PTEX.FileName (/var/tmp/290241225923386source1.pdf)
/PTEX.PageNumber 1
/PTEX.InfoDict 9 0 R
/Matrix [1.00000000 0.00000000 0.00000000 1.00000000 0.00000000 0.00000000]
/BBox [0.00000000 0.00000000 612.00000000 792.00000000]
/Resources <<
/ProcSet [ /PDF /ImageC /ImageI /Text ]
/ColorSpace <<
/R10 10 0 R
>>/ExtGState <<
/R7 11 0 R
>>/Font << /R9 12 0 R /R12 13 0 R >>
>>
/Length 14 0 R
/Filter /FlateDecode
>>
stream
xœµ½=¯-Ë‘%6€¼9ò¶5">‡•ß•fOkfÄž`š|@z³ù^7Õ§ÈîÇGp9r$Hž~€la C¶äœñå
#ÈÐ8ú
Šµ"«vUFì{Ï»ÍA¼[ëdæ®ÊÈȈ‘{[ÞÂmÁÿÆïÛËO~Önù›—¿}‰ 6ü§õ°ÜÞ_j˜þüÕË_Ü~õ²¼-}
9iii±÷ÿ¨}éÿÊ©‡¼Þþú%Ü~ùÒÖX¤Ô--këY~ƒH ‡·ºJ«¤·Ü H,ø‘[ìK~+ H
åÖ[Y*~áŠô·¦@zëÖ·ÞñÞKÎoòN¹ùoØ‘€Ä·Ÿ•Io)IomBâÛšÙ#!¾µrK±-oeJ•_¯ù–R©o±‘ïÌò¡-7ü¦ méo9Rã[`™–7éH")_‘„ÿŽZ1ÍÈÔŽ-cÛÁâKSÕŽ/o(½7]«"òö
HE¯$d í-$EÒ[Œ‚´ò–P«ÆÜñ¹–1¤D
ZF?—'ed{È´ ½-I+ELžÜŠü8Æ8K×–˜Ú˜9I>N¾z‘~h:*'̤öéWDæ(¦d
o…
÷´bS”÷Y¾\ìòã«NÛÀÕ¸¾emi¨„™JÔ™}™üç7øÄÍûmïÍgž[Á˜ôŒ1IYÌŠU&ˆ,ðeNHÑ1a\gäÔΓ–3gß¹–my ÒŸçQY"fê@d‘’0ˆHËY‘±ÊŠ·Ï9¥·ÐvD~CðÖ×çÈ\«qjå4ºð‚,œûMÞg•WÆ"O
¬oËS¤é¢’e±v 2|íYÓð ÂÛêöúk]±nÚÈ«&Ýþº®òQ²JSX8©XJúIêùSÐzÉŒÀä–?aÔ_›¬ÒEä$¥+“@U€ \ÀD0¤Ç<}•w”YoX‹-WïÞ_äÞ’|R\cÀTÝ^äéËÐeÈKö„$.ó$Í@èà9âó_±Êe5Ýò‚™p@Eþ)PÔåö2ÓÛŠq´Æ :*b´dIK^1ãðÁ²¸ú‚~jI…¡@rFº·è¤yM*¦S±ßâŽD‘ÁÝ ¹–ÖJò±)Aâê+È
‘Ƀ
#Ž¶¢Lƒ.;˜@I7¹+ÄÉ#,¤2AN["ÈC¹–rÚ: ©
ÉÀ‡•ã•ušaÀVt|”¹ÞëÓU¶FAV}Ñc”cìòv£V“]‘¹‘pX¨(süÖ\kn9Ë^°`[æú‰èç@ö|Eî"‰^°`ÒYñ§'@€ˆn «êýeœBY
„™ ¢+`Qĺfl“dˆ‘yM@Z'ù " R¡Ð/"—"el&D^'Z«Ìž+rnÇoÙÖ2-Ë6[ðé¡ÉÖ0€º UmËȘúU6¥ˆ:•šYi¢oÀ’ªØäûEÞSEº¿ ‘Ž @M{÷s "Ï–®U¦"JÇJ²]f‘膢ƴ+R ‚®‘ñ»n^ÊÛeÝ.ÚŽ¿”?I…ÓôèÍ™\Îü³söÚŒL®*"»@A½B ~·R«ëØC°`šè.2$EþRU/òë;GP™(ˆÔoŠÔú¬ÌŽÈ|)×Z"Îø†AT*8½Žw~ MŨ +úœ7—¼ˆ À’´uGD>
RT¤bA¹H~{VD$¼(S;’z£ÌçŽiœ€KŸwé)v`Á´.‹ì›Iß$H_ Ü3þÛ!lDOƒ0ÀÔÔg‘T =B¦WŒIÐsGÆ®"[¿ Ô‡Ò*'’ÐÏÓ(ÞM¯m~Ï®ºI_kÏšÞçþYfÁ7oq·¯Œ×ŽÑ,DØÈl|^ïºqÓÙ&ˆg.wkš*ž6ªª€LÚű£Œ"¶Ò»{³N¿PæÉöºìäØT®Ç%°“š«l?çg™lòœÝËXc]Iè~Ñ9¢üJUebÅØÿ(ZdOGcx‚–éü]]¬¢"¡1âÀX–…v@ͳ[dúÛZv¤ÈŽ€ÿÊ+Bdi”YŽÅ¶Ê-[ADk"oJm$bVÇV¨Ÿ– çž&ῸSSa“³ÜªˆÌAŠSAäÍ„D8ñ(èA
~@ž3ŸŸfkÈB¼£F€ÈáBç²
±séÒߎFvä$lU÷íyæQ©j…hÝÁ Ä–Ñ
7żïÉ›³³ˆHßǶ}3ÎO=é+žÕœS×¥Œ,‡&ʶ¦Þh ÙÁÒѽMËDžÕär AkE¿L\¥SäÀ £=ζ‚tÌÁdf„½Rƒ8…x
sÌ\$`m<)Ó¸^ÏuÓSUÖ{Âò]¦ê'¯Qa‚À>Ám°É˜)dÊîŸuét¡¬MY{¹õ¨VV(ÍUZcëV@Ò]Y€ÀÕ„?^’Lù[Y¥™Äýš¶)IÅ&uQZ¢Ô€ýHŽ˜Ødï¡p€E‰ù@*÷ÄDŽ¼I…`¡´ë¡@¤–µ4=T‹v´r¢wé!°"’ÍÉ1”êsé²"лÒ*¶ÀûK]`²ƒÎàôY¤ÛXÙºzjÞ—:tÇèó:=·ãùn~ŽÐÄÑ'Øç°‰rNõVΫÃö ¢;¢‡ËºŒÓè"¢WtŠ|pâ*Q¶¢ßªHB
^Hñ*‡= ºØ6zQ+Ež%ý,íˆ •éÜõ$=¿ ~Q¡¯sãÉl¹”1»½p6\úñ¬syž
ßÂBE[$ç{¦T9ÂÓ°b%EÖwóf(NS;禮ܡǪ™0i™Ž}¬æ eýÃbfLhÖÊf-qO,fÝ5íÀÕph‹Pí «‚ØÞ±ëé1ö%Ì+ÕžRÐì8vòÕ /òBŠ`êÉ|×F›Öó¢\Hã1Œí°qÑ áÌ y¯/‚ÝCú²ˆî ú˜Þ}ÂZ”ÀÃ/Àdx®
zD¤½ådÑ<=iÅñ¾0Ça©Wkþ)ú•u‘CòÚÕ N£r
AÕÄù[wD6AD²ßhahP´¿a˜$ÐÔDw·R†±FîS´Â‡Ìvyc»·ö}Çàù ¾Àß`ýžkcö~X‰õ¢8Ž–ÙmMÖM”/²¨‘ašv$6ERÕ~u/“fà2|2÷ 2b(Ï„È¥Ì@¦JFª|ºŽcÞÜüCµ“š#µ¸V©¶yÖE-ROéyÕ>¤€§q±ËÅTgsõN]ÞYÍ9t9G³ë9¬Êi}21Ké%ò€Ÿ‡Òµ:Ïvà¹)ØÅp&·HÍ
/ždµ4Y’c¬‡7‘ÁkT`mg .Ã!k}{Fæ"rèN¾eô,å³Ú{ðÛR’ñëeÍ/Z
稜g(W–*oc¢Vaxf&vŒÉžÉÙ3LÿÁìÞαטÝeÞX*5Ó±xÎFÑϘ¶&CÖ®ñ“l«"‚Š"Ô:l6l&ëŒ]eW]aBL-´Ý¨mT'$è^1¾Ø´NFÛçpLWèƒgÄ–Ù‘¶ªö=Orklxb¸Z¬…bþˆM•@$hgœýPóé_hv¬Ó³ùt²°n®Öj1×1øZ£ð7$ÏæéÉz=®ïž ÜXÉ¿ÈDåKµy'êj²}éOSÂÙ"âcŠšAäSVþB©Ã–)Ïü|šeaiß‘£[áÖ®oû‹]~ÕXžÎöcÈŽLé ØYyÀx ën§()²^ d›¡{SÚeeáìÖà Œì€Úðª3ŽµbQ„J¤‡˜ZMz+Ñ‚¾Ê¶«ÈlSŸ,¶X´W›îló°ñ^-Ç°O¶åÉö<[§‡½ZmT]õIÖÉž§A¿›ySD4†Ë¶ílî¨è˜ÚÍ}:#n>ñÂ5¯ÌsÒœ
÷ÛÇ\"žqr Ìî—ÍwÑ|‘«ÇºŒV*Xg~µŒ2Ñp’
¢†ô¤oXpæ“7Û_^`\„ˆJ`ÿÐ!0‡ˆÐ¦…½Äúcð,r¹Tàg
ÌWÎìâ™@÷ù‰wÓì’ú€såócôÄÑøQ΀qGÎôƒ‰¢°)":š’Bâà(ÈÅiVvóh©á€@¹)ûïM…/tZâÄ3Qý ‹èÄašùIg³ìšOòz>ÅâýÔ#í€e9,£?É2£<ö”±õ[–ÏŸæ€Ùîé3IÊ4ÝøHÖòWz–aum0 UýÒ ŒÈHé´œvâµå/õjDzPM2mãQ1Ó¥›±:{a<-Ê$Ñípæ–øÄ–ƒ´ò bËçh,‰fnÇa㘣[*@|r/§éŽH££ŠZÈ(ÓfàTI½RP‘Ëî›Ìæ ¸·à»ÈA£ï×äDzmX××ÔHè•[_/µ+b¯ÆÍf]qÖ[ç:ô®>?뼺‰ÌÎÅÙùxvRÜ}æìä´ŽP"h'‰ÏZ™þ’¬n8A8ñ´