├── .gitignore ├── .gitmodules ├── COPYING ├── README.md ├── Rakefile ├── core ├── agent.scm ├── amb-utils.scm ├── application.scm ├── carrying-cells.scm ├── cell-sugar.scm ├── cells.scm ├── compound-data.scm ├── contradictions.scm ├── diagram-cells.scm ├── diagrams.scm ├── example-networks.scm ├── explain.scm ├── general-scheduler.scm ├── generic-definitions.scm ├── intervals.scm ├── load.scm ├── merge-effects.scm ├── metadata.scm ├── physical-closures.scm ├── premises.scm ├── propagators.scm ├── run-tests ├── scheduler.scm ├── search.scm ├── standard-propagators.scm ├── sugar.scm ├── supported-values.scm ├── test-utils.scm ├── test │ ├── barometer-test.scm │ ├── carrying-cells-test.scm │ ├── compound-merges-test.scm │ ├── copying-data-test.scm │ ├── core-test.scm │ ├── dependencies-test.scm │ ├── load.scm │ ├── metadata-test.scm │ ├── partial-compounds-test.scm │ ├── physical-closures-test.scm │ ├── scheduler-test.scm │ └── switches-test.scm ├── truth-maintenance.scm └── ui.scm ├── distributed ├── load-client.scm ├── load-server.scm ├── propagators-client.scm ├── propagators-server.scm └── slrpc │ ├── federate-scratch.scm │ ├── rpc.txt │ ├── rpcmarshal.scm │ ├── rpcthreading.scm │ ├── rpctxtscraps.txt │ ├── slrpc-cps.scm │ ├── slrpc.scm │ └── test-rpc.scm ├── doc ├── Rakefile ├── art.pdf ├── bib.rkt ├── closures.tex ├── environments.tex ├── html4css1.css ├── partial-composition.tex ├── phd-thesis.pdf ├── preamble.tex ├── programmer-guide.rst ├── rake-latex.rb ├── reference.txt ├── revised-auto.bib ├── revised.scrbl ├── revised.tex ├── revised.txt └── style.css ├── examples ├── Rakefile ├── albatross-conundrum.scm ├── belief-propagation.scm ├── electric-parts.scm ├── load.scm ├── masyu.scm ├── multiple-dwelling.scm ├── recursive-sqrt.scm ├── riddle-of-the-knights.scm ├── run-examples ├── run-mechanics-tests ├── run-tests ├── selectors │ ├── code-slides.ps │ ├── code-slides.scm │ ├── data.scm │ ├── example-slides.ps │ ├── example-slides.txt │ ├── fae.eps │ ├── fae.fig │ ├── plan.txt │ ├── selectors.scm │ └── todo.txt ├── slow-examples.scm ├── sudoku.scm ├── test │ ├── belief-propagation-test.scm │ ├── bridge-rectifier-test.scm │ ├── galaxy-range-test.scm │ ├── load.scm │ ├── mechanics-load.scm │ ├── multiple-dwelling-test.scm │ ├── recursive-sqrt-test.scm │ ├── selectors-test.scm │ ├── smoke-test.scm │ ├── sudoku-test.scm │ └── voltage-divider-test.scm ├── voltage-divider-slice.scm └── voltage-divider.scm ├── explorations ├── algebraic-tms-test.scm ├── algebraic-tms.scm ├── ce-amp.scm ├── circuits │ ├── examples.scm │ ├── infrastructure.scm │ ├── layered.scm │ ├── load.scm │ ├── parts.scm │ ├── run-tests │ ├── slices.scm │ └── tests.scm ├── control-abstraction.scm ├── gods-eye-tms.scm ├── ignorance.scm ├── locking.txt ├── mortgages.scm ├── raa.scm ├── shared-resource.scm ├── sqrt-feedback.scm └── sudoku-2.scm ├── extensions ├── dot-writer.scm ├── draw.scm ├── example-closures.scm ├── functional-reactivity.scm ├── graphml-writer.scm ├── inequalities.scm ├── info-alist.scm ├── load.scm ├── mechanics ├── run-tests ├── solve.scm ├── symbolics-ineq.scm ├── symbolics.scm ├── test-utils.scm ├── test │ ├── functional-reactive-test.scm │ ├── graph-drawing-test.scm │ ├── inequality-test.scm │ ├── load.scm │ ├── symbolics-ineq-test.scm │ ├── symbolics-test.scm │ ├── virtual-closures-test.scm │ └── virtual-environments-test.scm ├── virtual-closures.scm └── virtual-environments.scm ├── git-incantations ├── load.scm ├── micah-anomaly.scm ├── run-tests ├── support ├── auto-compilation.scm ├── coercions.scm ├── deque-sets.scm ├── deque.scm ├── eq-properties.scm ├── generics-again.scm ├── insertion-order-sets.scm ├── load.scm ├── mit-profile.scm ├── mit-profile.scm.orig ├── profiler.scm ├── run-tests ├── scm-propagators.el ├── test-utils.scm ├── test │ ├── generic-microbench.scm │ ├── generics-test.scm │ ├── load.scm │ ├── profiler-test.scm │ └── utils-test.scm └── utils.scm └── todo.txt /.gitignore: -------------------------------------------------------------------------------- 1 | *.bin 2 | *.com 3 | *.ext 4 | *.bci 5 | *~ -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "testing"] 2 | path = testing 3 | url = git://github.com/axch/test-manager.git 4 | -------------------------------------------------------------------------------- /Rakefile: -------------------------------------------------------------------------------- 1 | task :clean do 2 | %w(.bin .bci .com .ext ~).each do |extension| 3 | sh "find . -name \"*#{extension}\" -delete" 4 | end 5 | end 6 | 7 | excludes = %w(*.bin *.com *.bci *.ext *~ *.svn selectors explorations .gitignore todo.txt partial-composition.* reference.* revised-html) 8 | 9 | task :release => [:workbook, :doc] do 10 | sh "cd #{File.dirname(__FILE__)}; " + %Q{tar --create --verbose --file ../propagator.tar --directory .. --transform "s/prop/propagator/" --exclude=} +"\"" + excludes.join("\" --exclude=\"") + "\" prop/" 11 | end 12 | 13 | def files 14 | ["scheduler", 15 | "metadata", 16 | "merge-effects", 17 | "cells", 18 | "cell-sugar", 19 | "propagators", 20 | "application", 21 | "sugar", 22 | "generic-definitions", 23 | "compound-data", 24 | "physical-closures", 25 | "standard-propagators", 26 | "carrying-cells", 27 | 28 | "intervals", 29 | "premises", 30 | "supported-values", 31 | "truth-maintenance", 32 | "contradictions", 33 | "search", 34 | "amb-utils", 35 | 36 | "example-networks"].map do |base| 37 | "core/#{base}.scm" 38 | end 39 | end 40 | 41 | task :workbook do 42 | sh "enscript -M letter -fCourier-Bold12 -o workbook.ps --file-align=2 #{files.join(" ")}" 43 | end 44 | 45 | task :doc do 46 | sh "cd #{File.dirname(__FILE__)}/doc; rake doc" 47 | end 48 | 49 | task :push => :release do 50 | sh "cp ../propagator.tar /afs/csail.mit.edu/group/mac/www/data/users/gjs/propagators/" 51 | sh "cp doc/revised-html.html /afs/csail.mit.edu/group/mac/www/data/users/gjs/propagators/" 52 | sh "cp doc/revised-html.html /afs/csail.mit.edu/group/mac/www/data/users/gjs/propagators/index.html" 53 | end 54 | -------------------------------------------------------------------------------- /core/agent.scm: -------------------------------------------------------------------------------- 1 | (define-record-type agent 2 | (agent:make-record worldview scheduler) 3 | agent? 4 | (worldview agent:worldview) 5 | (scheduler agent:scheduler)) 6 | 7 | (define (agent:make #!optional name parent) 8 | (let ((name 9 | (if (default-object? name) 10 | (begin (set! *agent-number* (+ *agent-number* 1)) 11 | (symbol 'agent *agent-number*)) 12 | name)) 13 | (new-worldview 14 | (if (default-object? parent) 15 | (worldview:make *current-agent*) 16 | (worldview:make parent)))) 17 | (let ((agent 18 | (agent:make-record new-worldview (make-scheduler)))) 19 | (name! agent name) 20 | ;;(eq-put! new-worldview 'agent agent) 21 | (for-each ((agent:scheduler agent) 'alert-one) 22 | (all-propagators)) 23 | agent))) 24 | 25 | (define *agent-number*) 26 | 27 | (define (agent:make-initial) 28 | (set! *agent-number* 0) 29 | (agent:make 'top-level-agent #f)) 30 | 31 | (define premise-in?) 32 | (define mark-premise-in!) 33 | (define mark-premise-out!) 34 | 35 | (define *worldview-number* 0) 36 | 37 | (define (install-agent! agent) 38 | (set! *scheduler* (agent:scheduler agent)) 39 | (set! *current-agent* agent) 40 | (set! premise-in? ((agent:worldview agent) 'premise-in?)) 41 | (set! mark-premise-in! ((agent:worldview agent) 'mark-premise-in!)) 42 | (set! mark-premise-out! ((agent:worldview agent) 'mark-premise-out!)) 43 | ;; *abort-process*, *last-value-of-run* ? 44 | 45 | ;; Probably should go away with good tracking of new stuff. 46 | (set! *worldview-number* (+ *worldview-number* 1)) 47 | (for-each ((agent:scheduler agent) 'alert-one) 48 | (all-propagators)) 49 | agent) 50 | 51 | 52 | (define (current-agent) 53 | *current-agent*) 54 | 55 | (define *premise-number* 0) 56 | 57 | (define (agent:make-premise #!optional description agent) 58 | (if (default-object? agent) 59 | (set! agent *current-agent*)) 60 | (if (default-object? description) 61 | (set! description "")) 62 | (set! *premise-number* (+ *premise-number* 1)) 63 | (let ((premise 64 | (symbol description "-by-" (name agent) 65 | "-premise-" *premise-number*))) 66 | ;;this probably breaks garbage collection (make weak ref?) 67 | (eq-put! premise 'agent agent) ; FIXME 68 | ;; default is IN within agent's scope. 69 | (((agent:worldview agent) 'mark-premise-in!) premise) 70 | (set! *worldview-number* (+ *worldview-number* 1)) 71 | premise)) 72 | 73 | (define (premise:creator-agent premise) 74 | (eq-get premise 'agent)) 75 | 76 | (define (worldview:make parent-agent) 77 | (let ((pi? (if parent-agent 78 | ((agent:worldview parent-agent) 'premise-in?) 79 | (lambda (premise) ;top-level: unknown 80 | (if (premise:creator-agent premise) 81 | #f ; private premises assumed out outside of scope. 82 | #t)))) ; top-level premises assumed in. 83 | 84 | (premise-status (make-eq-hash-table))) 85 | (define (premise-in? premise) 86 | (let ((status 87 | (hash-table/get premise-status premise 'unknown))) 88 | (cond ((eq? status 'unknown) (pi? premise)) ;ask parent 89 | (else status)))) 90 | (define (mark-premise-in! premise) 91 | (hash-table/put! premise-status premise #t)) 92 | (define (mark-premise-out! premise) 93 | (hash-table/put! premise-status premise #f)) 94 | (define (me message) 95 | (case message 96 | ((premise-in?) premise-in?) 97 | ((mark-premise-in!) mark-premise-in!) 98 | ((mark-premise-out!) mark-premise-out!) 99 | (else 100 | (error "unknown message -- WORLDVIEW" 101 | message)))) 102 | me)) 103 | -------------------------------------------------------------------------------- /core/amb-utils.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define-propagator (require cell) 25 | ((constant #t) cell)) 26 | (define require p:require) 27 | 28 | (define-propagator (forbid cell) 29 | ((constant #f) cell)) 30 | (define forbid p:forbid) 31 | 32 | (define-propagator-syntax (require-distinct cells) 33 | (for-each-distinct-pair 34 | (lambda (c1 c2) 35 | (forbid (e:eqv? c1 c2))) 36 | cells)) 37 | 38 | (define-propagator-syntax (one-of . cells) 39 | (let ((output (ensure-cell (car (last-pair cells)))) 40 | (inputs (map ensure-cell (except-last-pair cells)))) 41 | (cond ((= (length inputs) 2) 42 | (conditional (e:amb) (car inputs) (cadr inputs) output)) 43 | ((> (length inputs) 2) 44 | (conditional (e:amb) (car inputs) 45 | (apply e:one-of (cdr inputs)) output)) 46 | (else 47 | (error "Inadequate choices for one-of" 48 | inputs output))))) 49 | (propagator-constructor! one-of) 50 | (define p:one-of one-of) 51 | (define e:one-of (expression-style-variant one-of)) 52 | 53 | (define p:amb binary-amb) 54 | (define (e:amb) 55 | (let ((answer (make-named-cell (generate-cell-name)))) 56 | (binary-amb answer) 57 | (eq-put! answer 'subexprs '()) 58 | answer)) 59 | -------------------------------------------------------------------------------- /core/compound-data.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;;; Compound data 25 | 26 | ;;; The code for merging compound data turns out not to depend on the 27 | ;;; choice between the "copying data" or "carrying cells" strategies 28 | ;;; --- those are dependent entirely on what the constructor 29 | ;;; and accessor propagators do. 30 | 31 | ;;; Cons looks like this: 32 | #| 33 | (define (pair-equivalent? pair1 pair2) 34 | (and (equivalent? (car pair1) (car pair2)) 35 | (equivalent? (cdr pair1) (cdr pair2)))) 36 | 37 | (define (pair-merge pair1 pair2) 38 | (effectful-bind (merge (car pair1) (car pair2)) 39 | (lambda (car-answer) 40 | (effectful-bind (merge (cdr pair1) (cdr pair2)) 41 | (lambda (cdr-answer) 42 | (cons car-answer cdr-answer)))))) 43 | 44 | (defhandler merge pair-merge pair? pair?) 45 | (defhandler equivalent? pair-equivalent? pair? pair?) 46 | |# 47 | 48 | ;;; The generalization to arbitrary product types: 49 | 50 | (define (slotful-information-type predicate? constructor . accessors) 51 | (define (slotful-equivalent? thing1 thing2) 52 | (apply boolean/and 53 | (map (lambda (accessor) 54 | (equivalent? (accessor thing1) (accessor thing2))) 55 | accessors))) 56 | (define (slotful-merge thing1 thing2) 57 | (let* ((slots1 (map (lambda (accessor) (accessor thing1)) 58 | accessors)) 59 | (slots2 (map (lambda (accessor) (accessor thing2)) 60 | accessors))) 61 | (effectful-list-bind (map merge slots1 slots2) 62 | (lambda (submerges) 63 | (apply constructor submerges))))) 64 | (define (slotful-contradiction? thing) 65 | (any contradictory? (map (lambda (accessor) (accessor thing)) accessors))) 66 | (defhandler merge slotful-merge predicate? predicate?) 67 | (defhandler equivalent? slotful-equivalent? predicate? predicate?) 68 | (defhandler contradictory? slotful-contradiction? predicate?)) 69 | 70 | (slotful-information-type pair? cons car cdr) 71 | 72 | -------------------------------------------------------------------------------- /core/contradictions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define (tms-merge tms1 tms2) 25 | (let ((candidate (tms-assimilate tms1 tms2))) 26 | (effectful-bind (strongest-consequence candidate) 27 | (lambda (consequence) 28 | (if (not (contradictory? consequence)) ; ** 29 | (tms-assimilate candidate consequence) 30 | (make-effectful 31 | (tms-assimilate candidate consequence) 32 | (list (make-nogood-effect 33 | (v&s-support consequence))))))))) 34 | 35 | ;;; TODO TMS-QUERY is still hopelessly broken. The problem is that 36 | ;;; the effect of signaling a contradiction is being deferred from the 37 | ;;; point at which the worldview changes to the point at which some 38 | ;;; propagator tries to get the result. 39 | 40 | 41 | (define (tms-query tms) 42 | (let ((answer (strongest-consequence tms))) 43 | (let ((better-tms (tms-assimilate tms answer))) 44 | (if (not (eq? tms better-tms)) 45 | (set-tms-values! tms (tms-values better-tms))) 46 | (check-consistent! answer) ; ** 47 | answer))) 48 | 49 | (define (check-consistent! v&s) 50 | (if (contradictory? v&s) 51 | (process-nogood! (v&s-support v&s)))) 52 | 53 | #| 54 | ;;; Sussman's tentative and unpleasant patch for Micah's bug. 55 | ;;; Required change to core/test/dependencies-test.scm. 56 | 57 | (define (tms-query tms) 58 | (let ((answer (strongest-consequence tms))) 59 | (let ((better-tms (tms-assimilate tms answer))) 60 | (if (not (eq? tms better-tms)) 61 | (set-tms-values! tms (tms-values better-tms))) 62 | (if (contradictory? answer) 63 | (begin (process-nogood! (v&s-support answer)) 64 | nothing) 65 | answer)))) 66 | |# 67 | 68 | ;; Will be replaced by process-nogood! in search.scm 69 | (define (process-nogood! nogood) 70 | (abort-process `(contradiction ,(sort nogood premise. 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;; Example usages of propagator networks 25 | 26 | ;;; Unidirectional Fahrenheit to Celsius conversion 27 | 28 | (define-e:propagator (e:fahrenheit->celsius f) 29 | (e:* (e:- f 32) 5/9)) 30 | 31 | #| 32 | (initialize-scheduler) 33 | (define-cell f) 34 | (define-cell c) 35 | 36 | (p:fahrenheit->celsius f c) 37 | 38 | (add-content f 77) 39 | (run) 40 | (content c) 41 | ;Value: 25 42 | |# 43 | 44 | #| 45 | ;;; Here is a much more explicit way to write the same program 46 | 47 | (define-propagator (fahrenheit->celsius f c) 48 | (let-cells (thirty-two f-32 five c*9 nine) 49 | ((constant 32) thirty-two) 50 | ((constant 5) five) 51 | ((constant 9) nine) 52 | (p:- f thirty-two f-32) 53 | (p:* f-32 five c*9) 54 | (p:/ c*9 nine c))) 55 | |# 56 | 57 | ;;; Multidirectional Fahrenheit to Celsius to Kelvin conversion 58 | 59 | (define-propagator (c:fahrenheit-celsius f c) 60 | (c:== (ce:+ (ce:* c 9/5) 32) f)) 61 | (define-propagator (c:celsius-kelvin c k) 62 | (c:+ c 273.15 k)) 63 | 64 | #| 65 | (initialize-scheduler) 66 | (define-cell f) 67 | (define-cell c) 68 | 69 | (c:fahrenheit-celsius f c) 70 | 71 | (add-content c 25) 72 | (run) 73 | (content f) 74 | ;Value: 77 75 | 76 | (define-cell k) 77 | 78 | (c:celsius-kelvin c k) 79 | (run) 80 | (content k) 81 | ;Value: 298.15 82 | |# 83 | 84 | #| 85 | ;;; Same as above, but in diagram style 86 | 87 | (define-propagator (fahrenheit-celsius f c) 88 | (let-cells (f-32 c*9) 89 | (c:+ 32 f-32 f) 90 | (c:* f-32 5 c*9) 91 | (c:* c 9 c*9))) 92 | |# 93 | 94 | ;;; Measuring the height of a building using a barometer 95 | 96 | (define-e:propagator (ce:fall-duration t) 97 | (let-cell (g (make-interval 9.789 9.832)) 98 | (ce:* 1/2 (ce:* g (ce:square t))))) 99 | 100 | #| 101 | (initialize-scheduler) 102 | (define-cell fall-time) 103 | (define-cell building-height) 104 | (c:fall-duration fall-time building-height) 105 | 106 | (add-content fall-time (make-interval 2.9 3.1)) 107 | (run) 108 | (content building-height) 109 | ;Value: #(interval 41.163 47.243) 110 | |# 111 | ;;; In more ways than one 112 | 113 | (define-propagator (c:similar-triangles s-ba h-ba s h) 114 | (c:== (ce:* s-ba %% h-ba) 115 | (ce:* s %% h))) 116 | #| 117 | (initialize-scheduler) 118 | (define-cell barometer-height) 119 | (define-cell barometer-shadow) 120 | (define-cell building-height) 121 | (define-cell building-shadow) 122 | (c:similar-triangles barometer-shadow barometer-height 123 | building-shadow building-height) 124 | 125 | (add-content building-shadow (make-interval 54.9 55.1)) 126 | (add-content barometer-height (make-interval 0.3 0.32)) 127 | (add-content barometer-shadow (make-interval 0.36 0.37)) 128 | (run) 129 | (content building-height) 130 | ;Value: #(interval 44.514 48.978) 131 | 132 | (define-cell fall-time) 133 | (c:fall-duration fall-time building-height) 134 | 135 | (add-content fall-time (make-interval 2.9 3.1)) 136 | (run) 137 | (content building-height) 138 | ;Value: #(interval 44.514 47.243) 139 | 140 | (content barometer-height) 141 | ;Value: #(interval .3 .31839) 142 | ;; Refining the (make-interval 0.3 0.32) we put in originally 143 | 144 | (content fall-time) 145 | ;Value: #(interval 3.0091 3.1) 146 | ;; Refining (make-interval 2.9 3.1) 147 | 148 | (add-content building-height (make-interval 45 45)) 149 | (run) 150 | (content barometer-height) 151 | ;Value: #(interval .3 .30328) 152 | 153 | (content barometer-shadow) 154 | ;Value: #(interval .366 .37) 155 | 156 | (content building-shadow) 157 | ;Value: #(interval 54.9 55.1) 158 | 159 | (content fall-time) 160 | ;Value: #(interval 3.0255 3.0322) 161 | |# 162 | 163 | ;;; More goodies in ../examples/* 164 | -------------------------------------------------------------------------------- /core/general-scheduler.scm: -------------------------------------------------------------------------------- 1 | ;;; A more general scheduler that allows multiple agendas which may be 2 | ;;; arranged in priority order. The agenda identity is its oset. 3 | 4 | (define (make-general-scheduler starting-policy) 5 | 6 | (define agenda-oset car) 7 | (define agenda-policy cdr) 8 | (define make-agenda cons) 9 | 10 | (let* ((starting-oset (make-eq-oset)) 11 | (starting-agenda (make-agenda starting-oset starting-policy)) 12 | (current-agenda starting-agenda) 13 | (agendas (list current-agenda))) 14 | 15 | (define (next-agenda) 16 | (let lp ((agendas agendas)) 17 | (cond ((null? agendas) #f) 18 | ((> (oset-count (agenda-oset (car agendas))) 0) 19 | (car agendas)) 20 | (else (lp (cdr agendas)))))) 21 | 22 | (define (run-alerted) 23 | (let ((ca (next-agenda))) 24 | (if ca 25 | (begin 26 | (set! current-agenda ca) 27 | ((agenda-policy ca) (agenda-oset ca)) 28 | ;; yield 29 | (run-alerted)) 30 | (begin 31 | (set! current-agenda starting-agenda) 32 | 'done)))) 33 | 34 | (define (alert-one propagator #!optional agenda) 35 | (let ((ca 36 | (if (default-object? agenda) current-agenda agenda))) 37 | (if ca 38 | (oset-insert (agenda-oset ca) propagator) 39 | (oset-insert starting-oset propagator)))) 40 | 41 | 42 | (define (clear! #!optional agenda) 43 | (let ((ca (if (default-object? agenda) current-agenda agenda))) 44 | (if ca (oset-clear! (agenda-oset ca))))) 45 | 46 | (define (any-alerted?) 47 | (next-agenda)) 48 | 49 | (define (create-agenda policy direction base-agenda) 50 | (let ((split 51 | (split-list (lambda (e) (eq? (car e) base-agenda)) 52 | agendas)) 53 | (new-agenda (make-agenda (make-eq-oset) policy))) 54 | 55 | (if (not split) 56 | (error "Undefined base agenda -- CREATE-AGENDA")) 57 | (case direction 58 | ((before) 59 | (set! agendas 60 | (append (reverse (cons new-agenda (car split))) 61 | (list (cadr split)) 62 | (cddr split)))) 63 | ((after) 64 | (set! agendas 65 | (append (reverse (car split)) 66 | (list (cadr split)) 67 | (cons new-agenda (cddr split))))) 68 | (else (error "Bad direction -- CREATE-AGENDA"))) 69 | (car new-agenda))) ;return the oset. 70 | 71 | (define (me message) 72 | (cond ((eq? message 'run) (run-alerted)) 73 | ((eq? message 'alert-one) alert-one) 74 | ((eq? message 'clear!) (clear!)) ; Bug! 75 | ((eq? message 'done?) (not (any-alerted?))) 76 | ((eq? message 'create-agenda) create-agenda) 77 | ((eq? message 'current-agenda) current-agenda) 78 | (else 79 | (error "Bad message -- MAKE-GENERAL-SCHEDULER")))) 80 | 81 | me)) 82 | 83 | (define (lifo-policy oset) 84 | (let ((the-propagator (oset-pop! oset))) 85 | (execute-propagator the-propagator))) 86 | 87 | (define (make-lifo-scheduler) 88 | (make-general-scheduler lifo-policy)) 89 | 90 | 91 | 92 | (define (fifo-policy oset) 93 | (let ((the-propagator (oset-pop-tail! oset))) 94 | (execute-propagator the-propagator))) 95 | 96 | (define (make-fifo-scheduler) 97 | (make-general-scheduler fifo-policy)) 98 | 99 | 100 | 101 | 102 | 103 | 104 | (define (split-list p? lst) 105 | (let lp ((lst lst) (h '())) 106 | (cond ((null? lst) #f) 107 | ((p? (car lst)) 108 | (list h (car lst) (cdr lst))) 109 | (else 110 | (lp (cdr lst) (cons (car lst) h)))))) 111 | 112 | 113 | (set! make-scheduler make-round-robin-scheduler) 114 | 115 | ;;(set! make-scheduler make-fifo-scheduler) 116 | 117 | ;;(set! make-scheduler make-lifo-scheduler) 118 | -------------------------------------------------------------------------------- /core/generic-definitions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;;; General generic applicative functor machinery 25 | 26 | ;;; If a group of partial information structures fit into the 27 | ;;; applicative functor (TODO: Reference Paterson and McBride) 28 | ;;; paradigm, the network can be mechanically extended to handle them 29 | ;;; and their compositions. 30 | 31 | (define (binary-mapping f) 32 | (define (loop x y) 33 | (let ((mapper (binary-map x y))) 34 | (if (procedure? mapper) 35 | (mapper loop) 36 | (f x y)))) 37 | (name! loop f) 38 | loop) 39 | 40 | (define binary-map 41 | (make-generic-operator 2 'binary-map 42 | (lambda (x y) 'done!))) 43 | 44 | (defhandler binary-map 45 | (lambda (x y) (lambda (f) nothing)) 46 | nothing? any?) 47 | 48 | (defhandler binary-map 49 | (lambda (x y) (lambda (f) nothing)) 50 | any? nothing?) 51 | 52 | 53 | (defhandler binary-map 54 | (lambda (x y) (lambda (f) nothing)) 55 | contradictory? any?) 56 | 57 | (defhandler binary-map 58 | (lambda (x y) (lambda (f) nothing)) 59 | any? contradictory?) 60 | 61 | (define (unary-mapping f) 62 | (name! 63 | (lambda (x) 64 | ((binary-mapping (lambda (x y) (f x))) 65 | ;; TODO Make this 1 a real "object that can be coerced into anything" 66 | x 1)) 67 | f)) 68 | 69 | (define (nary-mapping f) 70 | (name! 71 | (lambda args 72 | (case (length args) 73 | ((0) (f)) 74 | ((1) ((unary-mapping f) (car args))) 75 | ((2) ((binary-mapping f) (car args) (cadr args))) 76 | (else 77 | (let loop ((args '()) (rest args)) 78 | (if (null? (cdr rest)) 79 | ((binary-mapping (lambda (lst item) 80 | (apply f (reverse (cons item lst))))) 81 | args (car rest)) 82 | (loop ((binary-mapping cons) (car rest) args) (cdr rest))))))) 83 | f)) 84 | 85 | ;;;; General generic-monadic machinery 86 | 87 | ;;; If a partial information structure fits into the monad paradigm, 88 | ;;; the portions of the network that are necessarily monadic rather 89 | ;;; than applicative-functorial can be automatically extended to that 90 | ;;; structure. Of course, since monads do not compose naturally, it 91 | ;;; is up to the user to effectively treat a group of partial 92 | ;;; information structures as forming a single monad where 93 | ;;; appropriate, and define corresponding cross-structure methods for 94 | ;;; these operations. 95 | ;;; TODO Does anything other than IF really need monads? 96 | 97 | (define (generic-bind thing function) 98 | (generic-flatten (generic-unpack thing function))) 99 | 100 | (define generic-unpack 101 | (make-generic-operator 2 'unpack 102 | (lambda (object function) 103 | (function object)))) 104 | 105 | (define generic-flatten 106 | (make-generic-operator 1 'flatten (lambda (object) object))) 107 | 108 | (define (%nary-unpacking function) 109 | (lambda args 110 | (let loop ((args args) 111 | (function function)) 112 | (if (null? args) 113 | (function) 114 | (generic-bind 115 | (car args) 116 | (lambda (arg) 117 | (loop (cdr args) 118 | (lambda remaining-args 119 | (apply function (cons arg remaining-args)))))))))) 120 | 121 | ;; This version also attaches the name information, for debugging and 122 | ;; drawing networks. 123 | (define (nary-unpacking function) 124 | (eq-label! (%nary-unpacking function) 'name function)) 125 | 126 | (defhandler generic-unpack 127 | (lambda (object function) nothing) 128 | nothing? any?) 129 | 130 | (defhandler generic-unpack 131 | (lambda (object function) nothing) 132 | contradictory? any?) 133 | 134 | 135 | ;;; This handler is redundant but harmless 136 | (defhandler generic-flatten 137 | (lambda (thing) nothing) 138 | nothing?) 139 | -------------------------------------------------------------------------------- /core/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-relative "../support/load") 34 | 35 | (for-each load-relative-compiled 36 | '("agent" 37 | "scheduler" 38 | "general-scheduler" 39 | ;;"metadata" 40 | "diagrams" 41 | "merge-effects" 42 | "cells" 43 | "diagram-cells" 44 | "cell-sugar" 45 | "propagators" 46 | "application" 47 | "sugar" 48 | "generic-definitions" 49 | "compound-data" 50 | "physical-closures" 51 | "standard-propagators" 52 | "carrying-cells" 53 | 54 | ;;Intervals must follow standard-propagators in the load order 55 | ;;because it depends on interval-non-zero?, numerical-zero?, 56 | ;;binary-nothing, and binary-contradiction previously defined. 57 | 58 | "intervals" 59 | "premises" 60 | "supported-values" 61 | "truth-maintenance" 62 | "contradictions" 63 | "search" 64 | "amb-utils" 65 | 66 | "ui" 67 | "explain" 68 | 69 | "example-networks" 70 | "test-utils")) 71 | 72 | (maybe-warn-low-memory) 73 | (initialize-scheduler) 74 | -------------------------------------------------------------------------------- /core/merge-effects.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;; Data structure to represent a merge result that may have effects. 25 | 26 | (define-structure effectful 27 | info 28 | effects) 29 | 30 | (define (effectful-return info) 31 | (make-effectful info '())) 32 | 33 | (define (->effectful thing) 34 | (if (effectful? thing) 35 | thing 36 | (effectful-return thing))) 37 | 38 | (define (effectful-> effectful) 39 | (let ((effectful (remove-redundant-effects effectful))) 40 | (if (null? (effectful-effects effectful)) 41 | (effectful-info effectful) 42 | effectful))) 43 | 44 | (define (remove-redundant-effects effectful) 45 | (make-effectful 46 | (effectful-info effectful) 47 | (filter (lambda (effect) 48 | (not (redundant-effect? effect))) 49 | (effectful-effects effectful)))) 50 | 51 | (define redundant-effect? 52 | (make-generic-operator 1 'redundant-effect? (lambda (thing) #f))) 53 | 54 | (define (effectful-flatten effectful) 55 | (let ((subeffectful (->effectful (effectful-info effectful)))) 56 | (let ((subinfo (effectful-info subeffectful)) 57 | (subeffects (effectful-effects subeffectful)) 58 | (effects (effectful-effects effectful))) 59 | (make-effectful subinfo (append effects subeffects))))) 60 | 61 | (define (effectful-merge e1 e2) 62 | (let ((e1 (->effectful e1)) 63 | (e2 (->effectful e2))) 64 | (let ((info-merge (->effectful (merge (effectful-info e1) 65 | (effectful-info e2))))) 66 | (effectful-> 67 | (make-effectful 68 | (effectful-info info-merge) 69 | (append (effectful-effects e1) 70 | (effectful-effects info-merge) 71 | (effectful-effects e2))))))) 72 | 73 | (define (effectful-bind effectful func) 74 | (let ((effectful (->effectful effectful))) 75 | (effectful-> 76 | (effectful-flatten 77 | (make-effectful 78 | (->effectful (func (effectful-info effectful))) 79 | (effectful-effects effectful)))))) 80 | 81 | (define (effectful-list-bind effectfuls func) 82 | (let ((effectfuls (map ->effectful effectfuls))) 83 | (effectful-> 84 | (effectful-flatten 85 | (make-effectful 86 | (->effectful (func (map effectful-info effectfuls))) 87 | (apply append (map effectful-effects effectfuls))))))) 88 | -------------------------------------------------------------------------------- /core/premises.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define (hypothetical-printer state object) 25 | (with-current-unparser-state state 26 | (lambda (port) 27 | (write `(hypothetical 28 | ,(hash object) 29 | ,(hypothetical-sign object) 30 | ,(if (premise-in? object) 'in 'out) 31 | ,@(name-stack (hypothetical-cell object))) 32 | port)))) 33 | 34 | (define-structure 35 | (hypothetical (type vector) (named 'hypothetical) 36 | (constructor %make-hypothetical) 37 | ;;(print-procedure #f) 38 | (print-procedure hypothetical-printer) 39 | (safe-accessors #t)) 40 | index 41 | sign 42 | cell) 43 | 44 | (define *hypothetical-count* 0) 45 | 46 | (define initialize-scheduler 47 | (let ((initialize-scheduler initialize-scheduler)) 48 | (lambda () 49 | (initialize-scheduler) 50 | (set! *hypothetical-count* 0)))) 51 | 52 | (define with-independent-scheduler 53 | (let ((with-independent-scheduler with-independent-scheduler)) 54 | (lambda args 55 | (fluid-let ((*hypothetical-count* 0)) ; TODO Is this right? 56 | (apply with-independent-scheduler args))))) 57 | 58 | (define (make-hypothetical sign cell) 59 | (set! *hypothetical-count* (+ *hypothetical-count* 1)) 60 | (%make-hypothetical *hypothetical-count* sign cell)) 61 | 62 | (define (premise. 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define-method generic-match ((pattern ) (object rtd:effectful)) 25 | (generic-match 26 | pattern 27 | (vector 'effectful (effectful-info object) 28 | (effectful-effects object)))) 29 | 30 | ;;; Test slotful structure 31 | 32 | (define-structure (kons (constructor kons)) 33 | kar 34 | kdr) 35 | (declare-type-tester kons? rtd:kons) 36 | 37 | (slotful-information-type kons? kons kons-kar kons-kdr) 38 | 39 | (define-method generic-match ((pattern ) (object rtd:kons)) 40 | (generic-match 41 | pattern 42 | (vector 'kons (kons-kar object) (kons-kdr object)))) 43 | 44 | (define-method generic-match ((pattern ) (object rtd:%interval)) 45 | (generic-match 46 | pattern 47 | (vector 'interval (interval-low object) (interval-high object)))) 48 | 49 | (define-method generic-match ((pattern ) (object rtd:nogood-effect)) 50 | (generic-match 51 | pattern 52 | (vector 'nogood-effect (nogood-effect-nogood object)))) 53 | 54 | (define-method generic-match ((pattern ) (object )) 55 | ;; Account for v&ses and tmses, as well as standard vectors. 56 | (define (match-vectors pattern object) 57 | (and (= (vector-length pattern) (vector-length object)) 58 | (reduce boolean/and #t (map generic-match 59 | (vector->list pattern) 60 | (vector->list object))))) 61 | (define (match-v&s pattern object) 62 | ;; vector-ref because the patterns are often explicit vectors 63 | ;; (rather than v&s objects) which are too short, so they don't 64 | ;; pass the checks performed by the safe accessors. 65 | (and (generic-match (vector-ref pattern 1) (v&s-value object)) 66 | (generic-match (sort (vector-ref pattern 2) premise. 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | barometer 24 | 25 | (define-test (barometer-example) 26 | (interaction 27 | (initialize-scheduler) 28 | (define-cell barometer-height) 29 | (define-cell barometer-shadow) 30 | (define-cell building-height) 31 | (define-cell building-shadow) 32 | (c:similar-triangles 33 | barometer-shadow barometer-height building-shadow building-height) 34 | (add-content building-shadow (make-interval 54.9 55.1)) 35 | (add-content barometer-height (make-interval 0.3 0.32)) 36 | (add-content barometer-shadow (make-interval 0.36 0.37)) 37 | (run) 38 | 39 | (content building-height) 40 | (produces #(interval 44.51351351351351 48.977777777777774)) 41 | 42 | (define-cell fall-time) 43 | (c:fall-duration fall-time building-height) 44 | (add-content fall-time (make-interval 2.9 3.1)) 45 | (run) 46 | 47 | (content building-height) 48 | (produces #(interval 44.51351351351351 47.24276000000001)) 49 | 50 | (content barometer-height) 51 | (produces #(interval .3 .3183938287795994)) 52 | 53 | (content fall-time) 54 | (produces #(interval 3.0091234174691017 3.1)) 55 | 56 | (add-content building-height 45) 57 | (run) 58 | 59 | (content barometer-height) 60 | (produces #(interval .3 .30327868852459017)) 61 | 62 | (content barometer-shadow) 63 | (produces #(interval .366 .37)) 64 | 65 | (content building-shadow) 66 | (produces #(interval 54.9 55.1)) 67 | 68 | (content fall-time) 69 | (produces #(interval 3.025522031629098 3.0321598338046556))))) 70 | -------------------------------------------------------------------------------- /core/test/carrying-cells-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | carrying-cells 24 | (define-test (smoke) 25 | (interaction 26 | (initialize-scheduler) 27 | (define-cell bill (make-tms (supported 3 '(bill)))) 28 | (define-cell bill-cons (e:carry-cons nothing bill)) 29 | (define-cell answer) 30 | (c:== bill-cons answer) 31 | (define-cell fred (make-tms (supported 4 '(fred)))) 32 | (define-cell fred-cons (e:carry-cons fred nothing)) 33 | (define-cell george (make-tms (supported #t '(george)))) 34 | (conditional-wire george fred-cons answer) 35 | (define-cell the-pair? (e:carry-pair? answer)) 36 | (define-cell the-car (e:carry-car answer)) 37 | (define-cell the-cdr (e:carry-cdr answer)) 38 | (run) 39 | ; (pp (content answer)) 40 | (content the-pair?) 41 | (produces #t) 42 | (content the-car) 43 | (produces #(tms (#(supported 4 (fred george))))) 44 | (content the-cdr) 45 | (produces #(tms (#(supported 3 (bill))))))) 46 | 47 | ;; This test exercises the following situation: v&s-merge is merging 48 | ;; v&s1 and v&s2, where the value of v&s1 is more informative than 49 | ;; the value of v&s2 when viewed unconditionally; but if one 50 | ;; conditions on the premises in the support of v&s1, then the values 51 | ;; actually are equivalent. Further, the support of v&s2 is more 52 | ;; informative than the support of v&s1, containing fewer premises. 53 | ;; Furthermore, it is true (but possibly not relevant) that merging 54 | ;; the values of v&s1 and v&s2 produces whichever is given first 55 | ;; (because they are cells) together with an effect which becomes 56 | ;; redundant when conditioned on the union of the supports of v&s1 57 | ;; and v&s2 (and is duly filtered out). 58 | 59 | ;; In this situation, v&s-merge returns v&s1 because its value is 60 | ;; unconditionally more informative than the value of v&s2; but 61 | ;; arguably it should return v&s2. Logically, the situation looks 62 | ;; something like this: 63 | ;; A -> () -> X merge () -> A -> X 64 | ;; which probably ought to emit () -> A -> X. The analogy is not 65 | ;; quite right, because the X's are not actually the same, being 66 | ;; merged cells. 67 | (define-test (cell-in-v&s) 68 | (interaction 69 | (define-cell four 4) 70 | (define-cell george-four (supported 4 '(george))) 71 | (execute-effect 72 | (make-cell-join-effect 73 | four 74 | george-four 75 | (make-tms (supported #t '(george))))) 76 | (define v&s1 (supported four '(george))) 77 | (define v&s2 (supported george-four '())) 78 | ;; Given the way four and george-four are connected, v&s2 is 79 | ;; strictly more informative, so merging the twain should produce 80 | ;; it. 81 | (merge v&s1 v&s2) 82 | (produces v&s2))) 83 | 84 | (define-test (early-access-test) 85 | (interaction 86 | (initialize-scheduler) 87 | (define-cell source-car) 88 | (define-cell source-cdr) 89 | (define-cell the-pair (e:carry-cons source-car source-cdr)) 90 | (check (eq? source-car (e:carry-car the-pair))) 91 | (check (eq? source-cdr (e:carry-cdr the-pair))) 92 | )) 93 | 94 | (define-test (deposit) 95 | (interaction 96 | (initialize-scheduler) 97 | (define-cell two-cell (e:deposit 2)) 98 | (run) 99 | (check (cell? two-cell)) 100 | (check (cell? (content two-cell))) 101 | (content (content two-cell)) 102 | (produces 2) 103 | (define-cell examined (e:examine two-cell)) 104 | (content examined) 105 | (produces 2))) 106 | 107 | (define-test (examine) 108 | (interaction 109 | (initialize-scheduler) 110 | (define-cell examinee) 111 | (define-cell exam (e:examine examinee)) 112 | (add-content exam 2) 113 | (run) 114 | (check (cell? (content examinee))) 115 | (content (content examinee)) 116 | (produces 2))) 117 | ) 118 | -------------------------------------------------------------------------------- /core/test/compound-merges-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | compound-merges 24 | (define-each-check 25 | (generic-match (cons nothing nothing) (merge (cons nothing nothing) nothing)) 26 | (generic-match (cons nothing nothing) (merge nothing (cons nothing nothing))) 27 | (generic-match 28 | (cons nothing nothing) (merge (cons nothing nothing) (cons nothing nothing))) 29 | (generic-match (cons 4 nothing) (merge nothing (cons 4 nothing))) 30 | (generic-match (cons 4 nothing) (merge (cons 4 nothing) nothing)) 31 | (generic-match (cons 4 nothing) (merge (cons 4 nothing) (cons 4 nothing))) 32 | (generic-match the-contradiction (merge 4 (cons 5 6))) 33 | (generic-match the-contradiction (merge 4 (cons 4 5))) 34 | (generic-match the-contradiction (merge 4 (cons nothing nothing))) 35 | (generic-match '(4 . 5) (merge (cons nothing 5) (cons 4 nothing))) 36 | (generic-match '(4 . 5) (merge (cons 4 nothing) (cons nothing 5))) 37 | (generic-match '(4 . 5) (merge (cons 4 5) (cons 4 nothing))) 38 | (generic-match '(4 . 5) (merge (cons 4 nothing) (cons 4 5))) 39 | (generic-match '(4 . 5) (merge (cons 4 5) (cons 4 5))) 40 | ;; This 41 | #; 42 | (merge (make-tms (supported (cons (make-tms (supported 4 '(fred))) nothing) 43 | '(george))) 44 | (make-tms (supported (cons nothing (make-tms (supported 3 '(bill)))) 45 | '()))) 46 | ;; is mysterious because the result should, I think, look like 47 | ;; (4:fred,george . 3:bill), but I'm not sure how to make it do 48 | ;; that. Also, 49 | #; 50 | (merge (make-tms (supported (cons (make-tms (supported 4 '(fred))) nothing) 51 | '(george))) 52 | (make-tms (supported the-contradiction '(fred george)))) 53 | ;; (or the moral equivalents thereof) should retain the fact that 54 | ;; george said there was a pair here (in case there's a pair? 55 | ;; propagator watching), but can probably afford to get rid of the 56 | ;; 4:fred inside, because if the pair is believed, then george is, 57 | ;; so fred isn't. 58 | ) 59 | 60 | (define-test (recursive-tms-merge) 61 | (check 62 | (generic-match 63 | #(effectful 64 | #(tms 65 | (#(supported 66 | (#(tms (#(supported #(*the-contradiction*) (bill fred)) 67 | #(supported 4 (fred)) 68 | #(supported 3 (bill)))) 69 | . 70 | #(*the-nothing*)) 71 | (george joe)) 72 | #(supported 73 | (#(tms (#(supported 3 (bill)))) . #(*the-nothing*)) (joe)) 74 | #(supported 75 | (#(tms (#(supported 4 (fred)))) . #(*the-nothing*)) 76 | (george)))) 77 | (#(nogood-effect (joe george bill fred)))) 78 | (merge (make-tms (supported 79 | (cons (make-tms (supported 4 '(fred))) nothing) 80 | '(george))) 81 | (make-tms (supported 82 | (cons (make-tms (supported 3 '(bill))) nothing) 83 | '(joe))))))) 84 | 85 | (define-test (recursive-tms-merge-2) 86 | (check 87 | (generic-match 88 | #(effectful 89 | #(tms 90 | (#(supported 91 | #(kons #(tms (#(supported #(*the-contradiction*) (bill fred)) 92 | #(supported 4 (fred)) 93 | #(supported 3 (bill)))) 94 | #(*the-nothing*)) 95 | (george joe)) 96 | #(supported 97 | #(kons #(tms (#(supported 3 (bill)))) #(*the-nothing*)) (joe)) 98 | #(supported 99 | #(kons #(tms (#(supported 4 (fred)))) #(*the-nothing*)) 100 | (george)))) 101 | (#(nogood-effect (joe george bill fred)))) 102 | (merge (make-tms (supported 103 | (kons (make-tms (supported 4 '(fred))) nothing) 104 | '(george))) 105 | (make-tms (supported 106 | (kons (make-tms (supported 3 '(bill))) nothing) 107 | '(joe))))))) 108 | 109 | ) 110 | -------------------------------------------------------------------------------- /core/test/copying-data-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | ;;; The "copying data" strategy from the thesis is given by these 23 | ;;; definitions of the cons-car-cdr propagators: 24 | #| 25 | (define conser (function->propagator-constructor cons)) 26 | (define carer (function->propagator-constructor (nary-unpacking car))) 27 | (define cdrer (function->propagator-constructor (nary-unpacking cdr))) 28 | |# 29 | ;;; This strategy is tested here, with the definitions in question 30 | ;;; appearing inside the test scope below. 31 | 32 | ;;; The "carrying cells" strategy is elaborated in 33 | ;;; extensions/carrying-cells.scm. Since the merging is the same in 34 | ;;; both cases, the two strategies may be intermixed within the same 35 | ;;; network --- just make sure your propagators know what to expect 36 | ;;; (and there is as yet no good story for merging a piece of data and 37 | ;;; a cell, so merging a carrying cons with a copying cons will not do 38 | ;;; anything good). 39 | 40 | (in-test-group 41 | copying-data 42 | 43 | (define-test (example) 44 | (interaction 45 | (define conser (function->propagator-constructor cons)) 46 | (define carer (function->propagator-constructor (nary-unpacking car))) 47 | (define cdrer (function->propagator-constructor (nary-unpacking cdr))) 48 | 49 | (initialize-scheduler) 50 | 51 | (define-cell x) 52 | (define-cell y) 53 | (define-cell pair) 54 | (conser x y pair) 55 | 56 | (run) 57 | (content pair) 58 | (produces '( #(*the-nothing*) . #(*the-nothing*) )) 59 | 60 | (define-cell control) 61 | (define-cell switched-pair) 62 | (switch control pair switched-pair) 63 | 64 | (add-content control (make-tms (supported #t '(joe)))) 65 | (run) 66 | (content switched-pair) 67 | (produces #(tms (#(supported ( #(*the-nothing*) . #(*the-nothing*) ) (joe))))) 68 | 69 | (define-cell x-again) 70 | (carer switched-pair x-again) 71 | 72 | (run) 73 | (content x-again) 74 | (produces #(*the-nothing*)) 75 | 76 | (add-content x (make-tms (supported 4 '(harry)))) 77 | 78 | (run) 79 | (content pair) 80 | (produces '( #(tms (#(supported 4 (harry)))) . #(*the-nothing*) )) 81 | 82 | (content switched-pair) 83 | (produces #(tms (#(supported ( #(tms (#(supported 4 (harry)))) . #(*the-nothing*) ) 84 | (joe))))) 85 | 86 | (content x-again) 87 | (produces #(tms (#(supported 4 (harry joe))))) 88 | ))) 89 | -------------------------------------------------------------------------------- /core/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (for-each load-relative 23 | '("scheduler-test" 24 | "core-test" 25 | "metadata-test" 26 | "dependencies-test" 27 | "partial-compounds-test" 28 | "switches-test" 29 | "compound-merges-test" 30 | "copying-data-test" 31 | "carrying-cells-test" 32 | "physical-closures-test" 33 | "barometer-test")) 34 | -------------------------------------------------------------------------------- /core/test/metadata-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2011 Alexey Radul and Gerald Jay Sussman 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | metadata 24 | 25 | (define-test (macrology-smoke) 26 | (initialize-scheduler) 27 | (let-cells ((foo (make-cell)) 28 | bar 29 | (baz (make-cell))) 30 | (check (eq? 'foo (name foo))) 31 | (check (not (eq-get foo 'name))) 32 | (check (eq? 'bar (name bar))) 33 | (check (eq? 'bar (eq-get bar 'name))) 34 | (check (eq? 'baz (name baz))) 35 | (check (not (eq-get baz 'name))) 36 | )) 37 | ) 38 | -------------------------------------------------------------------------------- /core/test/partial-compounds-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | partial-compounds 24 | 25 | (define caring-function (nary-unpacking car)) 26 | 27 | (define-each-check 28 | (initialize-scheduler) ;; Why I need this is a mystery to me 29 | (equal? nothing (caring-function nothing)) 30 | (equal? nothing (caring-function (cons nothing 5))) 31 | (equal? 3 (caring-function (cons 3 5))) 32 | (equal? 4 (generic-unpack (cons 4 5) car)) 33 | 34 | (generic-match 35 | #(supported 4 (joe)) 36 | (generic-flatten (supported 4 '(joe)))) 37 | (generic-match 38 | #(supported 4 (joe)) 39 | (generic-unpack (supported (cons 4 5) '(joe)) car)) 40 | (generic-match 41 | #(supported 4 (joe)) 42 | (caring-function (supported (cons 4 5) '(joe)))) 43 | (generic-match 44 | #(supported 4 (harry joe)) 45 | (caring-function (supported (cons (supported 4 '(harry)) 5) '(joe)))) 46 | (generic-match 47 | #(supported 4 (harry joe)) 48 | (caring-function (supported (cons (supported 4 '(harry)) 49 | (supported 5 '(george))) 50 | '(joe)))) 51 | (generic-match 52 | nothing 53 | (caring-function (supported (cons nothing 5) '(joe)))) 54 | 55 | (generic-match 56 | #(tms (#(supported 4 (harry joe)))) 57 | (caring-function (make-tms (supported (cons (supported 4 '(harry)) 5) '(joe))))) 58 | (generic-match 59 | #(tms (#(supported 4 (harry joe)))) 60 | (caring-function 61 | (make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe))))) 62 | 63 | (generic-match 64 | nothing 65 | (disbelieving 'joe 66 | (caring-function 67 | (make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe)))))) 68 | 69 | (generic-match 70 | nothing 71 | (disbelieving 'harry 72 | (caring-function 73 | (make-tms (supported (cons (make-tms (supported 4 '(harry))) 5) '(joe)))))) 74 | 75 | (generic-match 76 | #(tms (#(supported 4 (harry joe)))) 77 | (disbelieving 'george 78 | (caring-function 79 | (make-tms (supported (cons (make-tms (supported 4 '(harry))) 80 | (make-tms (supported 5 '(george)))) 81 | '(joe)))))) 82 | 83 | (generic-match 84 | nothing 85 | (caring-function 86 | (make-tms (supported (cons nothing 4) '(joe))))) 87 | 88 | (generic-match 89 | #(tms (#(supported #(interval 4 5) (harry joe)))) 90 | (caring-function 91 | (make-tms 92 | (supported (cons (make-tms (supported (make-interval 4 5) '(harry))) 5) 93 | '(joe))))) 94 | )) 95 | -------------------------------------------------------------------------------- /core/test/scheduler-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | scheduler 24 | 25 | (define (with-every-scheduler thunk) 26 | (for-each 27 | (lambda (scheduler) 28 | (fluid-let ((make-scheduler scheduler)) 29 | (thunk))) 30 | (list make-round-robin-scheduler 31 | make-stack-scheduler 32 | make-two-stack-scheduler 33 | make-robin-stack-scheduler 34 | make-two-robin-scheduler))) 35 | 36 | (define-test (smoke) 37 | (with-every-scheduler 38 | (lambda () 39 | (let ((run-count 0)) 40 | (define (run-me) 41 | (set! run-count (+ run-count 1))) 42 | (initialize-scheduler) 43 | (check (= 0 (length (all-propagators)))) 44 | (check (= 0 run-count)) 45 | (alert-propagators run-me) 46 | (check (= 1 (length (all-propagators)))) 47 | ;; Running actually runs 48 | (check (eq? 'done (run))) 49 | (check (= 1 run-count)) 50 | (check (= 1 (length (all-propagators)))) 51 | ;; No spurious reruns 52 | (check (eq? 'done (run))) 53 | (check (= 1 run-count)) 54 | (check (= 1 (length (all-propagators))))))))) 55 | -------------------------------------------------------------------------------- /distributed/load-client.scm: -------------------------------------------------------------------------------- 1 | 2 | (load-relative "slrpc/slrpc-cps") 3 | (load-relative "propagators-client") 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /distributed/load-server.scm: -------------------------------------------------------------------------------- 1 | (load-relative "slrpc/slrpc-cps") 2 | (load-relative "propagators-server") 3 | 4 | ;;; (server-start) 5 | 6 | -------------------------------------------------------------------------------- /distributed/propagators-client.scm: -------------------------------------------------------------------------------- 1 | ;;; Client: 2 | 3 | (define propagators-port 5390) 4 | 5 | (define (client-connect password #!optional host port) 6 | (let ((client (create-rpc-client)) 7 | (port (if (default-object? port) propagators-port port)) 8 | (address (if (default-object? host) "localhost" host))) 9 | (connect-rpc-client client port address) 10 | (list 'propclient client password))) 11 | 12 | (define (client-disconnect client) 13 | (disconnect-rpc-client (cadr client))) 14 | 15 | (define (client-access-service client service-id #!optional password) 16 | ((bind-rpc-call (cadr client) "access-thing") 17 | service-id 18 | (if (default-object? password) (caddr client) 19 | password))) 20 | 21 | (define (get-remote-cell client cell-name) 22 | (let ((remote-entity 23 | ((client-access-service client 'get-cell) 24 | cell-name)) 25 | (remote-invoker 26 | (client-access-service client 'cell-invoke))) 27 | (let ((proxycell 28 | (make-entity 29 | (lambda args 30 | (error "don't apply a remote cell!")) 31 | (lambda args 32 | (remote-invoker remote-entity args))))) 33 | (eq-put! proxycell 'cell #t) 34 | (register-diagram proxycell) ; Don't know if this is appropriate or not! 35 | proxycell))) 36 | 37 | 38 | ; FIXME: neighbors, who, etc don't behave reasonably as they do not proxy 39 | ; cells as above. also cells contaning cells aren't handled either. 40 | 41 | 42 | (attach-special-object-id nothing "csail.mit.edu/ProjectMAC/Propagators/Nothing") 43 | (register-portable-record-type 44 | (record-type-descriptor (make-interval 1 2)) 45 | "csail.mit.edu/ProjectMAC/Propagators/Interval") 46 | 47 | 48 | #| 49 | ;;;; Demo 50 | ;;; Assume that the password is "". 51 | 52 | (define client (client-connect "" "127.0.0.1" propagators-port)) 53 | ;Value: client 54 | 55 | (define testcell 56 | (get-remote-cell client 'testcell)) 57 | ;Value: testcell 58 | 59 | (content testcell) 60 | ;Value: #(*the-nothing*) 61 | 62 | (nothing? (content testcell)) 63 | ;Value: #t 64 | 65 | (add-content testcell 123) 66 | ;Unspecified return value 67 | 68 | (content testcell) 69 | ;Value: 123 70 | 71 | 72 | (define testcell3 (get-remote-cell client 'testcell3)) 73 | ;Value: testcell3 74 | 75 | (content testcell3) 76 | ;Value: #(*the-nothing*) 77 | 78 | (add-content testcell3 (make-interval 1 10)) 79 | ;Unspecified return value 80 | 81 | (content testcell3) 82 | ;Value: #[interval 1 10] 83 | 84 | (add-content testcell3 (make-interval 2 20)) 85 | ;Unspecified return value 86 | 87 | (content testcell3) 88 | ;Value: #[interval 2 10] 89 | 90 | ... 91 | 92 | 93 | 94 | (client-disconnect client) 95 | |# -------------------------------------------------------------------------------- /distributed/propagators-server.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ProjectMAC/propagators/add671f009e62441e77735a88980b6b21fad7a79/distributed/propagators-server.scm -------------------------------------------------------------------------------- /distributed/slrpc/rpctxtscraps.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | End-to-end vs. composable error handling 4 | 5 | One might ask, why not just implement end-to-end error handling? Why 6 | not rely on garbage collection to eventually clean up old, abandoned 7 | continuations, and rather than worrying about which continuations 8 | should report network errors when, just have the initiator of a 9 | complex call wait for a timeout? This can be made to work, in 10 | scenarios similar to where turnstiles can be used, but it comes with 11 | truly horrible composability properties. There is no guarantee that 12 | dynamic-wind actions will ever be run -- it depends on the lifetimes 13 | of continuations. There is no way to tell where a network error 14 | occured -- a call simply fails after timing out. Finding the problem 15 | will require bolting on an entirely separate traceback mechanism, 16 | which may or may not give fresh and accurate results. Most 17 | importantly, the choices of timeout values are quite arbitrary, 18 | difficult to pick and failing to compose in any sensible fashion. A 19 | parameterized call must have either a carefully tuned, parameterized 20 | timeout or a worst-case timeout. A call that combines multiple calls 21 | with built-in timeouts must still include its own higher-level 22 | timeouts, and it cannot predict without actually going through the 23 | call what the sum of all lower-level timeouts will be. Typically, the 24 | most practical solution is to set extremely generous timeouts on 25 | everything and to outlaw long-running calls by fiat. This works fine 26 | in the absence of network errors, but when errors do occur, otherwise 27 | short-running calls suffer excruciating delays. Regardless of 28 | strategy, the result is clumsy and brittle, requiring constant 29 | supervision. 30 | 31 | # ..too much bull-loni. aliveness heartbeats/timeouts? 32 | 33 | 34 | There are, of course, better-refined end-to-end strategies that are 35 | not quite so ridiculous. For example, one might allow only the 36 | end-consumer of a service to set timeouts and do so based on the 37 | responsiveness needs of the user interface rather than on the speed of 38 | the implementation. Again, however, there is a serious breakdown in 39 | composability. 40 | 41 | A hybrid approach can provide somewhat better results. For example, foo-bar-baz et all 42 | Or, one could track the chain of machines 43 | traversed during a demarcated call and propagate periodic heartbeats 44 | 45 | 46 | 47 | 48 | 49 | # ... 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /doc/Rakefile: -------------------------------------------------------------------------------- 1 | # Three definitions copied and modified from Alexey's rake-latex.rb. 2 | # The modification is to remove the dependency on the 3 | # :{eps/pdf}pictures tasks, on the suspicion that that dependency was 4 | # causing spurious re-texing. 5 | # Also using rubber instead of pdflatex. 6 | def pdflatex filename 7 | desc "LaTeX #{filename}.tex to a PDF" 8 | file "#{filename}.pdf" => ["#{filename}.tex"] do 9 | sh "rubber --pdf #{filename}.tex" 10 | end 11 | task :pdflatex => "#{filename}.pdf" 12 | end 13 | 14 | def autobib filename 15 | file "#{filename}.aux" => :pdflatex 16 | file "#{filename}-auto.bib" => "#{filename}.aux" do 17 | bibdump = "#{ENV['HOME']}/work/papers/bibdump.rb" 18 | if File.executable?(bibdump) 19 | sh "#{bibdump} #{filename}" 20 | else 21 | puts "Can't find the bibliography dumping program, ignoring" 22 | touch "#{filename}-auto.bib" 23 | end 24 | end 25 | file "#{filename}.bbl" => ["#{filename}-auto.bib"] do 26 | sh "bibtex #{filename}" 27 | end 28 | desc "Regenerate the bibliography data" 29 | task :bibtex => "#{filename}.bbl" 30 | end 31 | # End copied definitions 32 | 33 | task :doc => :pdflatex 34 | 35 | pdflatex "revised" 36 | autobib "revised" 37 | 38 | file "revised-html.tex" => "revised.tex" do 39 | sh "cat revised.tex | grep -v hypertarget | grep -v pdfbookmark > revised-html.tex" 40 | end 41 | 42 | file "revised-html/revised-html.html" => "revised-html.tex" do 43 | sh "rubber --pdf revised-html.tex" 44 | sh "latex2html -split 0 -nonavigation revised-html" 45 | end 46 | 47 | task :doc => "revised.html" 48 | 49 | file "revised.html" => "revised-html/revised-html.html" do 50 | sh "cp revised-html/revised-html.html revised-html.html" 51 | end 52 | -------------------------------------------------------------------------------- /doc/art.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ProjectMAC/propagators/add671f009e62441e77735a88980b6b21fad7a79/doc/art.pdf -------------------------------------------------------------------------------- /doc/bib.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp scheme 2 | 3 | (require scriblib/autobib) 4 | (provide (all-defined-out)) 5 | 6 | (define-cite ~cite citet generate-bib) 7 | 8 | (define axch (author-name "Alexey" "Radul")) 9 | (define gjs (author-name "Gerald Jay" "Sussman")) 10 | (define mit "Massachusetts Institute of Technology, Cambridge, MA") 11 | (define csail-tr "CSAIL Technical Report") 12 | 13 | (define art-thesis 14 | (make-bib 15 | #:author axch 16 | #:title "Propagation Networks: A Flexible and Expressive Substrate for Computation" 17 | #:date "2009" ; September 18 | #:url "http://hdl.handle.net/1721.1/49525" 19 | #:location (dissertation-location #:institution mit) 20 | #:is-book? #t)) 21 | 22 | (define art 23 | (make-bib 24 | #:author (authors axch gjs) 25 | #:title "The Art of the Propagator" 26 | #:location (techrpt-location 27 | #:institution csail-tr 28 | #:number "MIT-CSAIL-TR-2009-002") 29 | #:date "2009" 30 | #:url "http://hdl.handle.net/1721.1/44215")) 31 | 32 | (define mcbride-paterson-2008-applicative-functors 33 | (make-bib 34 | #:author (authors "Conor McBride" "Ross Paterson") 35 | #:title "Applicative programming with effects" 36 | #:location (journal-location "Journal of Functional Programming" 37 | #:pages (list 1 13) 38 | #:number 1 39 | #:volume 18) 40 | #:date "2008")) 41 | -------------------------------------------------------------------------------- /doc/phd-thesis.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ProjectMAC/propagators/add671f009e62441e77735a88980b6b21fad7a79/doc/phd-thesis.pdf -------------------------------------------------------------------------------- /doc/preamble.tex: -------------------------------------------------------------------------------- 1 | %%%% Alexey's general-purpose LaTeX stuff 2 | 3 | %% Paper size is a persistent annoyance. The (current) suggested 4 | %% strategy is to always use letterpaper or a4paper options to 5 | %% documentclass, and see to it that \pdfpagewidth and \pdfpageheight 6 | %% get set correctly. The color package, for example, does the 7 | %% latter. 8 | 9 | %% Also be sure to view the document at the right paper size with 10 | %% xdvi, and print it at the right paper size with dvips. 11 | 12 | \usepackage{amsmath} 13 | \usepackage{amsthm} 14 | \usepackage{amsfonts} 15 | \usepackage{amssymb} 16 | 17 | \usepackage{epsfig} 18 | \usepackage{graphicx} 19 | \usepackage[usenames]{color} 20 | 21 | \usepackage{ifpdf} 22 | 23 | \newtheorem{theorem}{Theorem}[section] 24 | \newtheorem{lemma}[theorem]{Lemma} 25 | \newtheorem{corollary}[theorem]{Corollary} 26 | \newtheorem{statement}[theorem]{Statement} 27 | \newtheorem{conjecture}[theorem]{Conjecture} 28 | 29 | \ifpdf 30 | \DeclareGraphicsRule{.pdftex}{pdf}{.pdftex}{} 31 | \else 32 | \fi 33 | 34 | %%% Commands 35 | \newcommand{\code}[1]{{\tt #1}} 36 | \newcommand{\defn}[1]{{\bfseries{#1}}} 37 | \newcommand{\todo}[1]{{\bf *** TODO: {#1} ***}} 38 | %% The idea here is to mark todo items that will not be showstoppers 39 | %% if the todo comment just vanishes. 40 | \newcommand{\otodo}[1]{{\bf *** TODO (Optional): {#1} ***}} 41 | % \renewcommand{\otodo}[1]{{}} % Like so. 42 | 43 | \def\caret{\^\,\hspace{-2pt}} 44 | 45 | %%% Shortcuts 46 | \newcommand{\be}{\begin{equation}} %numbered equations 47 | \newcommand{\ee}{\end{equation}} 48 | \newcommand{\bea}{\begin{eqnarray}} 49 | \newcommand{\eea}{\end{eqnarray}} 50 | \newcommand{\beas}{\begin{eqnarray*}} 51 | \newcommand{\eeas}{\end{eqnarray*}} 52 | \newcommand{\bl}{\begin{lisp}} 53 | \newcommand{\el}{\end{lisp}} 54 | \newcommand{\bls}{\begin{lisp*}} 55 | \newcommand{\els}{\end{lisp*}} 56 | \newcommand{\bv}{\begin{verbatim}{}} 57 | \newcommand{\ev}{\end{verbatim}{}} 58 | \newcommand{\LRa}{\ensuremath{\Leftrightarrow}} 59 | \newcommand{\Ra}{\ensuremath{\Rightarrow}} 60 | \newcommand{\La}{\ensuremath{\Leftarrow}} 61 | 62 | %%% Pictures 63 | \newlength{\pagepic} 64 | \setlength{\pagepic}{390pt} 65 | 66 | \newlength{\halfpagepic} 67 | \setlength{\halfpagepic}{210pt} 68 | 69 | \newcommand{\magicpicture}[1]{% 70 | \ifpdf 71 | \input{pictures/#1.pdftex_t} 72 | \else 73 | \input{pictures/#1.pstex_t} 74 | \fi} 75 | 76 | \newcommand{\diagram}[2]{% 77 | \begin{figure*} 78 | \begin{center} 79 | \includegraphics[width=\pagepic]{pictures/#1} 80 | \caption{{{#2}}} 81 | \label{fig:#1} 82 | \end{center} 83 | \end{figure*} 84 | } 85 | 86 | \newcommand{\magicdiagram}[2]{% 87 | \begin{figure*} 88 | \begin{center} 89 | \magicpicture{#1} 90 | \caption{{{#2}}} 91 | \label{fig:#1} 92 | \end{center} 93 | \end{figure*} 94 | } 95 | 96 | \newcommand{\twocaptiondiagram}[3]{% 97 | \begin{figure*} 98 | \begin{center} 99 | \magicpicture{#1} 100 | \caption[{{#2}}]{{{#3}}} 101 | \label{fig:#1} 102 | \end{center} 103 | \end{figure*} 104 | } 105 | 106 | %%% Floating controls. See discussion at 107 | %%% http://dcwww.camd.dtu.dk/~schiotz/comp/LatexTips/LatexTips.html 108 | \renewcommand{\topfraction}{0.85} 109 | \renewcommand{\textfraction}{0.1} 110 | \renewcommand{\floatpagefraction}{0.75} 111 | -------------------------------------------------------------------------------- /doc/rake-latex.rb: -------------------------------------------------------------------------------- 1 | # require File.dirname(__FILE__) + "/fix-xfig-fonts.rb" 2 | 3 | desc "Crunch all xfigs to eps" 4 | task :epspictures 5 | 6 | desc "Crunch all xfigs to pdf" 7 | task :pdfpictures 8 | 9 | def latex filename 10 | desc "LaTeX #{filename}.tex" 11 | file "#{filename}.dvi" => ["#{filename}.tex", :epspictures] do 12 | sh "latex #{filename}.tex" 13 | end 14 | task :latex => "#{filename}.dvi" 15 | end 16 | 17 | def pdflatex filename 18 | desc "LaTeX #{filename}.tex to a PDF" 19 | file "#{filename}.pdf" => ["#{filename}.tex", :pdfpictures] do 20 | sh "pdflatex #{filename}.tex" 21 | end 22 | task :pdflatex => "#{filename}.pdf" 23 | end 24 | 25 | def autobib filename 26 | file "#{filename}.aux" => :pdflatex 27 | file "#{filename}-auto.bib" => "#{filename}.aux" do 28 | bibdump = "#{ENV['HOME']}/work/papers/bibdump.rb" 29 | if File.executable?(bibdump) 30 | sh "#{bibdump} #{filename}" 31 | else 32 | puts "Can't find the bibliography dumping program, ignoring" 33 | touch "#{filename}-auto.bib" 34 | end 35 | end 36 | file "#{filename}.bbl" => ["#{filename}-auto.bib"] do 37 | sh "bibtex #{filename}" 38 | end 39 | desc "Regenerate the bibliography data" 40 | task :bibtex => "#{filename}.bbl" 41 | end 42 | 43 | ## Xfig integration 44 | 45 | # eps or pdf 46 | # latex string processing (need figure size) or not 47 | # layer selection 48 | # layered animations 49 | # - named layers? 50 | 51 | def figure outfile, infile=outfile 52 | process_fig outfile, infile, "eps", "" 53 | process_fig outfile, infile, "pdf", "" 54 | end 55 | 56 | def fig_layer outfile, layers, infile=outfile 57 | process_fig outfile, infile, "eps", "-K -D #{layers}" 58 | process_fig outfile, infile, "pdf", "-K -D #{layers}" 59 | end 60 | 61 | def fig_animation outfile, layers_list, infile=outfile 62 | layers_list.each_index do |i| 63 | fig_layer "#{outfile}-#{i}", layers_list[i], infile 64 | end 65 | end 66 | 67 | def special_figure outfile, size=12, infile=outfile 68 | process_fig outfile, infile, "pstex", "-Z #{size}" 69 | process_fig outfile, infile, "pdftex", "-Z #{size}" 70 | end 71 | 72 | def special_fig_layer outfile, layers, infile=outfile, size=12 73 | process_fig outfile, infile, "pstex", "-K -D #{layers} -Z #{size}" 74 | process_fig outfile, infile, "pdftex", "-K -D #{layers} -Z #{size}" 75 | end 76 | 77 | def special_fig_animation outfile, layers_list, infile=outfile, size=12 78 | layers_list.each_index do |i| 79 | special_fig_layer "#{outfile}-#{i}", layers_list[i], infile, size 80 | end 81 | end 82 | 83 | def process_fig outfile, infile, format, options 84 | ensure_legal_fig_format format 85 | full_out_name = "#{outfile}.#{format}" 86 | desc "Produce #{full_out_name}" 87 | file full_out_name => "#{infile}.fig" do 88 | sh "fig2dev -L #{format} #{options} #{infile}.fig #{full_out_name}" 89 | end 90 | task pictures_task(format) => full_out_name 91 | if fig_latex_strings_wanted? format 92 | file "#{full_out_name}_t" => full_out_name do 93 | sh "fig2dev -L #{format}_t #{options} -F -p #{full_out_name} #{infile}.fig #{full_out_name}_t" 94 | fix_font_size outfile, format 95 | end 96 | if format == "pdftex" 97 | task "#{full_out_name}_t" => "#{outfile}.pstex" 98 | end 99 | task pictures_task(format) => "#{full_out_name}_t" 100 | end 101 | end 102 | 103 | def legal_fig_formats 104 | ["eps", "pdf", "pstex", "pdftex"] 105 | end 106 | 107 | def ensure_legal_fig_format format 108 | if legal_fig_formats.member? format 109 | # OK 110 | else 111 | raise "Illegal format #{format} for figure output." 112 | end 113 | end 114 | 115 | def pictures_task format 116 | case format 117 | when "eps" : :epspictures 118 | when "pstex" : :epspictures 119 | when "pdf" : :pdfpictures 120 | when "pdftex": :pdfpictures 121 | end 122 | end 123 | 124 | def fig_latex_strings_wanted? format 125 | ["pstex", "pdftex"].member? format 126 | end 127 | -------------------------------------------------------------------------------- /doc/revised-auto.bib: -------------------------------------------------------------------------------- 1 | @string{and = { and }} 2 | 3 | @string{axch = {Alexey Radul}} 4 | @string{gjs = {Gerald Jay Sussman}} 5 | @string{gls = {Guy L. {Steele Jr.}}} 6 | @string{cph = {Chris Hanson}} 7 | @string{alan-borning = {Alan H. Borning}} 8 | @string{dam = {David Allen McAllester}} 9 | @string{zabih = {Ramin Zabih}} 10 | @string{rms = {Richard Matthew Stallman}} 11 | @string{johan-dekleer = {Johan {de Kleer}}} 12 | @string{clinger = {William D. Clinger}} 13 | @string{shriram = {Shriram Krishnamurthi}} 14 | @string{greg-cooper = {Gregory H. Cooper}} 15 | @string{spj = {Simon L. Peyton Jones}} 16 | @string{wadler = {Philip Wadler}} 17 | @string{koller = {D. Koller}} 18 | @string{pfeffer = {Avi Pfeffer}} 19 | @string{paul-hudak = {Paul Hudak}} 20 | @string{conal-elliott = {Conal Elliott}} 21 | 22 | @string{mit = {Massachusetts Institute of Technology}} 23 | @string{ailab = {MIT Artificial Intelligence Laboratory}} 24 | @string{csail = {MIT Computer Science and Artificial Intelligence Laboratory}} 25 | @string{mit-press = {MIT Press}} 26 | @string{mit-address = {Cambridge, MA}} 27 | @string{cambridge-u-press = {Cambridge University Press}} 28 | @string{cambridge-u-address = {Cambridge, UK}} 29 | %% TODO Hack to get the address of the ACM rather than of the conferences 30 | %% they sponsor 31 | @string{acm = {Association for Computing Machinery, New York, NY}} 32 | @string{new-york = ""} 33 | 34 | @techreport{art, 35 | title = {{The Art of the Propagator}}, 36 | author = axch # and # gjs, 37 | year = 2009, 38 | institution= csail, 39 | type = {CSAIL Tech Report}, 40 | number = {MIT-CSAIL-TR-2009-002}, 41 | note = {\url{http://hdl.handle.net/1721.1/44215}}, 42 | publisher = mit, 43 | address = mit-address 44 | } 45 | 46 | @phdthesis{art-thesis, 47 | author = axch, 48 | title = {{Propagation Networks: A Flexible and Expressive 49 | Substrate for Computation}}, 50 | school = mit, 51 | year = 2009, 52 | address = mit-address, 53 | month = sep, 54 | note = {\url{http://hdl.handle.net/1721.1/49525}} 55 | } 56 | 57 | @article{mcbride-paterson-2008-applicative-functors, 58 | title = {{Applicative programming with effects}}, 59 | author = {McBride, Conor and Paterson, Ross}, 60 | journal = {Journal of Functional Programming}, 61 | volume = 18, 62 | number = 1, 63 | pages = {1-13}, 64 | year = 2008, 65 | publisher = {Cambridge University Press, 32 Avenue of the Americas 66 | New York NY 10013-2473 USA} 67 | } 68 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | @import url(html4css1.css); 2 | 3 | body { 4 | background: white; 5 | font-family: verdana, arial, helvetica, sans-serif; 6 | margin: 0px; 7 | padding: 6px; 8 | } 9 | 10 | h1, h2 { 11 | color: #333333; 12 | margin-top: 0px; 13 | margin-bottom: 0px; 14 | padding-top: 0.0em; 15 | } 16 | 17 | p { 18 | margin-top: 0.5em; 19 | text-align: justify; 20 | } 21 | 22 | .document { 23 | max-width: 50em; 24 | margin: 0 auto; 25 | } 26 | 27 | /* People list */ 28 | .people { overflow: auto; } 29 | .person { 30 | float: left; 31 | text-align: center; 32 | padding: .5em; 33 | width: 160px; 34 | height: 180px; 35 | } 36 | .person img { height: 120px; } 37 | .person .name { font-weight: bold; } 38 | .person { font-size: 80%; } 39 | -------------------------------------------------------------------------------- /examples/Rakefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2009-2010 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of Propagator Network Prototype. 5 | ### 6 | ### Propagator Network Prototype is free software; you can redistribute it and/or modify 7 | ### it under the terms of the GNU General Public License as published by 8 | ### the Free Software Foundation, either version 3 of the License, or 9 | ### (at your option) any later version. 10 | ### 11 | ### Propagator Network Prototype is distributed in the hope that it will be useful, 12 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ### GNU General Public License for more details. 15 | ### 16 | ### You should have received a copy of the GNU General Public License 17 | ### along with Propagator Network Prototype. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | def scheme command 21 | sh "mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --load load --eval '(begin #{command} (%exit 0))'" 22 | end 23 | 24 | def dot_dump command, filename 25 | task "#{filename}.dot" do 26 | scheme "(initialize-scheduler) #{command} (draw:write-graph-to-file \"#{filename}.dot\")" 27 | end 28 | task "dot-graphs" => "#{filename}.dot" 29 | end 30 | 31 | def graphml_dump command, filename 32 | task "#{filename}.graphml" do 33 | scheme "(initialize-scheduler) #{command} (fluid-let ((draw:format (quote graphml))) (draw:write-graph-to-file \"#{filename}.graphml\"))" 34 | end 35 | task "graphmls" => "#{filename}.graphml" 36 | task :pictures => "#{filename}.graphml" 37 | end 38 | 39 | def dot_process filename, format 40 | file "#{filename}.#{format}" => "#{filename}.dot" do 41 | sh "dot -T#{format} -o #{filename}.#{format} #{filename}.dot" 42 | end 43 | task :pictures => "#{filename}.#{format}" 44 | end 45 | 46 | def picture command, filename 47 | dot_dump command, filename 48 | dot_process(filename, "svg") 49 | dot_process(filename, "png") 50 | graphml_dump command, filename 51 | end 52 | 53 | picture "(define-cell f) (define-cell c) (fahrenheit->celsius f c)", "fahrenheit-to-celsius" 54 | picture "(define-cell f) (define-cell c) (define-cell k) (fahrenheit-celsius f c) (celsius-kelvin c k)", "temperature" 55 | picture "(define-cell fall-time) (define-cell building-height) (define-cell barometer-height) (define-cell barometer-shadow) (define-cell building-shadow) (fall-duration fall-time building-height) (similar-triangles barometer-shadow barometer-height building-shadow building-height)", "barometer" 56 | picture "(define-cell x) (define-cell sqrt-x) (sqrt-network x sqrt-x) (add-content x 2) (run)", "recursive-sqrt" 57 | picture "(multiple-dwelling)", "multiple-dwelling" 58 | picture "(multiple-dwelling-expressions)", "multiple-dwelling-expressions" 59 | picture "(build-network)", "riddle-of-the-knights" 60 | picture "(build-albatross-network)", "albatross-conundrum" 61 | -------------------------------------------------------------------------------- /examples/electric-parts.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Gerald Jay Sussman and Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;; Primitive data structures 25 | 26 | (define (electric-terminal i e) 27 | (cons i e)) 28 | (define (current terminal) 29 | (car terminal)) 30 | (define (potential terminal) 31 | (cdr terminal)) 32 | 33 | ;; TODO (re)insert optional names for cells and devices 34 | (define ((2-terminal-device vic) t1 t2) 35 | "We measure the voltage from t1 to t2 (i.e. v = e(t1) - e(t2)), 36 | and the current is measured as flowing into t1." 37 | (let ((i1 (current t1)) (e1 (potential t1)) 38 | (i2 (current t2)) (e2 (potential t2))) 39 | (let-cells (v P) 40 | (c:+ v e2 e1) 41 | (c:+ i1 i2 0) 42 | (c:* i1 v P) 43 | (vic v i1) 44 | P))) 45 | 46 | (define (linear-resistor R) 47 | (2-terminal-device 48 | (lambda (v i) 49 | (c:* R i v)))) 50 | 51 | (define (voltage-source strength) 52 | (2-terminal-device 53 | (lambda (v i) 54 | (c:== strength v)))) 55 | 56 | (define (current-source strength) 57 | (2-terminal-device 58 | (lambda (v i) 59 | (c:== strength i)))) 60 | 61 | (define (ground node) 62 | (p:== 0 (potential (car node)))) 63 | 64 | (define spst-switch p:conditional-wire) 65 | 66 | (define (node n) 67 | (let ((e (make-cell)) 68 | (is 69 | (let lp ((n n)) 70 | (cond ((= n 1) 71 | (let-cell i 72 | (list i i))) 73 | ((= n 2) 74 | (let-cells (i1 i2 i) 75 | (c:+ i1 i2 i) 76 | (list i i1 i2))) 77 | ((even? n) 78 | (let ((a1 (lp (/ n 2))) 79 | (a2 (lp (/ n 2))) 80 | (a (make-cell))) 81 | (c:+ (car a1) (car a2) a) 82 | (cons a (append (cdr a1) (cdr a2))))) 83 | ((odd? n) 84 | (let ((a1 (lp (- n 1))) 85 | (i2 (make-cell)) 86 | (a (make-cell))) 87 | (c:+ (car a1) i2 a) 88 | (cons a (cons i2 (cdr a1))))) 89 | (else (error)))))) 90 | ((constant 0) (car is)) 91 | (map (lambda (i) 92 | (electric-terminal i e)) 93 | (cdr is)))) 94 | 95 | 96 | ;;; Support for slices -- GJS 97 | 98 | (define (clone-terminal terminal) 99 | (electric-terminal (current terminal) 100 | (potential terminal))) 101 | 102 | (define (ideal-diode) 103 | (2-terminal-device 104 | (lambda (v i) 105 | (let-cells (if>=0 vreverse vr<=0 iforward conducting -conducting) 106 | ;;#t=>conducting; #f=>not conducting 107 | (p:amb conducting) 108 | (p:not conducting -conducting) 109 | (spst-switch conducting 0 v) 110 | (spst-switch -conducting v vreverse) 111 | (c:<= vr<=0 vreverse 0) 112 | (require vr<=0) 113 | (spst-switch -conducting 0 i) 114 | (spst-switch conducting i iforward) 115 | (c:>= if>=0 iforward 0) 116 | (require if>=0))))) 117 | -------------------------------------------------------------------------------- /examples/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-relative "../extensions/load.scm") 34 | 35 | (for-each 36 | load-relative-compiled 37 | '("multiple-dwelling" 38 | "recursive-sqrt" 39 | "masyu" 40 | "sudoku" 41 | "riddle-of-the-knights" 42 | "albatross-conundrum" 43 | "belief-propagation" 44 | "electric-parts" 45 | "selectors/data" 46 | )) 47 | 48 | (for-each 49 | load-relative 50 | '("selectors/selectors")) 51 | 52 | (maybe-warn-low-memory) 53 | (initialize-scheduler) 54 | -------------------------------------------------------------------------------- /examples/multiple-dwelling.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define-propagator-syntax (p:multiple-dwelling) 25 | (let-cells (baker cooper fletcher miller smith 26 | b=5 c=1 f=5 f=1 m>c sf fc one five s-f as-f f-c af-c) 27 | (one-of 1 2 3 4 5 baker) (one-of 1 2 3 4 5 cooper) 28 | (one-of 1 2 3 4 5 fletcher) (one-of 1 2 3 4 5 miller) 29 | (one-of 1 2 3 4 5 smith) 30 | (require-distinct 31 | (list baker cooper fletcher miller smith)) 32 | ((constant 1) one) ((constant 5) five) 33 | (p:= five baker b=5) (forbid b=5) 34 | (p:= one cooper c=1) (forbid c=1) 35 | (p:= five fletcher f=5) (forbid f=5) 36 | (p:= one fletcher f=1) (forbid f=1) 37 | (p:> miller cooper m>c) (require m>c) 38 | (p:- smith fletcher s-f) 39 | (p:abs s-f as-f) 40 | (p:= one as-f sf) (forbid sf) 41 | (p:- fletcher cooper f-c) 42 | (p:abs f-c af-c) 43 | (p:= one af-c fc) (forbid fc) 44 | (list baker cooper fletcher miller smith))) 45 | 46 | #| 47 | (initialize-scheduler) 48 | (define answers (p:multiple-dwelling)) 49 | (run) 50 | (map v&s-value (map tms-query (map content answers))) 51 | ;Value: '(3 2 4 5 1) 52 | 53 | *number-of-calls-to-fail* 54 | ;Value: 33 55 | |# 56 | 57 | ;;; Here's how you write the same program in expression style 58 | (define-propagator-syntax (p:multiple-dwelling-expressions) 59 | (let-cells ((baker (e:one-of 1 2 3 4 5)) 60 | (cooper (e:one-of 1 2 3 4 5)) 61 | (fletcher (e:one-of 1 2 3 4 5)) 62 | (miller (e:one-of 1 2 3 4 5)) 63 | (smith (e:one-of 1 2 3 4 5))) 64 | (require-distinct 65 | (list baker cooper fletcher miller smith)) 66 | (forbid (e:= baker 5)) 67 | (forbid (e:= cooper 1)) 68 | (forbid (e:= fletcher 5)) 69 | (forbid (e:= fletcher 1)) 70 | (require (e:> miller cooper)) 71 | (forbid (e:= 1 (e:abs (e:- fletcher smith)))) 72 | (forbid (e:= 1 (e:abs (e:- fletcher cooper)))) 73 | (list baker cooper fletcher miller smith))) 74 | 75 | #| 76 | (initialize-scheduler) 77 | (define answers (p:multiple-dwelling-expressions)) 78 | (run) 79 | (map v&s-value (map tms-query (map content answers))) 80 | ;Value: '(3 2 4 5 1) 81 | 82 | *number-of-calls-to-fail* 83 | ;Value: 33 84 | |# 85 | -------------------------------------------------------------------------------- /examples/recursive-sqrt.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define-e:propagator (e:heron-step x g) 25 | (e:/ (e:+ g (e:/ x g)) 2)) 26 | 27 | (define-e:propagator (e:sqrt-iter x g) 28 | (e:if (x g) (e:good-enuf? x g) 29 | g 30 | (e:sqrt-iter x (e:heron-step x g)))) 31 | 32 | (define-e:propagator (e:sqrt-network x) 33 | (e:sqrt-iter x 1.0)) 34 | 35 | (define-e:propagator (e:good-enuf? x g) 36 | (let-cell (eps .00000001) 37 | (e:< (e:abs (e:- x (e:* g g))) eps))) 38 | 39 | #| 40 | (initialize-scheduler) 41 | (define-cell x) 42 | (define-cell answer (e:sqrt-network x)) 43 | 44 | (add-content x 2) 45 | (run) 46 | (content answer) 47 | ;Value: 1.4142135623746899 48 | |# 49 | 50 | (define-propagator (p:factorial-1 n n!) 51 | (p:when (n n!) (e:not (e:= 0 n)) 52 | (p:== (e:* n (e:factorial-1 (e:- n 1))) n!)) 53 | (switch (e:= 0 n) 1 n!)) 54 | 55 | (define-propagator (p:factorial-2 n n!) 56 | (p:if (n n!) (e:= 0 n) 57 | (p:== 1 n!) 58 | (p:== (e:* n (e:factorial-2 (e:- n 1))) n!))) 59 | 60 | (define-e:propagator (e:factorial-3 n) 61 | (ce:== (e:when (n) (e:not (e:= 0 n)) 62 | (e:* n (e:factorial-3 (e:- n 1)))) 63 | (e:switch (e:= 0 n) 1))) 64 | 65 | (define-e:propagator (e:factorial-4 n) 66 | (e:if (n) (e:= 0 n) 67 | 1 68 | (e:* n (e:factorial-4 (e:- n 1))))) 69 | 70 | (define-e:propagator (e:kernel fact) 71 | (lambda-e:propagator (n) 72 | (import fact) 73 | (e:if (n) (e:= n 0) 74 | 1 75 | (e:* n (e@ fact (e:- n 1)))))) 76 | 77 | -------------------------------------------------------------------------------- /examples/run-examples: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(begin (load "load") (load "slow-examples") (flush-output) (run-tests-and-exit))' 4 | -------------------------------------------------------------------------------- /examples/run-mechanics-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec ../extensions/mechanics --compiler -heap 6000 --batch-mode --no-init-file --eval \ 4 | "(begin 5 | (if (lexical-unbound? system-global-environment 'let-fluids) 6 | (set! load/suppress-loading-message? #t) 7 | (set-fluid! load/suppress-loading-message? #t)) 8 | (load \"load\") 9 | (load \"test/mechanics-load\") 10 | (run-tests-and-exit))" 11 | -------------------------------------------------------------------------------- /examples/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval \ 4 | "(begin 5 | (if (lexical-unbound? system-global-environment 'let-fluids) 6 | (set! load/suppress-loading-message? #t) 7 | (set-fluid! load/suppress-loading-message? #t)) 8 | (load \"load\") 9 | (load \"test/load\") 10 | (run-tests-and-exit))" 11 | -------------------------------------------------------------------------------- /examples/selectors/code-slides.scm: -------------------------------------------------------------------------------- 1 | 2 | (define-macro-propagator (fast-air-estimate segment) 3 | (let-cells (same-city? same-city-answer intercity-answer) 4 | (same-city segment same-city?) 5 | (conditional same-city? 6 | same-city-answer intercity-answer segment) 7 | (conditional-writer same-city? 8 | segment same-city-answer intercity-answer) 9 | (fast-incity-air-estimate same-city-answer) 10 | (fast-intercity-air-estimate intercity-answer))) 11 | -------------------------------------------------------------------------------- /examples/selectors/fae.fig: -------------------------------------------------------------------------------- 1 | #FIG 3.2 Produced by xfig version 3.2.5 2 | Landscape 3 | Center 4 | Inches 5 | Letter 6 | 100.00 7 | Single 8 | -2 9 | 1200 2 10 | 6 5325 4500 6750 5025 11 | 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 12 | 5325 4500 6750 4500 6750 5025 5325 5025 5325 4500 13 | 4 0 0 50 -1 0 14 0.0000 4 210 1005 5550 4800 Same City\001 14 | -6 15 | 6 2625 4875 3975 6525 16 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 3300 5625 36 36 3300 5625 3336 5625 17 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 2925 6150 36 36 2925 6150 2961 6150 18 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 3675 6150 36 36 3675 6150 3711 6150 19 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3 20 | 3300 4875 3300 5625 3150 6225 21 | 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 22 | 3975 6525 2625 6525 2625 5250 3975 5250 3975 6525 23 | -6 24 | 6 8475 4875 9825 6525 25 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 9150 5625 36 36 9150 5625 9186 5625 26 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 8775 6150 36 36 8775 6150 8811 6150 27 | 1 3 0 1 0 0 50 -1 20 0.000 1 0.0000 9525 6150 36 36 9525 6150 9561 6150 28 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 3 29 | 9150 4875 9150 5625 9000 6225 30 | 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 31 | 9825 6525 8475 6525 8475 5250 9825 5250 9825 6525 32 | -6 33 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 1950 1802 1802 6000 1950 7800 2025 34 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 3150 450 450 6000 3150 6000 3600 35 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 5025 1275 450 450 5025 1275 5025 1725 36 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6975 2625 450 450 6975 2625 6975 3075 37 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 7050 1425 450 450 7050 1425 7050 1875 38 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 4950 2475 450 450 4950 2475 4950 2925 39 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6075 750 450 450 6075 750 6075 1200 40 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 5925 450 450 6000 5925 6000 6375 41 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 7200 450 450 6000 7200 6000 7650 42 | 1 3 0 1 0 7 50 -1 -1 0.000 1 0.0000 6000 8850 450 450 6000 8850 6000 9300 43 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 44 | 0 0 1.00 60.00 120.00 45 | 6000 3750 6000 4500 46 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 47 | 0 0 1.00 60.00 120.00 48 | 6000 5025 6000 5475 49 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 50 | 0 0 1.00 60.00 120.00 51 | 5550 5925 3975 5925 52 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 1 3 53 | 0 0 1.00 60.00 120.00 54 | 3300 4875 3300 2025 4200 2025 55 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 1 3 56 | 0 0 1.00 60.00 120.00 57 | 7800 2100 9150 2100 9150 4875 58 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 2 59 | 0 0 1.00 60.00 120.00 60 | 6450 5925 8475 5925 61 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3 62 | 0 0 1.00 60.00 120.00 63 | 3675 6150 3675 7200 5550 7200 64 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3 65 | 0 0 1.00 60.00 120.00 66 | 2925 6150 2925 8850 5550 8850 67 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3 68 | 0 0 1.00 60.00 120.00 69 | 6450 8850 9525 8850 9525 6150 70 | 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 71 | 3675 7575 5100 7575 5100 8100 3675 8100 3675 7575 72 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 3 73 | 0 0 1.00 60.00 120.00 74 | 0 0 1.00 60.00 120.00 75 | 5100 7875 5400 7875 5700 7500 76 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 1 3 77 | 0 0 1.00 60.00 120.00 78 | 0 0 1.00 60.00 120.00 79 | 6300 8550 6600 8175 6900 8175 80 | 2 2 0 1 0 7 50 -1 -1 0.000 0 0 -1 0 0 5 81 | 6900 7875 8325 7875 8325 8400 6900 8400 6900 7875 82 | 2 1 0 1 0 7 50 -1 -1 0.000 0 0 -1 1 0 3 83 | 0 0 1.00 60.00 120.00 84 | 6450 7200 8775 7200 8775 6150 85 | 4 0 0 50 -1 0 14 0.0000 4 225 840 5475 2025 Segment\001 86 | 4 0 0 50 -1 0 14 0.0000 4 165 435 4800 1350 Start\001 87 | 4 0 0 50 -1 0 14 0.0000 4 165 735 5700 825 Method\001 88 | 4 0 0 50 -1 0 14 0.0000 4 165 495 4725 2550 Cost \001 89 | 4 0 0 50 -1 0 14 0.0000 4 165 420 5775 3225 Pain\001 90 | 4 0 0 50 -1 0 14 0.0000 4 165 510 6750 2700 Time\001 91 | 4 0 0 50 -1 0 14 0.0000 4 165 390 6900 1500 End\001 92 | 4 0 0 50 -1 0 14 0.0000 4 165 405 5850 6000 SC?\001 93 | 4 0 0 50 -1 0 14 0.0000 4 165 480 5775 7275 SCA\001 94 | 4 0 0 50 -1 0 14 0.0000 4 165 420 5775 8925 ICA\001 95 | 4 0 0 50 -1 0 14 0.0000 4 165 705 4050 7875 FICEA\001 96 | 4 0 0 50 -1 0 14 0.0000 4 165 690 7200 8175 FITAE\001 97 | -------------------------------------------------------------------------------- /examples/selectors/plan.txt: -------------------------------------------------------------------------------- 1 | Propagators for Critic-Selector Structures 2 | 3 | Big problem: how to build the critic-selector 4 | architecture in such a way that it is flexible and 5 | can be easily extended as new requirements arise. 6 | 7 | Critical idea is to organize such a program as a 8 | collection of data repositories, each about a 9 | particular subject matter, and a network of agents 10 | that unify the information in neighboring 11 | repositories to make a coherent model of the 12 | world. 13 | 14 | It is important to build standards that enable the 15 | addition of repositories and agents as needed. 16 | 17 | 18 | 19 | Alexey has constructed a small example 20 | illustrating how such a critic-selector model may 21 | be constructed for a particular microworld. This 22 | particular model has only two levels, but it is an 23 | appropriate playground to help us identify the 24 | barriers to make bigger and more powerful such 25 | models, maintaining the flexibility that we will 26 | need for systems where the details emerge only 27 | after considerable structure is constructed. 28 | 29 | In this case the micro world is modeling the 30 | deliberative process whereby Alexey might 31 | determine an acceptable travel plan to go from 32 | Alexey's house in Brookline to the Metropolitan 33 | Opera House in Manhattan. 34 | 35 | Of course, this is a solved problem, using 36 | well-known optimization methods, such as 37 | Dijkstra's algorithm. But here we do not want an 38 | optimal special-purpose algorithm for just this 39 | kind of problem. 40 | 41 | We want our model to have plausible psychological 42 | reality. We want to construct it in a way that is 43 | consistent with our introspective perception of of 44 | the way we solve this kind of problem in our 45 | everyday lives. 46 | 47 | So Alexey's model is intended to emulate 48 | deliberation, the incremental proposal, selection, 49 | and elaboration of alternative plans, under the 50 | watchful eyes of critics that can shut down any 51 | elaboration for an arbitrary reason (e.g. "You 52 | won't get me to go to Newark!") 53 | 54 | 55 | 56 | A few slides of the execution 57 | 58 | Some places and paths: 59 | 60 | Alexey's Residence 61 | 62 | 63 | 64 | Beaconsfield T stop 65 | 66 | 67 | 68 | South Station, Logan Airport 69 | 70 | 71 | 72 | Penn Station, Laguardia Airport, etc 73 | 74 | 75 | 76 | 125th&LexingtonAve 77 | 78 | 79 | 80 | 59th Stop, 57th Stop 81 | 82 | 83 | 84 | MET 85 | (W64&Amsterdam) 86 | 87 | 88 | 89 | Cognitive Architecture 90 | 91 | The proposer/selector 92 | of alternative plans, 93 | 94 | Walk 95 | Subway 96 | Fly 97 | Train 98 | Bus 99 | 100 | The splitter of plans 101 | 102 | There are specialized elaborators 103 | for each kind of plan. 104 | 105 | The critic layer 106 | 107 | I hate Newark 108 | Airports are a hassle 109 | Price must be below ... 110 | Time should be short 111 | 112 | I want to make the 8PM performance 113 | 114 | Program Architecture 115 | 116 | Builder of network 117 | Propagators of travel data 118 | Scheduling of work 119 | 120 | 121 | 122 | The propagator infrastructure 123 | 124 | Cells and Propagators 125 | 126 | Simple example execution 127 | 128 | Reversability 129 | 130 | Merging and information monotonicity 131 | 132 | Dependencies 133 | 134 | Hypotheticals and world-views 135 | 136 | Backtracking 137 | 138 | Summary 139 | 140 | Thinking of software as hardware 141 | 142 | Wiring diagrams 143 | 144 | Locality of data with processing 145 | 146 | Processing proportional to data 147 | repositories 148 | 149 | 150 | This infrastructure captures all of the known 151 | paradigms of programming in such a way that they 152 | can coexist and cooperate to form a large system 153 | that retains flexibility. 154 | -------------------------------------------------------------------------------- /examples/selectors/todo.txt: -------------------------------------------------------------------------------- 1 | Explore behavior of full thing 2 | - Get it to decide to fly, to take the train, etc 3 | - Observe fully-elaborated methods 4 | - Method compounder 5 | - Method merger 6 | 7 | Pull the annoyance out of the computation, and make the critics deduce 8 | the annoyance from the method, and control the search with arbitrary 9 | criteria. 10 | 11 | Prettify the program for display. 12 | 13 | Add more metadata for pictures. 14 | - Better grouping of subfunctions 15 | - Better names for split nodes and choice nodes 16 | Draw pictures. 17 | -------------------------------------------------------------------------------- /examples/test/belief-propagation-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | belief-propagation 24 | 25 | (define-each-check 26 | (generic-match 27 | #(message ((#t . 1.) (#f . 1.))) ; Message to Alarm 28 | (pointwise-sum-product 29 | (lambda (alarm john) 30 | (force-assoc 31 | (list alarm john) 32 | '(((#t #t) . .9) 33 | ((#t #f) . .09999999999999998) 34 | ((#f #t) . .05) 35 | ((#f #f) . .95)))) 36 | (list #t #f) ; Alarm's support 37 | (make-message '((#t . 1) (#f . 1))))) ; Message from John 38 | (generic-match 39 | #(message ((#t . 1.) (#f . 1.))) ; Message to earthquake 40 | (pointwise-sum-product 41 | (lambda (earthquake burglary alarm) 42 | (force-assoc 43 | (list burglary earthquake alarm) 44 | '(((#t #t #t) . .95) 45 | ((#t #t #f) . 5.0000000000000044e-2) 46 | ((#t #f #t) . .94) 47 | ((#t #f #f) . .06000000000000005) 48 | ((#f #t #t) . .29) 49 | ((#f #t #f) . .71) 50 | ((#f #f #t) . .001) 51 | ((#f #f #f) . .999)))) 52 | (list #t #f) ; Earthquake's support 53 | (make-message '((#t . .001) (#f . .999))) ; Message from burglary 54 | (make-message '((#t . 1) (#f . 1)))))) ; Message from alarm 55 | 56 | (define-test (burglary) 57 | (interaction 58 | (initialize-scheduler) 59 | (define nodes (build-burglary-network)) 60 | (run) 61 | (map content (map node-marginal nodes)) 62 | (produces 63 | '(#(message ((#t . 1.6283729946769937e-2) (#f . .98371627005323))) 64 | #(message ((#t . 1.1394968773811182e-2) (#f . .9886050312261888))) 65 | #(message ((#t . .04343771179992706) (#f . .9565622882000729))) 66 | #(message ((#t . 1.) (#f . 0.))) 67 | #(message ((#t . .03997202114194967) (#f . .9600279788580504))))))) 68 | ) 69 | -------------------------------------------------------------------------------- /examples/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (for-each load-relative 23 | '("smoke-test" 24 | "multiple-dwelling-test" 25 | "recursive-sqrt-test" 26 | "sudoku-test" 27 | "belief-propagation-test" 28 | "galaxy-range-test")) 29 | -------------------------------------------------------------------------------- /examples/test/mechanics-load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (for-each load-relative 23 | '("selectors-test" 24 | "voltage-divider-test" 25 | "bridge-rectifier-test")) 26 | -------------------------------------------------------------------------------- /examples/test/multiple-dwelling-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | multiple-dwelling 24 | 25 | (define-test (multiple-dwelling) 26 | (interaction 27 | (initialize-scheduler) 28 | (define answers (p:multiple-dwelling)) 29 | (run) 30 | (map v&s-value (map tms-query (map content answers))) 31 | (produces '(3 2 4 5 1)) 32 | 33 | (check (< *number-of-calls-to-fail* 100)) 34 | ))) 35 | -------------------------------------------------------------------------------- /examples/test/recursive-sqrt-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | recursive-sqrt 24 | 25 | (define-test (one-heron-step) 26 | (interaction 27 | (initialize-scheduler) 28 | (define-cell x) 29 | (define-cell guess) 30 | (define-cell better-guess) 31 | 32 | (p:heron-step x guess better-guess) 33 | 34 | (add-content x 2) 35 | (add-content guess 1.4) 36 | (run) 37 | (content better-guess) 38 | (produces 1.4142857142857141) 39 | )) 40 | 41 | (define-test (sqrt) 42 | (interaction 43 | (initialize-scheduler) 44 | (define-cell x) 45 | (define-cell answer) 46 | 47 | (p:sqrt-network x answer) 48 | 49 | (add-content x 2) 50 | (run) 51 | (content answer) 52 | (produces 1.4142135623746899) 53 | )) 54 | 55 | (define-test (factorial-1) 56 | (interaction 57 | (initialize-scheduler) 58 | (define-cell n! (e:factorial-1 5)) 59 | (run) 60 | (content n!) 61 | (produces 120))) 62 | 63 | (define-test (factorial-2) 64 | (interaction 65 | (initialize-scheduler) 66 | (define-cell n! (e:factorial-2 5)) 67 | (run) 68 | (content n!) 69 | (produces 120))) 70 | 71 | (define-test (factorial-3) 72 | (interaction 73 | (initialize-scheduler) 74 | (define-cell n! (e:factorial-3 5)) 75 | (run) 76 | (content n!) 77 | (produces 120))) 78 | 79 | (define-test (factorial-4) 80 | (interaction 81 | (initialize-scheduler) 82 | (define-cell n! (e:factorial-4 5)) 83 | (run) 84 | (content n!) 85 | (produces 120))) 86 | 87 | (define-test (factorial-5) 88 | (let-cell-rec (fact (e:kernel fact)) 89 | (let-cell (answer (e@ fact 4)) 90 | (run) 91 | (check (= 24 (content answer)))))) 92 | ) 93 | -------------------------------------------------------------------------------- /examples/test/smoke-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | smoke 24 | 25 | ;; Testing that constructing the networks used in the slow examples works 26 | (define-each-check 27 | (build-network) 28 | (build-albatross-network) 29 | (parse-puzzle 30 | '("X O OO " 31 | " O OO" 32 | "X XO O " 33 | " X XO " 34 | "OOO X OX " 35 | " X X " 36 | " X O O" 37 | " XO " 38 | " OOO OXOO " 39 | " O "))) 40 | ) 41 | -------------------------------------------------------------------------------- /examples/test/sudoku-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | sudoku 24 | 25 | (define-test (parse-smoke) 26 | (initialize-scheduler) 27 | (check 28 | (equal? 29 | "????\n????\n????\n?3??\n" 30 | (with-output-to-string 31 | (lambda () 32 | (print-sudoku-board 33 | (parse-sudoku 34 | '((0 0 0 0) (0 0 0 0) (0 0 0 0) (0 3 0 0))))))))) 35 | 36 | (define-test (solve-smoke) 37 | (initialize-scheduler) 38 | (check 39 | (equal? 40 | "3124\n2431\n1243\n4312\n" 41 | (with-output-to-string 42 | (lambda () 43 | (do-sudoku '((0 1 2 0) 44 | (0 0 0 0) 45 | (0 0 4 0) 46 | (0 3 0 0))))))) 47 | (check (< *number-of-calls-to-fail* 100))) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /examples/test/voltage-divider-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | voltage-divider 24 | 25 | (define-test (grounded-divider) 26 | (interaction 27 | (initialize-scheduler) 28 | 29 | (define n0 (node 2)) 30 | (define n0t1 (car n0)) 31 | (define n0t2 (cadr n0)) 32 | 33 | (define n1 (node 2)) 34 | (define n1t1 (car n1)) 35 | (define n1t2 (cadr n1)) 36 | 37 | (define n2 (node 2)) 38 | (define n2t1 (car n2)) 39 | (define n2t2 (cadr n2)) 40 | 41 | (ground n0) 42 | 43 | (define-cell Pv ((voltage-source 6) n1t1 n0t1)) 44 | (define-cell PR1 ((linear-resistor 4) n1t2 n2t1)) 45 | (define-cell PR2 ((linear-resistor 2) n2t2 n0t2)) 46 | 47 | (define-cell power (e:+ Pv (e:+ PR1 PR2))) 48 | 49 | (plunker (potential n2t1)) 50 | 51 | (run) 52 | 53 | (symbolic-expression (content (potential n2t1))) 54 | (produces 2) 55 | (symbolic-expression (content (current n2t2))) 56 | (produces 1) 57 | (symbolic-expression (content power)) 58 | (produces 0))) 59 | 60 | (define-test (plunk-for-ground) 61 | (interaction 62 | (initialize-scheduler) 63 | 64 | (define n0 (node 2)) 65 | (define n0t1 (car n0)) 66 | (define n0t2 (cadr n0)) 67 | 68 | (define n1 (node 2)) 69 | (define n1t1 (car n1)) 70 | (define n1t2 (cadr n1)) 71 | 72 | (define n2 (node 2)) 73 | (define n2t1 (car n2)) 74 | (define n2t2 (cadr n2)) 75 | 76 | (plunker (potential (car n0))) 77 | 78 | (define-cell Pv ((voltage-source 6) n1t1 n0t1)) 79 | (define-cell PR1 ((linear-resistor 4) n1t2 n2t1)) 80 | (define-cell PR2 ((linear-resistor 2) n2t2 n0t2)) 81 | 82 | (define-cell power (e:+ Pv (e:+ PR1 PR2))) 83 | 84 | (plunker (potential n2t1)) 85 | 86 | (run) 87 | 88 | (symbolic-expression (content (potential n2t1))) 89 | ;; TODO: better matching for autogenerated variables 90 | #; 91 | (produces (+ 2 x??)) 92 | (symbolic-expression (content (current n2t2))) 93 | (produces 1) 94 | (symbolic-expression (content power)) 95 | (produces 0))) 96 | 97 | (define-test (slice-voltage-divider) 98 | (interaction 99 | (initialize-scheduler) 100 | 101 | (define n0 (node 2)) 102 | (define n0t1 (car n0)) 103 | (define n0t2 (cadr n0)) 104 | 105 | (define n1 (node 2)) 106 | (define n1t1 (car n1)) 107 | (define n1t2 (cadr n1)) 108 | 109 | (define n2 (node 2)) 110 | (define n2t1 (car n2)) 111 | (define n2t2 (cadr n2)) 112 | 113 | (ground n0) 114 | 115 | (define-cell Pv ((voltage-source 6) n1t1 n0t1)) 116 | 117 | (define-cell R1 4) 118 | (define-cell PR1 ((linear-resistor R1) n1t2 n2t1)) 119 | 120 | (define-cell R2 2) 121 | (define-cell PR2 ((linear-resistor R2) n2t2 n0t2)) 122 | 123 | (define-cell power (e:+ Pv (e:+ PR1 PR2))) 124 | 125 | ;; A slice 126 | 127 | (define n1t2* (clone-terminal n1t2)) 128 | 129 | (define n0t2* (clone-terminal n0t2)) 130 | 131 | (define-cell R1+R2 (ce:+ R1 R2)) 132 | 133 | 134 | ;; Note that PRS does not contribute to the power in the circuit. 135 | (define-cell PRS ((linear-resistor R1+R2) n1t2* n0t2*)) 136 | 137 | (run) 138 | 139 | ;; Note that the results aren't symbolic expressions --- no variables 140 | ;; were necessary, because of the slice. 141 | 142 | (content (potential n2t1)) 143 | (produces 2) 144 | (content (current n2t2)) 145 | (produces 1) 146 | (content power) 147 | (produces 0))) 148 | 149 | ) 150 | -------------------------------------------------------------------------------- /examples/voltage-divider-slice.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Gerald Jay Sussman and Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (initialize-scheduler) 23 | 24 | (define n0 (node 2)) 25 | (define n0t1 (car n0)) 26 | (define n0t2 (cadr n0)) 27 | 28 | (define n1 (node 2)) 29 | (define n1t1 (car n1)) 30 | (define n1t2 (cadr n1)) 31 | 32 | (define n2 (node 2)) 33 | (define n2t1 (car n2)) 34 | (define n2t2 (cadr n2)) 35 | 36 | ; (ground n0) 37 | (plunker (potential n0t1)) 38 | 39 | (define-cell Pv ((voltage-source 6) n1t1 n0t1)) 40 | 41 | (define-cell R1 4) 42 | (define-cell PR1 ((linear-resistor R1) n1t2 n2t1)) 43 | 44 | (define-cell R2 2) 45 | (define-cell PR2 ((linear-resistor R2) n2t2 n0t2)) 46 | 47 | (define-cell power (e:+ Pv (e:+ PR1 PR2))) 48 | 49 | ;;; A slice 50 | 51 | (define n1t2* (clone-terminal n1t2)) 52 | 53 | (define n0t2* (clone-terminal n0t2)) 54 | 55 | (define-cell R1+R2 (ce:+ R1 R2)) 56 | 57 | 58 | ;;; Note that PRS does not contribute to the power in the circuit. 59 | 60 | (define PRS ((linear-resistor R1+R2) n1t2* n0t2*)) 61 | 62 | (run) 63 | 64 | (pec (symbolic-expression (content (current n2t2)))) 65 | -------------------------------------------------------------------------------- /examples/voltage-divider.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Gerald Jay Sussman and Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (initialize-scheduler) 23 | 24 | (define n0 (node 2)) 25 | (define n0t1 (car n0)) 26 | (define n0t2 (cadr n0)) 27 | 28 | (define n1 (node 2)) 29 | (define n1t1 (car n1)) 30 | (define n1t2 (cadr n1)) 31 | 32 | (define n2 (node 2)) 33 | (define n2t1 (car n2)) 34 | (define n2t2 (cadr n2)) 35 | 36 | ; (ground n0) 37 | (plunker (potential n0t1)) 38 | 39 | (define-cell Pv ((voltage-source 6) n1t1 n0t1)) 40 | (define-cell PR1 ((linear-resistor 4) n1t2 n2t1)) 41 | (define-cell PR2 ((linear-resistor 2) n2t2 n0t2)) 42 | 43 | (define-cell power (e:+ Pv (e:+ PR1 PR2))) 44 | 45 | (plunker (potential n2t1)) 46 | 47 | (run) 48 | 49 | (pp (content (potential n2t1))) 50 | #| 51 | #[:symbolic 15] 52 | (expression (+ 2 x43)) 53 | (metadata #[:symbolic-metadata 16]) 54 | |# 55 | 56 | (pec (symbolic-expression (content (current n2t2)))) 57 | #| Result: 58 | 1 59 | |# 60 | 61 | (pec (symbolic-expression (content power))) 62 | #| Result: 63 | 0 64 | |# 65 | -------------------------------------------------------------------------------- /explorations/algebraic-tms-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | algebraic-tms 24 | (define-test (smoke) 25 | (interaction 26 | (initialize-scheduler) 27 | (define-cell bill (make-tms (supported 3 '(bill)))) 28 | (define-cell bill-cons (e:copy-cons nothing bill)) 29 | (define-cell answer) 30 | (c:== bill-cons answer) 31 | (define-cell fred (make-tms (supported 4 '(fred)))) 32 | (define-cell fred-cons (e:copy-cons fred nothing)) 33 | (define-cell george (make-tms (supported #t '(george)))) 34 | (conditional-wire george fred-cons answer) 35 | (define-cell the-pair? (e:copy-pair? answer)) 36 | (define-cell the-car (e:copy-car answer)) 37 | (define-cell the-cdr (e:copy-cdr answer)) 38 | (run) 39 | ; (pp (content answer)) 40 | (content the-pair?) 41 | (produces #t) 42 | (content the-car) 43 | (produces #(tms (#(supported 4 (fred george))))) 44 | (content the-cdr) 45 | (produces #(tms (#(supported 3 (bill))))))) 46 | 47 | (define-test (contradictions) 48 | (check 49 | (generic-match 50 | `#(effectful 51 | #(algebraic-tms 52 | #(tms 53 | (#(supported (#(*the-nothing*) . #(*the-nothing*)) (joe)) 54 | #(supported (#(*the-nothing*) . #(*the-nothing*)) (george)))) 55 | ((,car . #(tms (#(supported #(*the-contradiction*) 56 | (george fred bill joe)) 57 | #(supported 3 (bill joe)) 58 | #(supported 4 (fred george))))) 59 | (,cdr . #(tms ())))) 60 | (#(nogood-effect (george fred bill joe)))) 61 | (merge (->algebraic-tms 62 | (make-tms (supported 63 | (cons (make-tms (supported 4 '(fred))) nothing) 64 | '(george)))) 65 | (->algebraic-tms 66 | (make-tms (supported 67 | (cons (make-tms (supported 3 '(bill))) nothing) 68 | '(joe))))))))) 69 | -------------------------------------------------------------------------------- /explorations/circuits/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul and Gerald Jay Sussman 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-relative "../../extensions/load.scm") 34 | 35 | (for-each load-relative-compiled 36 | '("infrastructure" 37 | "layered" 38 | "parts" 39 | "slices" 40 | "examples")) 41 | 42 | (maybe-warn-low-memory) 43 | (initialize-scheduler) 44 | -------------------------------------------------------------------------------- /explorations/circuits/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(begin (set! load-debugging-info-on-demand? #t) (set! load/suppress-loading-message? #t))' --load load.scm --load tests --eval '(let ((v (show-time run-registered-tests))) (newline) (flush-output) (%exit v))' 4 | -------------------------------------------------------------------------------- /explorations/gods-eye-tms.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | ;;; Some code snippets for God's-eye TMSes, lest I forget them. 23 | 24 | (defhandler generic-flatten 25 | (lambda (v&s) 26 | (generic-flatten 27 | (make-tms (map (lambda (sub-v&s) 28 | (generic-flatten 29 | (supported sub-v&s (v&s-support v&s)))) 30 | (tms-values (v&s-value v&s)))))) 31 | (lambda (thing) (and (v&s? thing) (tms? (v&s-value thing))))) 32 | 33 | 34 | (defhandler generic-flatten 35 | (lambda (tms) 36 | (let ((candidates 37 | (apply append 38 | (map tms-values 39 | (map ->tms 40 | (filter (lambda (x) (not (nothing? x))) 41 | (map generic-flatten (tms-values tms)))))))) 42 | (if (null? candidates) 43 | nothing 44 | (make-tms candidates)))) 45 | tms?) 46 | 47 | ;;; I am tempted to use this for the ant's-eye tms flatten, but it 48 | ;;; doesn't actually work, because TMSes given to flatten don't 49 | ;;; actually obey the TMS invariants. 50 | (defhandler generic-flatten 51 | (lambda (tms) 52 | (let ((candidate (generic-flatten (tms-query tms)))) 53 | (if (nothing? candidate) 54 | nothing 55 | (make-tms candidate)))) 56 | tms?) 57 | 58 | -------------------------------------------------------------------------------- /explorations/ignorance.scm: -------------------------------------------------------------------------------- 1 | ;;; Exploratory thoughts about propagators that make conclusions based 2 | ;;; on not knowing something else. 3 | 4 | ;;; Here is such a propagator: 5 | (define (ignorance-detector input output) 6 | (let ((unknown-premise (list 'unknown))) 7 | (define (effective-nothing? thing) 8 | (cond ((nothing? thing) 9 | #t) 10 | ((tms? thing) 11 | (effective-nothing? (tms-query thing))) 12 | ((v&s? thing) 13 | (or (not (v&s-believed? thing)) 14 | (effective-nothing? (v&s-value thing)))) 15 | (else 16 | #f))) 17 | (define (ignorance-try) 18 | (if (effective-nothing? (content input)) 19 | (bring-in! unknown-premise) 20 | (kick-out! unknown-premise))) 21 | (mark-premise-out! unknown-premise) 22 | ((constant (make-tms (list (supported #t (list unknown-premise))))) 23 | output) 24 | (propagator input ignorance-try))) 25 | 26 | ;;; One might use it for a rule system like this: 27 | 28 | (with-pattern-variables (x y z) 29 | (let-rules 30 | ( 31 | (ancestor-bc ((req (supported (pattern (show (?x ancestor ?z)))))) 32 | (let-rules 33 | ( 34 | (ancestor-bc0 35 | (on-trigger ((c (supported (pattern (?x parent ?z))))) 36 | (support (pattern (?x ancestor ?z)) (justify ancestor-bc0 c)))) 37 | 38 | (ancestor-bc1 39 | (on-trigger ((c (supported (pattern (?y parent ?z)))) 40 | (u (unknown (pattern (?x ancestor ?y))))) 41 | (support (pattern (show (?x ancestor ?y))) 42 | (justify ancestor-bc1 req c u)))) 43 | 44 | (ancestor-bc2 45 | (on-trigger ((c (supported (pattern (?x parent ?y)))) 46 | (u (unknown (pattern (?y ancestor ?z))))) 47 | (support (pattern (show (?y ancestor ?z))) 48 | (justify ancestor-bc2 req c u)))) 49 | 50 | 51 | ;; although the following is always true, it is instantiated 52 | ;; only for x, z that have the request req. 53 | 54 | (ancestor-transitive 55 | (on-trigger ((f1 (supported (pattern (?x ancestor ?y)))) 56 | (f2 (supported (pattern (?y ancestor ?z))))) 57 | (support (pattern (?x ancestor ?z)) 58 | (justify ancestor-transitive f1 f2)))) 59 | ) 60 | ;; These rules are dependent on the request 61 | (support ancestor-bc0 (justify ancestor-bc req)) 62 | (support ancestor-bc1 (justify ancestor-bc req)) 63 | (support ancestor-bc2 (justify ancestor-bc req)) 64 | 65 | ;; This rule is independent of everything 66 | (support ancestor-transitive) 67 | )) 68 | ) 69 | ;; This rule is independent of everything too 70 | (support ancestor-bc))) 71 | 72 | ;;; While it is running, a rule system like that might produce 73 | ;;; a propagator network that looks something like this: 74 | 75 | (let-cells* ((adam-parent-cain #t) 76 | (cain-parent-enoch #t) 77 | (enoch-parent-irad #t) 78 | (irad-parent-mehujael #t) 79 | (mehujael-parent-methushael #t) 80 | (methushael-parent-lamech #t) 81 | (lamech-parent-jabal #t) 82 | (lamech-parent-jubal #t) 83 | 84 | (adam-ancestor-cain) 85 | (cain-ancestor-enoch) 86 | (adam-ancestor-enoch) 87 | (cain-ancestor-adam) 88 | (enoch-ancestor-cain) 89 | (enoch-ancestor-adam) 90 | 91 | (show-adam-ancestor-enoch) 92 | (show-adam-ancestor-cain) 93 | (show-cain-ancestor-enoch) 94 | ) 95 | (ancestry-transitive adam-parent-cain cain-ancestor-enoch adam-ancestor-enoch) 96 | (parent-implies-ancestor adam-parent-cain adam-ancestor-cain) 97 | (parent-implies-ancestor cain-parent-enoch cain-ancestor-enoch) 98 | 99 | (ancestor-bc1 show-adam-ancestor-enoch 100 | adam-parent-cain 101 | (e:ignorance-detector cain-ancestor-enoch) 102 | show-cain-ancestor-enoch) 103 | 104 | (ancestor-bc2 show-adam-ancestor-enoch 105 | cain-parent-enoch 106 | (e:ignorance-detector adam-ancestor-cain) 107 | show-adam-ancestor-cain) 108 | ) 109 | 110 | (define (ancestor-bc1 req-cell c-cell u-cell answer-cell) 111 | (p:and req-cell c-cell u-cell answer-cell)) 112 | -------------------------------------------------------------------------------- /explorations/locking.txt: -------------------------------------------------------------------------------- 1 | The locking needed to ensure the integrity of the propagator network 2 | is completely deadlock-free. Why? Because only a few operations need 3 | to be atomic; they are very local operations; and every transaction 4 | only contains one of them. Nobody ever needs to hold more than one 5 | lock at a time, so deadlock is impossible because either you have the 6 | lock and can make progress, or you don't have the lock but you're not 7 | impeding anybody. 8 | 9 | Operations that require locking: 10 | 11 | Updating the contents of a cell with newly merged data. 12 | - This requires a compare-and-swap loop against the existing contents; 13 | but nothing worse than that, because it really doesn't matter 14 | whether your update comes in before or after the other guy's 15 | (As long as the other guy's gets done). 16 | - If a propagator has multiple outputs, it can put them into 17 | their cells one by one. 18 | 19 | Attaching propagators to cells 20 | - This can be done one cell at a time 21 | 22 | Uniquifying the cell-merge bridges 23 | - Not completely clear that this is necessary for correctness 24 | - To do it right, the only thing you really need is unique 25 | names for cells, that can atomically be turned into a unique 26 | name for the pair (which serves as the name of the cell 27 | controlling their bridge). 28 | 29 | (Updating the global worldview with a new nogood set or a new 30 | bring-in! or kick-out!) 31 | -------------------------------------------------------------------------------- /explorations/mortgages.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | ;;; A abortive attempt at a multidirectional mortgage calculator, both 23 | ;;; for the fun of it and because I am interested in having that 24 | ;;; program. 25 | 26 | (define (mortgage-term amount rate payment) 27 | (if (<= amount 0) 28 | 0 29 | (let ((next-amount (* rate (- amount payment)))) 30 | (if (>= next-amount amount) 31 | 'infinite 32 | (+ 1 (mortgage-term next-amount rate payment)))))) 33 | 34 | ;;; Assuming the interest is applied before the payment, the formula 35 | ;;; for balance after n cycles is 36 | ;;; 37 | ;;; Ar^n - Pr^(n-1) - ... - P = Ar^n - P(r^n - 1)/(r - 1), 38 | ;;; 39 | ;;; where A is the initial balance, P is the payment, and r is 1 + the 40 | ;;; unit interest rate (i.e. 5% per month is r=1.05). (check it!) 41 | ;;; For a mortgage to be exactly repaid with n payments, this 42 | ;;; residual balance must be exactly zero. This condition suffices 43 | ;;; to compute the payment from the principal or vice versa, given 44 | ;;; the rate and the term. 45 | (define (mortgage<->payment mortgage-amt interest-rate term payment) 46 | (c:== 47 | (ce:* mortgage-amt (e:expt interest-rate term)) 48 | (ce:* payment 49 | (e:/ (e:- (e:expt interest-rate term) 1) 50 | (e:- interest-rate 1))))) 51 | -------------------------------------------------------------------------------- /explorations/raa.scm: -------------------------------------------------------------------------------- 1 | ;;;; RAA 2 | ;;; Idea is to dismiss a hypothetical by denying the contrary... 3 | 4 | ;;; Want to stop worldview associated with contrary-premise 5 | ;;; if contrary premise finds a contradiction. Then want to 6 | ;;; reinstate the contrary belief in a new worldview if a 7 | ;;; reason for the contradiction is lost. 8 | 9 | (define (to-dismiss-hypothetical hypothetical-premise) 10 | (let ((agent (current-agent)) ; worldview and schedule 11 | (hcell (hypothetical-cell hypothetical-premise)) 12 | (sign 13 | (case (hypothetical-sign hypothetical-premise) ;stupid! 14 | ((true) #t) 15 | ((false) #f) 16 | (else (error "Bad hypothetical sign")))) 17 | (state (premise-in? hypothetical-premise)) ; unused? bad! 18 | (contrary-premise 19 | (or (eq-get hypothetical-premise 'contrary-premise) 20 | (let ((cp (generate-uninterned-symbol 'contrary))) 21 | (eq-put! cp 'hypothetical-premise hypothetical-premise) 22 | (eq-put! hypothetical-premise 'contrary-premise cp) 23 | cp)))) 24 | ;; Kick out the hypothetical and add the contrary premise to the 25 | ;; reasons why it should be out. 26 | (set-premise-nogoods! hypothetical-premise 27 | (lset-adjoin eq? 28 | (premise-nogoods hypothetical-premise) 29 | (list contrary-premise))) 30 | (kick-out! hypothetical-premise) 31 | 32 | ;; Assert the contrary premise, and use it to support the opposite 33 | ;; of the hypothetical being tested. 34 | (add-content hcell 35 | (make-tms 36 | (contingent (not sign) 37 | (list contrary-premise)))) 38 | (bring-in! contrary-premise) 39 | 40 | ;; Attach: look at process-nogood! in search 41 | (tell-contradiction-handler 42 | (lambda (a-nogood) 43 | (if (member contrary-premise a-nogood) 44 | (let ((reasons (delete contrary-premise a-nogood))) 45 | (if (or (not (null (filter hypothetical? reasons))) 46 | (not (null (filter (lambda (x) 47 | (eq-get x 'hypothetical-premise)) 48 | reasons)))) 49 | 'too-complicated 50 | (begin 51 | (kick-out! contrary-premise) 52 | (add-content hcell 53 | (make-tms (contingent sign reasons))) 54 | ;; deactivate unless a reason is retracted. 55 | ))) 56 | 'nothing-to-do))) 57 | 58 | (on-quiescence agent 59 | (lambda () 60 | (if (premise-in? contrary-premise) ;could not find contradiction 61 | (kick-out! contrary-premise)) ;restore original situation 62 | )) 63 | ))) -------------------------------------------------------------------------------- /explorations/shared-resource.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | ;;; An idea for a shared resource 23 | 24 | (define (doit go-worldview input output build-it) 25 | ;; The input is a bunch of conditional input information. The 26 | ;; output is a bunch of conditional output information. The 27 | ;; go-worldview starts empty. When it is written, the device reads 28 | ;; that worldview from the input, and goes off and does the 29 | ;; computation. When an answer shows up on the internal output, it 30 | ;; is reconditioned on the go-worldview and written to the external 31 | ;; output. Also at this point, the device is reset for the next use 32 | ;; by rebuilding the internal input and output cells, and clearing 33 | ;; the go-worldview cell. The outside world knows the device is 34 | ;; ready for use by examining the go-worldview cell. Substructure 35 | ;; assumes responsibility for not jumping the gun, and writing the 36 | ;; full answer to the internal output cell all at once. 37 | ;; The build-it procedure attaches the internal device to the 38 | ;; internal input and output cells. 39 | (let-cell status 40 | (define (builder status) 41 | (define (do-build) 42 | (if (nothing? (content status)) 43 | (let-cells (in-worldview in-input in-output) 44 | (build-it in-input in-output) 45 | (worldview-selector go-worldview input in-input) 46 | ;; This indirection prevents worldview-attacher from 47 | ;; rewriting the status cell when the go-worldview 48 | ;; changes (assuming the in-worldview cell rejects 49 | ;; updates). 50 | (copy go-worldview in-worldview) 51 | (worldview-attacher in-worldview in-output output status) 52 | (add-content status 'built)))) 53 | (propagator status do-build)) 54 | (define (destroyer status) 55 | (define (do-destroy) 56 | (if (eq? 'done (content status)) 57 | (begin (add-content status *clear*) 58 | (add-content go-worldview *clear*)))) 59 | (propagator status do-destroy)) 60 | (builder status) 61 | (destroyer status))) 62 | -------------------------------------------------------------------------------- /explorations/sqrt-feedback.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define interval-maker 23 | (function->propagator-constructor (binary-mapping make-interval))) 24 | 25 | ;; This assumes that the input is more than 1 26 | (define (sqrt-network input-cell answer-cell) 27 | (let-cell one 28 | ((constant 1) one) 29 | (interval-maker one input-cell answer-cell) 30 | (heron-step input-cell answer-cell answer-cell))) 31 | 32 | (define-cell x) 33 | (add-content x 2) 34 | (define-cell sqrt-x) 35 | (sqrt-network x sqrt-x) 36 | (run) 37 | ;; Oops: raw interval arithmetic loses here: 38 | (content sqrt-x) 39 | ; Value: (interval 1. 2.) 40 | -------------------------------------------------------------------------------- /explorations/sudoku-2.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (load "../../propagator/sets") 23 | 24 | (define (singleton-set? thing) 25 | (and (set? thing) 26 | (= 1 (length (set->list thing))))) 27 | 28 | (define (one-choice? thing) 29 | (or (integer? thing) 30 | (and (tms? thing) 31 | (not (nothing? (tms-query thing))) 32 | (let ((content (v&s-value (tms-query thing)))) 33 | (or (integer? content) 34 | (singleton-set? content)))))) 35 | 36 | (define (the-one-choice thing) 37 | (if (integer? thing) 38 | thing 39 | (let ((content (v&s-value (tms-query thing)))) 40 | (cond ((singleton-set? content) 41 | (car (set->list content))) 42 | ((integer? content) 43 | content) 44 | (else 45 | (error "Huh? the-one-choice" thing)))))) 46 | 47 | (define (one-choice thing) 48 | thing) 49 | 50 | (define (add-set-split! cell size grain) 51 | (call-with-values 52 | (lambda () 53 | (partition (lambda (n) 54 | (< (modulo n (* 2 grain)) grain)) 55 | (iota size 1))) 56 | (lambda (in out) 57 | (one-of (make-set in) (make-set out) cell)))) 58 | 59 | (define (add-guesser! cell size) 60 | (let loop ((grain 1)) 61 | (if (>= grain size) 62 | 'done 63 | (begin (add-set-split! cell size grain) 64 | (loop (* 2 grain))))) 65 | ((constant (make-set (iota size 1))) cell)) 66 | 67 | ---------------------------------------------------------------------- 68 | 69 | (define (all-different . cells) 70 | (require-distinct cells)) 71 | 72 | -------------------------------------------------------------------------------- /extensions/dot-writer.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (make-dot-writer output-port) 23 | (define (write-graph write-contents) 24 | (write-string "digraph G {" output-port) 25 | (newline output-port) 26 | (draw:indented 27 | (lambda () 28 | (write-options) 29 | (write-contents))) 30 | (write-string "}" output-port) 31 | (newline output-port)) 32 | 33 | (define (write-options) 34 | (for-each (lambda (option) 35 | (write-indentation) 36 | (write-string option output-port) 37 | (write-string ";" output-port) 38 | (newline output-port)) 39 | '(; "orientation=landscape" 40 | ; "size=\"10,7.5\"" 41 | ; "page=\"8.5,11\"" 42 | "ratio=fill"))) 43 | 44 | (define (do-write-node node-id attributes) 45 | (write-indentation) 46 | (write node-id output-port) 47 | (write-attributes attributes) 48 | (write-string ";" output-port) 49 | (newline output-port)) 50 | 51 | (define (node-shape node) 52 | (cond ((cell? node) "ellipse") 53 | ((diagram? node) "box") 54 | (else 55 | (error "Unshapeable node type" node)))) 56 | 57 | (define (write-node node) 58 | (do-write-node 59 | (draw:node-id node) 60 | `(("label" . ,(draw:node-label node)) 61 | ("shape" . ,(node-shape node))))) 62 | 63 | (define (write-edge source-name target-name label) 64 | (write-indentation) 65 | (write source-name output-port) 66 | (write-string " -> " output-port) 67 | (write target-name output-port) 68 | (write-attributes `(("label" . ,label))) 69 | (write-string ";" output-port) 70 | (newline output-port)) 71 | 72 | (define (write-cluster id label write-contents) 73 | (write-subgraph 74 | (string-append "cluster_" (write-to-string id)) 75 | label write-contents)) 76 | 77 | (define (write-subgraph id label write-contents) 78 | (write-indentation) 79 | (write-string "subgraph " output-port) 80 | (write-string id output-port) 81 | (write-string " { " output-port) 82 | (write-subgraph-attributes `(("label" . ,(write-to-string label)))) 83 | (newline output-port) 84 | (draw:indented write-contents) 85 | (write-indentation) 86 | (write-string "}" output-port) 87 | (newline output-port)) 88 | 89 | (define (write-attributes attributes) 90 | (if (pair? attributes) 91 | (let ((first-attribute? #t)) 92 | (write-string " [" output-port) 93 | (for-each (lambda (attribute) 94 | (if (not first-attribute?) 95 | (write-string ", " output-port)) 96 | (write-string (car attribute) output-port) 97 | (write-string "=" output-port) 98 | (write (cdr attribute) output-port) 99 | (set! first-attribute? #f)) 100 | attributes) 101 | (write-string " ]" output-port)))) 102 | 103 | ;;; TODO Why is the string handling in MIT Scheme so awful? 104 | (define (write-subgraph-attributes attributes) 105 | (if (pair? attributes) 106 | (for-each (lambda (attribute) 107 | (write-string (car attribute) output-port) 108 | (write-string "=" output-port) 109 | (write (cdr attribute) output-port) 110 | (write-string "; " output-port)) 111 | attributes))) 112 | 113 | (define (write-indentation) 114 | (repeat draw:indentation-level 115 | (lambda () 116 | (write-string " " output-port)))) 117 | 118 | (define (me message) 119 | (cond ((eq? 'write-graph message) write-graph) 120 | ((eq? 'write-node message) write-node) 121 | ((eq? 'write-edge message) write-edge) 122 | ((eq? 'write-cluster message) write-cluster) 123 | (else 124 | (error "Unknown message" message)))) 125 | 126 | me) 127 | -------------------------------------------------------------------------------- /extensions/example-closures.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define fact-cl 25 | (let-cells (in-n in-n! 26 | zero control not-control one n-again n-1 n-1! empty) 27 | 28 | (define fact-cl 29 | (make-v-closure 30 | (list in-n in-n!) 31 | (list zero control not-control one n-again n-1 n-1! empty) 32 | '())) ; No global environment yet 33 | 34 | ((vc:const 0) zero) 35 | ((vc:const 1) one) 36 | (vc:=? in-n zero control) 37 | (vc:inverter control not-control) 38 | (vc:switch control one in-n!) 39 | (vc:switch not-control in-n n-again) 40 | (vc:subtractor n-again one n-1) 41 | (static-call-site fact-cl (list n-1 n-1!)) 42 | (vc:multiplier n-1! in-n in-n!) 43 | fact-cl)) 44 | 45 | (define fib-cl 46 | (let-cells (in-n fib-n one two recur not-recur 47 | n-again n-1 n-2 fib-n-1 fib-n-2) 48 | (define fib-cl 49 | (make-v-closure 50 | (list in-n fib-n) 51 | (list one two recur not-recur n-again n-1 n-2 fib-n-1 fib-n-2) 52 | '())) 53 | 54 | ((vc:const 1) one) 55 | ((vc:const 2) two) 56 | (vc:. 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define (information-assq key alist) 25 | (let ((binding (assq key alist))) 26 | (if binding 27 | (cdr binding) 28 | nothing))) 29 | 30 | (define (same-alist? alist1 alist2) 31 | (lset= (lambda (pair1 pair2) 32 | (and (eq? (car pair1) (car pair2)) 33 | (equivalent? (cdr pair1) (cdr pair2)))) 34 | alist1 alist2)) 35 | 36 | (define (unary-alist-unpacking f) 37 | (lambda (alist) 38 | (map (lambda (binding) 39 | (cons (car binding) (f (cdr binding)))) 40 | alist))) 41 | 42 | (define (binary-alist-unpacking f) 43 | (lambda (alist1 alist2) 44 | (let ((keys (lset-union eq? (map car alist1) (map car alist2)))) 45 | (define get information-assq) 46 | (map (lambda (key) 47 | (cons key (f (get key alist1) (get key alist2)))) 48 | keys)))) 49 | 50 | (define %merge-alist (binary-alist-unpacking merge)) 51 | 52 | (define (merge-alist alist1 alist2) 53 | (let ((putative-answer (%merge-alist alist1 alist2))) 54 | (effectful-list-bind (map cdr putative-answer) 55 | (lambda (cdrs) 56 | (map cons 57 | (map car putative-answer) 58 | cdrs))))) 59 | -------------------------------------------------------------------------------- /extensions/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-relative "../core/load.scm") 34 | 35 | (define *virtual-copies* #t) 36 | 37 | (define (maybe thing bool) 38 | (if bool 39 | (list thing) 40 | '())) 41 | 42 | (for-each load-relative-compiled 43 | `(,@(maybe "virtual-environments" *virtual-copies*) 44 | ,@(maybe "virtual-closures" *virtual-copies*) 45 | "info-alist" 46 | "functional-reactivity" 47 | "solve" ; Requires mechanics to work 48 | "inequalities" ; Requires mechanics to work 49 | "symbolics" ; Requires mechanics to work 50 | "symbolics-ineq" ; Requires mechanics to work 51 | "test-utils")) 52 | 53 | (for-each load-relative 54 | `(,@(maybe "example-closures" *virtual-copies*) 55 | "draw" 56 | "dot-writer" 57 | "graphml-writer")) 58 | 59 | (maybe-warn-low-memory) 60 | (initialize-scheduler) 61 | -------------------------------------------------------------------------------- /extensions/mechanics: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ruby 2 | 3 | ### ---------------------------------------------------------------------- 4 | ### Copyright 2009-2010 Alexey Radul. 5 | ### ---------------------------------------------------------------------- 6 | ### This file is part of Propagator Network Prototype. 7 | ### 8 | ### Propagator Network Prototype is free software; you can redistribute it and/or modify 9 | ### it under the terms of the GNU General Public License as published by 10 | ### the Free Software Foundation, either version 3 of the License, or 11 | ### (at your option) any later version. 12 | ### 13 | ### Propagator Network Prototype is distributed in the hope that it will be useful, 14 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ### GNU General Public License for more details. 17 | ### 18 | ### You should have received a copy of the GNU General Public License 19 | ### along with Propagator Network Prototype. If not, see . 20 | ### ---------------------------------------------------------------------- 21 | 22 | # -*- ruby-mode -*- 23 | 24 | def root 25 | ENV["SCMUTILS_ROOT"] || "/usr/local/scmutils" 26 | end 27 | 28 | def scheme 29 | scheme = "#{root}/mit-scheme/bin/scheme" 30 | end 31 | 32 | def try_by_executable 33 | fixed_opts = ["--library", 34 | "#{root}/mit-scheme/lib", 35 | "--heap", 36 | "6000", 37 | "--band", 38 | "edwin-mechanics.com" 39 | ] 40 | 41 | if File.executable?(scheme) 42 | exec scheme, *(fixed_opts + ARGV) 43 | end 44 | end 45 | 46 | def mechanics_band 47 | "/scmutils/linux/edwin-mechanics.com" 48 | end 49 | 50 | def mechanics_band64 51 | "/scmutils/scheme-x86-64/edwin-mechanics.com" 52 | end 53 | 54 | def try_by_band(band) 55 | fixed_opts = ["-constant", 56 | "2000", 57 | "-heap", 58 | "10000", 59 | "-band", 60 | band 61 | ] 62 | if File.exist?(band) 63 | exec "mit-scheme", *(fixed_opts + ARGV) 64 | end 65 | end 66 | 67 | try_by_executable 68 | try_by_band("/sw" + mechanics_band) 69 | try_by_band("/usr/local"+ mechanics_band) 70 | try_by_band("/usr/local"+ mechanics_band64) 71 | puts "No Scheme at #{scheme} and no Mechanics bands at {/sw|/usr/local}#{mechanics_band} :(" 72 | 73 | -------------------------------------------------------------------------------- /extensions/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec ./mechanics --compiler -heap 6000 --batch-mode --no-init-file --eval \ 4 | "(begin 5 | (if (lexical-unbound? system-global-environment 'let-fluids) 6 | (set! load/suppress-loading-message? #t) 7 | (set-fluid! load/suppress-loading-message? #t)) 8 | (load \"load\") 9 | (load \"test/load\") 10 | (run-tests-and-exit))" 11 | -------------------------------------------------------------------------------- /extensions/test-utils.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | (define (fail-all cells) 25 | (process-one-contradiction 26 | (apply append (map v&s-support (filter v&s? (map tms-query (filter tms? (map content cells)))))))) 27 | 28 | (define (for-each-consistent-state proc cells) 29 | (set! cells (listify cells)) 30 | (let loop ((last-run-result (run))) 31 | (if (eq? 'done last-run-result) 32 | (begin 33 | (proc) 34 | (fail-all cells) 35 | (loop (run)))))) 36 | 37 | (define map-consistent-states (walker->mapper for-each-consistent-state)) 38 | 39 | (define-method generic-match ((pattern ) (object rtd:symbolic-metadata)) 40 | (generic-match 41 | pattern (vector 'metadata (symbolic-variable-order object) 42 | (symbolic-substitutions object) 43 | (symbolic-residual-equations object)))) 44 | 45 | (define-method generic-match ((pattern ) (object rtd:symbolic)) 46 | (generic-match 47 | pattern (vector 'symbolic (symbolic-expression object) 48 | (symbolic-metadata object)))) 49 | 50 | (define-method generic-match ((pattern ) (object rtd:symb-ineq)) 51 | (generic-match 52 | pattern (vector 'symb-ineq (symb-ineq-expression object) 53 | (symb-ineq-local object) 54 | (symb-ineq-global object)))) 55 | 56 | (define-method generic-match ((pattern ) (object rtd:inequality)) 57 | (generic-match pattern `(,@(inequality->list object) ,(inequality-variables object)))) 58 | 59 | (define-method generic-match ((pattern rtd:inequality) (object rtd:inequality)) 60 | (generic-match (inequality->list pattern) (inequality->list object))) 61 | 62 | (define-method generic-match ((pattern ) (object rtd:frs)) 63 | (if (stale-frs? object) 64 | (generic-match 65 | pattern (vector 'stale-frs (frs-value object) 66 | (frs-support object))) 67 | (generic-match 68 | pattern (vector 'frs (frs-value object) 69 | (frs-support object))))) 70 | 71 | (define-method generic-match ((pattern ) (object rtd:frpremise)) 72 | (generic-match 73 | pattern (vector 'frp (frpremise-identity object) 74 | (frpremise-timestamp object)))) 75 | 76 | #| 77 | ;;; Trying to abstract the above. 78 | 79 | (define (record-type-summarizer record-type-descriptor) 80 | (lambda (object) 81 | (list->vector 82 | (cons (symbol (record-type-name record-type-descriptor)) 83 | (map (lambda (field-name) 84 | ((record-accessor record-type-descriptor field-name) 85 | object)) 86 | (record-type-field-names record-type-descriptor)))))) 87 | 88 | (define (declare-match-vector-patterns record-type-descriptor) 89 | (add-method generic-match 90 | (make-method (list record-type-descriptor) 91 | (lambda (pattern object) 92 | (generic-match 93 | pattern 94 | ((record-type-summarizer record-type-descriptor) 95 | object)))))) 96 | 97 | (declare-match-vector-patterns rtd:symbolic-metadata) 98 | (declare-match-vector-patterns rtd:symbolic) 99 | (declare-match-vector-patterns rtd:symb-ineq) 100 | (declare-match-vector-patterns rtd:frpremise) 101 | |# 102 | -------------------------------------------------------------------------------- /extensions/test/functional-reactive-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | functional-reactive 24 | 25 | (define-each-check 26 | (generic-match #(frp seconds 0) (make-frpremise 'seconds 0))) 27 | 28 | (define-test (glitch) 29 | (interaction 30 | (initialize-scheduler) 31 | (define-cell one) 32 | (define-cell seconds) 33 | (define-cell seconds+one) 34 | (p:+ one seconds seconds+one) 35 | (add-content one 1) 36 | (add-content seconds (make-frs 0 (make-frpremise 'seconds 0))) 37 | (run) 38 | (content seconds+one) 39 | (produces #(frs 1 (#(frp seconds 0)))) 40 | 41 | (define-cell seconds+one-again) 42 | (define-cell glitchable) 43 | (p:< seconds seconds+one-again glitchable) 44 | (add-content seconds+one-again (content seconds+one)) 45 | (run) 46 | (content glitchable) 47 | (produces #(frs #t (#(frp seconds 0)))) 48 | 49 | (add-content seconds (make-frs 1 (make-frpremise 'seconds 1))) 50 | (content seconds) 51 | (produces #(frs 1 (#(frp seconds 1)))) 52 | (run) 53 | (content seconds+one) 54 | (produces #(frs 2 (#(frp seconds 1)))) 55 | ;; Rather than glitching, it should notice that its input is out of 56 | ;; date 57 | (content glitchable) 58 | (produces #(frs #t (#(frp seconds 0)))) 59 | 60 | ;; But when updated, it should propagate 61 | (add-content seconds+one-again (content seconds+one)) 62 | (run) 63 | (content glitchable) 64 | (produces #(frs #t (#(frp seconds 1)))))) 65 | ) 66 | -------------------------------------------------------------------------------- /extensions/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | 23 | (for-each load-relative 24 | `("inequality-test" 25 | "symbolics-test" 26 | "symbolics-ineq-test" 27 | "functional-reactive-test" 28 | ,@(maybe "virtual-environments-test" *virtual-copies*) 29 | ,@(maybe "virtual-closures-test" *virtual-copies*) 30 | "graph-drawing-test")) 31 | 32 | -------------------------------------------------------------------------------- /extensions/test/symbolics-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | symbolics 24 | 25 | (define-each-check 26 | (generic-match 27 | #(symbolic x #(metadata (x) () ())) 28 | (variable->symbolic 'x)) 29 | 30 | (generic-match 31 | #(symbolic -1 #(metadata (x) (((= x -1) ())) ())) 32 | (merge (make-symbolic 'x (make-symbolic-metadata '(x) '() '())) 33 | (make-symbolic '(+ (* 2 x) 1) (make-symbolic-metadata '(x) '() '())))) 34 | 35 | (generic-match 36 | #(symbolic -11 37 | #(metadata (x z y) (((= z -12) ()) ((= x -1) ()) ((= y -4) ())) ())) 38 | (merge (make-symbolic '(+ (* 2 x) 3 z) 39 | (make-symbolic-metadata '(x z) '(((= y (* 4 x)) ())) '())) 40 | (make-symbolic '(- y 7) 41 | (make-symbolic-metadata '(y) '(((= x (+ 3 y)) ())) '())))) 42 | 43 | (generic-match 44 | #(symbolic x #(metadata (x) () ())) 45 | (merge (make-symbolic 'x (make-symbolic-metadata '(x) '() '())) 46 | (make-symbolic 'x (make-symbolic-metadata '(x) '() '())))) 47 | 48 | (equal? 49 | nothing 50 | ((nary-unpacking +) (make-symbolic 'x (empty-metadata)) nothing)))) 51 | -------------------------------------------------------------------------------- /git-incantations: -------------------------------------------------------------------------------- 1 | To get a checkout 2 | 3 | cd to a random directory 4 | 5 | git clone git@github.com:ProjectMAC/propagators.git 6 | 7 | this will create a directory called propagators 8 | 9 | to get testing stuff 10 | 11 | cd propagators 12 | git submodule init 13 | git submodule update 14 | 15 | to update from repository 16 | 17 | git pull 18 | 19 | to modify a file and put in repository 20 | 21 | git add 22 | git commit -m 23 | git push 24 | 25 | -------------------------------------------------------------------------------- /load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-relative "extensions/load") 34 | -------------------------------------------------------------------------------- /micah-anomaly.scm: -------------------------------------------------------------------------------- 1 | #| 2 | (initialize-scheduler) 3 | (set! *avoid-false-true-flips* #f) ; turn off hysteresis so amb has real defaulting 4 | 5 | (define-cell in1) 6 | (define-cell in2) 7 | (define-cell aux1) 8 | (define-cell aux2) 9 | (define-cell out) 10 | 11 | (p:id in1 aux1) 12 | (p:id in1 out) 13 | (p:amb in1) 14 | 15 | (p:id in2 aux2) 16 | (p:id in2 out) 17 | (p:amb in2) 18 | 19 | (inquire out) ; --> #t 20 | ;Value: ((out) has #(value=#t, 21 | ; premises=((hypothetical 23 true in #[entity 24] in1)), 22 | ; informants=((amb-choose)))) 23 | 24 | (tell! aux1 #f 'temp1) ; force ambs to false via in1 25 | 26 | (inquire out) ; --> #f 27 | ;Value: ((out) has #(value=#f, 28 | ; premises=((hypothetical 25 false in #[entity 24] in1)), 29 | ; informants=((amb-choose)))) 30 | 31 | (kick-out! 'temp1) 32 | 33 | (tell! aux2 #f 'temp2) ; force ambs to false via in2 34 | 35 | (inquire out) ; --> #f 36 | ;Value: ((out) has #(value=#f, 37 | ; premises=((hypothetical 25 false in #[entity 24] in1)), 38 | ; informants=((amb-choose)))) 39 | 40 | (kick-out! 'temp2) 41 | 42 | (inquire out) ; --> #f ?! What happened to default-true?? 43 | ;Value: ((out) has #(value=#f, 44 | ; premises=((hypothetical 25 false in #[entity 24] in1)), 45 | ; informants=((amb-choose)))) 46 | 47 | 48 | 49 | (pp (content aux1)) 50 | #(tms 51 | (#(value=#(*the-contradiction*), 52 | premises=(temp1 (hypothetical 23 true out #[entity 24] in1)), 53 | informants=((amb-choose) user)) 54 | #(value=#f, 55 | premises=(temp1), 56 | informants=(user)) 57 | #(value=#t, 58 | premises=((hypothetical 23 true out #[entity 24] in1)), 59 | informants=((amb-choose))) 60 | #(value=#f, 61 | premises=((hypothetical 25 false in #[entity 24] in1)), 62 | informants=((amb-choose))))) 63 | 64 | 65 | (pp (content aux2)) 66 | #(tms 67 | (#(value=#(*the-contradiction*), 68 | premises=(temp2 (hypothetical 28 true out #[entity 27] in2)), 69 | informants=((amb-choose) user)) 70 | #(value=#f, 71 | premises=(temp2), 72 | informants=(user)) 73 | #(value=#t, 74 | premises=((hypothetical 28 true out #[entity 27] in2)), 75 | informants=((amb-choose))) 76 | #(value=#f, 77 | premises=((hypothetical 26 false in #[entity 27] in2)), 78 | informants=((amb-choose))))) 79 | 80 | 81 | (pp (content out)) 82 | #(tms 83 | (#(value=#(*the-contradiction*), 84 | premises=((hypothetical 23 true out #[entity 24] in1) (hypothetical 26 false in #[entity 27] in2)), 85 | informants=((amb-choose) (amb-choose))) 86 | #(value=#(*the-contradiction*), 87 | premises=((hypothetical 25 false in #[entity 24] in1) (hypothetical 28 true out #[entity 27] in2)), 88 | informants=((amb-choose) (amb-choose))) 89 | #(value=#f, 90 | premises=((hypothetical 25 false in #[entity 24] in1)), 91 | informants=((amb-choose))) 92 | #(value=#t, 93 | premises=((hypothetical 23 true out #[entity 24] in1)), 94 | informants=((amb-choose))) 95 | #(value=#t, 96 | premises=((hypothetical 28 true out #[entity 27] in2)), 97 | informants=((amb-choose))) 98 | #(value=#f, 99 | premises=((hypothetical 26 false in #[entity 27] in2)), 100 | informants=((amb-choose))))) 101 | |# 102 | 103 | ;;; To find out what non-hypothetical premises support a hypothetical 104 | 105 | (define (ultimate-support hyp) 106 | (let ((visited '())) 107 | (define (walk-one hyp) 108 | (if (not (memq hyp visited)) 109 | (begin (set! visited (cons hyp visited)) 110 | (append-map (lambda (premise-nogood) 111 | (sort (if (any hypothetical? premise-nogood) 112 | (let* ((s (divide-list hypothetical? 113 | premise-nogood)) 114 | (hyps (car s)) (roots (cadr s))) 115 | (append-map (lambda (sub) 116 | (lset-union eq? roots sub)) 117 | (map walk-one hyps))) 118 | (list premise-nogood)) 119 | premise. 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations)) 23 | 24 | ;;;; Auto-compilation 25 | 26 | ;;; A facility for automatically (re)compiling files at load time so 27 | ;;; as to avoid both the hassle of manual recompilations and the 28 | ;;; slowness of running interpreted code. Takes care around macros 29 | ;;; from previously loaded files. 30 | 31 | (define (self-relatively thunk) 32 | (let ((place (ignore-errors current-load-pathname))) 33 | (if (pathname? place) 34 | (with-working-directory-pathname 35 | (directory-namestring place) 36 | thunk) 37 | (thunk)))) 38 | 39 | (define (load-relative filename #!optional environment) 40 | (self-relatively (lambda () (load filename environment)))) 41 | 42 | (define (compiled-code-type) 43 | ;; Trying to support the C backend 44 | (if (lexical-unbound? 45 | (nearest-repl/environment) 46 | 'compiler:compiled-code-pathname-type) 47 | "com" 48 | (compiler:compiled-code-pathname-type))) 49 | 50 | ;; The environment argument is the one to take macro definitions from 51 | ;; for sf. 52 | (define (cf-conditionally filename #!optional environment) 53 | (define (default-environment) 54 | (if (current-eval-unit #f) 55 | (current-load-environment) 56 | (nearest-repl/environment))) 57 | (if (default-object? environment) 58 | (set! environment (default-environment))) 59 | (fluid-let ((sf/default-syntax-table environment)) 60 | (sf-conditionally filename)) 61 | (if (cf-seems-necessary? filename) 62 | (compile-bin-file filename))) 63 | 64 | (define (compiler-available?) 65 | (not (lexical-unbound? (nearest-repl/environment) 'cf))) 66 | 67 | (define (compilation-seems-necessary? filename) 68 | (or (sf-seems-necessary? filename) 69 | (cf-seems-necessary? filename))) 70 | 71 | (define (sf-seems-necessary? filename) 72 | (not (file-processed? filename "scm" "bin"))) 73 | 74 | (define (cf-seems-necessary? filename) 75 | (not (file-processed? filename "bin" (compiled-code-type)))) 76 | 77 | (define (load-compiled filename #!optional environment) 78 | (if (compiler-available?) 79 | (begin (cf-conditionally filename environment) 80 | (load filename environment)) 81 | (if (compilation-seems-necessary? filename) 82 | (begin (warn "The compiler does not seem to be loaded") 83 | (warn "Are you running Scheme with --compiler?") 84 | (warn "Skipping compilation; loading source interpreted") 85 | (load (pathname-default-type filename "scm") environment)) 86 | (load filename environment)))) 87 | 88 | (define (load-relative-compiled filename #!optional environment) 89 | (self-relatively (lambda () (load-compiled filename environment)))) 90 | -------------------------------------------------------------------------------- /support/coercions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations)) 23 | 24 | (define (coercability-tester name) 25 | (make-generic-operator 1 name (lambda (x) #f))) 26 | 27 | (define (coercer name #!optional operation) 28 | (make-generic-operator 1 name operation)) 29 | 30 | (define (tag-coercion-metadata predicate coercer tester) 31 | (eq-put! coercer 'coercability-tester tester) 32 | (eq-put! coercer 'predicate predicate)) 33 | 34 | (define (declare-coercion type coercer #!optional coercion) 35 | (let ((the-tester (eq-get coercer 'coercability-tester))) 36 | (if the-tester 37 | (defhandler the-tester (lambda (thing) #t) type) 38 | (error "No tester available for" coercer))) 39 | (if (not (default-object? coercion)) 40 | (defhandler coercer coercion type))) 41 | 42 | (define-syntax declare-named-coercion-target 43 | (syntax-rules () 44 | ((_ predicate-name coercability-name coercer-name operation) 45 | (begin 46 | (define coercability-name 47 | (coercability-tester 'coercability-name)) 48 | (define coercer-name 49 | (coercer 'coercer-name operation)) 50 | (defhandler coercer-name (lambda (x) x) predicate-name) 51 | (tag-coercion-metadata predicate-name coercer-name coercability-name))) 52 | ((_ predicate-name coercability-name coercer-name) 53 | (declare-named-coercion-target 54 | predicate-name coercability-name coercer-name #!default)))) 55 | 56 | (define-syntax declare-coercion-target 57 | (sc-macro-transformer 58 | (lambda (form use-env) 59 | (let ((name (cadr form)) 60 | (opt-operation (cddr form))) 61 | (let ((pred-name (symbol name '?)) 62 | (coercability-name (symbol name '-able?)) 63 | (coercer-name (symbol '-> name))) 64 | `(declare-named-coercion-target 65 | ,pred-name ,coercability-name, coercer-name ,@opt-operation)))))) 66 | 67 | (define (defhandler-coercing operation handler coercer) 68 | (let ((predicate (eq-get coercer 'predicate)) 69 | (coercability-tester (eq-get coercer 'coercability-tester))) 70 | (defhandler operation handler predicate predicate) 71 | (defhandler operation 72 | (coercing coercer handler) predicate coercability-tester) 73 | (defhandler operation 74 | (coercing coercer handler) coercability-tester predicate))) 75 | -------------------------------------------------------------------------------- /support/deque-sets.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2013 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;;; Sets that preserve insertion order 25 | 26 | (define-structure (insertion-order-set (conc-name oset-)) 27 | table deque) 28 | 29 | (define (make-eq-oset) 30 | (make-insertion-order-set (make-strong-eq-hash-table) 31 | (deque:make))) 32 | 33 | (define (oset-insert oset thing) 34 | (hash-table/lookup 35 | (oset-table oset) 36 | thing 37 | (lambda (value) 'ok) 38 | (lambda () 39 | (hash-table/put! (oset-table oset) thing #t) 40 | (deque:add-to-front! (oset-deque oset) thing)))) 41 | 42 | (define (oset-peek oset) 43 | (if (= 0 (oset-count oset)) 44 | (error "Peeking empty oset" oset)) 45 | (deque:first (oset-deque oset))) 46 | 47 | (define (oset-pop! oset) 48 | (let ((answer (oset-peek oset))) 49 | (hash-table/remove! (oset-table oset) answer) 50 | (deque:remove-first! (oset-deque oset)) 51 | answer)) 52 | 53 | 54 | (define (oset-peek-tail oset) 55 | (if (= 0 (oset-count oset)) 56 | (error "Peeking empty oset" oset)) 57 | (deque:last (oset-deque oset))) 58 | 59 | (define (oset-pop-tail! oset) 60 | (let ((answer (oset-peek-tail oset))) 61 | (hash-table/remove! (oset-table oset) answer) 62 | (deque:remove-last! (oset-deque oset)) 63 | answer)) 64 | 65 | 66 | (define (oset-members oset) 67 | (deque:all (oset-deque oset))) 68 | 69 | (define (oset-clear! oset) 70 | (hash-table/clear! (oset-table oset)) 71 | (set-oset-deque! oset (deque:make))) 72 | 73 | (define (oset-count oset) 74 | (hash-table/count (oset-table oset))) 75 | -------------------------------------------------------------------------------- /support/eq-properties.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2003 Gerald Jay Sussman. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | ;;;; Traditional LISP property lists 23 | ;;; extended to work on any kind of 24 | ;;; eq? data structure. 25 | 26 | ;;; Property lists are a way of creating data that 27 | ;;; looks like a record structure without 28 | ;;; commiting to the fields that will be used 29 | ;;; until run time. The use of such flexible 30 | ;;; structures is frowned upon by most computer 31 | ;;; scientists, because it is hard to statically 32 | ;;; determine the bounds of the behavior of a 33 | ;;; program written using this stuff. But it 34 | ;;; makes it easy to write programs that confuse 35 | ;;; such computer scientists. I personally find 36 | ;;; it difficult to write without such crutches. 37 | ;;; -- GJS 38 | 39 | (declare (usual-integrations)) 40 | 41 | (define eq-properties (make-weak-eq-hash-table)) 42 | 43 | (define (eq-label! node . plist) 44 | (let loop ((plist plist)) 45 | (cond ((null? plist) node) 46 | ((null? (cdr plist)) (error "Malformed plist")) 47 | (else 48 | (eq-put! node (car plist) (cadr plist)) 49 | (loop (cddr plist)))))) 50 | 51 | (define (eq-put! node property value) 52 | (let ((plist 53 | (hash-table/get eq-properties node '()))) 54 | (let ((vcell (assq property plist))) 55 | (if vcell 56 | (set-cdr! vcell value) 57 | (hash-table/put! eq-properties node 58 | (cons (cons property value) plist))))) 59 | node) 60 | 61 | (define (eq-get node property) 62 | (let ((plist 63 | (hash-table/get eq-properties node '()))) 64 | (let ((vcell (assq property plist))) 65 | (if vcell 66 | (cdr vcell) 67 | #f)))) 68 | 69 | (define (eq-rem! node . properties) 70 | (for-each 71 | (lambda (property) 72 | (let ((plist 73 | (hash-table/get eq-properties node '()))) 74 | (let ((vcell (assq property plist))) 75 | (if vcell 76 | (hash-table/put! eq-properties node 77 | (delq! vcell plist)))))) 78 | properties) 79 | node) 80 | 81 | 82 | (define (eq-adjoin! node property new) 83 | (eq-put! node property 84 | (lset-adjoin eq? (or (eq-get node property) '()) new)) 85 | node) 86 | 87 | (define (eq-plist node) 88 | (let ((plist 89 | (hash-table/get eq-properties node #f))) 90 | (if plist (cons node plist) #f))) 91 | 92 | (define (eq-clone! source target) 93 | (hash-table/put! eq-properties target 94 | (hash-table/get eq-properties source '())) 95 | target) 96 | 97 | ;;; Path names are built with properties. 98 | 99 | (define (eq-path path) 100 | (define (lp node) 101 | (if node 102 | (if (pair? path) 103 | (eq-get ((eq-path (cdr path)) node) 104 | (car path)) 105 | node) 106 | #f)) 107 | lp) 108 | -------------------------------------------------------------------------------- /support/insertion-order-sets.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;;; Sets that preserve insertion order 25 | 26 | (define-structure (insertion-order-set (conc-name oset-)) 27 | table 28 | list) 29 | 30 | (define (make-eq-oset) 31 | (make-insertion-order-set (make-strong-eq-hash-table) '())) 32 | 33 | ;; Turning this off makes the order in which propagators are run vary 34 | ;; chaotically. That is not supposed to cause trouble in principle, 35 | ;; but a reproducible run order can be valuable for debugging the 36 | ;; infrastructure. The chaotic variation also causes variations in the 37 | ;; *number-of-calls-to-fail* when doing dependency directed backtracking. 38 | (define *reproducible-order* #t) 39 | 40 | (define (oset-insert oset thing) 41 | (hash-table/lookup 42 | (oset-table oset) 43 | thing 44 | (lambda (value) 'ok) 45 | (lambda () 46 | (hash-table/put! (oset-table oset) thing #t) 47 | (set-oset-list! oset (cons thing (oset-list oset)))))) 48 | 49 | (define (oset-peek oset) 50 | (if (= 0 (oset-count oset)) 51 | (error "Peeking empty oset" oset)) 52 | (if *reproducible-order* 53 | (car (oset-list oset)) 54 | (car (hash-table/key-list (oset-table oset))))) 55 | 56 | (define (oset-pop! oset) 57 | (let ((answer (oset-peek oset))) 58 | (hash-table/remove! (oset-table oset) answer) 59 | (set-oset-list! oset (cdr (oset-list oset))) 60 | answer)) 61 | 62 | (define (oset-members oset) 63 | (if *reproducible-order* 64 | (list-copy (oset-list oset)) 65 | (hash-table/key-list (oset-table oset)))) 66 | 67 | (define (oset-clear! oset) 68 | (hash-table/clear! (oset-table oset)) 69 | (set-oset-list! oset '())) 70 | 71 | (define (oset-count oset) 72 | (hash-table/count (oset-table oset))) 73 | -------------------------------------------------------------------------------- /support/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (define (self-relatively thunk) 23 | (let ((place (ignore-errors current-load-pathname))) 24 | (if (pathname? place) 25 | (with-working-directory-pathname 26 | (directory-namestring place) 27 | thunk) 28 | (thunk)))) 29 | 30 | (define (load-relative filename) 31 | (self-relatively (lambda () (load filename)))) 32 | 33 | (load-option 'sos) 34 | 35 | (load-relative "auto-compilation") 36 | 37 | (load-relative "../testing/load") 38 | 39 | (for-each load-relative-compiled 40 | '("profiler" 41 | ;;"mit-profile" 42 | "eq-properties" 43 | "generics-again" 44 | "coercions" 45 | ;;"insertion-order-sets" ;deque-sets is better! GJS 46 | "utils" 47 | "deque" 48 | "deque-sets" 49 | "test-utils")) 50 | 51 | (maybe-warn-low-memory) 52 | -------------------------------------------------------------------------------- /support/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval \ 4 | "(begin 5 | (if (lexical-unbound? system-global-environment 'let-fluids) 6 | (set! load/suppress-loading-message? #t) 7 | (set-fluid! load/suppress-loading-message? #t)) 8 | (load \"load\") 9 | (load \"test/load\") 10 | (run-tests-and-exit))" 11 | -------------------------------------------------------------------------------- /support/scm-propagators.el: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can redistribute it and/or modify 7 | ;;; it under the terms of the GNU General Public License as published by 8 | ;;; the Free Software Foundation, either version 3 of the License, or 9 | ;;; (at your option) any later version. 10 | ;;; 11 | ;;; Propagator Network Prototype is distributed in the hope that it will be useful, 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | ;;; GNU General Public License for more details. 15 | ;;; 16 | ;;; You should have received a copy of the GNU General Public License 17 | ;;; along with Propagator Network Prototype. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; The purpose of these Emacs modifications is to let me write 21 | ;;; define-foo and let-foo macros, and have Emacs treat them like the 22 | ;;; standard define and let. 23 | 24 | ;;; This works by tweaking some of the guts of Emacs' Scheme Mode (via 25 | ;;; scheme.el). There are two things that need to be done: 26 | ;;; indentation and colorization (for font-lock mode). Indentation is 27 | ;;; easy but repetitive. Emacs Scheme Mode already does the thing I 28 | ;;; want for define-mumble. For the let-style macros I have, I write 29 | 30 | (put 'let-cells 'scheme-indent-function 1) 31 | (put 'let-cells* 'scheme-indent-function 1) 32 | (put 'let-cells-rec 'scheme-indent-function 1) 33 | (put 'let-cell 'scheme-indent-function 1) 34 | (put 'let-cell-rec 'scheme-indent-function 1) 35 | 36 | ;;; Colorizing is more involved but also more general: 37 | 38 | ;; Modified from scheme-font-lock-keywords-1 from scheme.el 39 | (defconst axchify-scheme-font-lock-keywords 40 | (eval-when-compile 41 | (list 42 | ;; 43 | ;; Declarations. Hannes Haug says 44 | ;; this works for SOS, STklos, SCOOPS, Meroon and Tiny CLOS. 45 | (list (concat "(\\(define\\*?\\(" 46 | ;; Class names. 47 | "-class" 48 | ;; Guile modules. 49 | "\\|-module\\|" 50 | ;; Macro names, as variable names. A bit dubious, this. 51 | "\\(-syntax\\|-macro\\)\\|" 52 | ;; Function names, and names of arguments of user-defined 53 | ;; definition mechanisms 54 | "\\(\\|-public\\|-method\\|-generic\\(-procedure\\)?\\|-\\sw+\\)\\|" 55 | "\\)\\)\\>" 56 | ;; Any whitespace and declared object. 57 | "[ \t]*(?" 58 | "\\(\\sw+\\)?") 59 | '(1 font-lock-keyword-face) 60 | '(6 (cond ((match-beginning 4) font-lock-function-name-face) 61 | ((match-beginning 3) font-lock-variable-name-face) 62 | (t font-lock-type-face)) 63 | nil t)) 64 | ;; General let-like forms 65 | (cons "(\\(let-\\sw+\\)" 1) 66 | )) 67 | "General definitions to highlight in Scheme modes.") 68 | 69 | ;; Colorize and indent let-foo and define-foo macros consistently 70 | ;; with let and define 71 | (font-lock-add-keywords 'scheme-mode axchify-scheme-font-lock-keywords) 72 | -------------------------------------------------------------------------------- /support/test-utils.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Massachusetts Institute of Technology. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (declare (usual-integrations make-cell cell?)) 23 | 24 | ;;; For looking for memory leaks 25 | 26 | (define (garbage-collect-to-stability) 27 | ;; This loop is necessary because gc-daemons may make more things 28 | ;; unreachable; in principle for arbitrarily many iterations of the 29 | ;; gc. 30 | (let loop ((old-memory -1) 31 | (new-memory (gc-flip))) 32 | ;; Poke the eq-properties table to make it rehash and clean itself 33 | (eq-get 'full-lexical 'grumble) 34 | (if (< (abs (- new-memory old-memory)) 10) 35 | new-memory 36 | (loop new-memory (gc-flip))))) 37 | 38 | (define (memory-loss-from thunk) 39 | (let ((initial-memory (garbage-collect-to-stability))) 40 | (thunk) 41 | (- initial-memory (garbage-collect-to-stability)))) 42 | 43 | (define (repeat count thunk) 44 | (let loop ((count count)) 45 | (if (<= count 0) 46 | 'ok 47 | (begin 48 | (thunk) 49 | (loop (- count 1)))))) 50 | 51 | ;; This version is a thunk combinator! 52 | (define ((repeated count thunk)) 53 | (repeat count thunk)) 54 | 55 | ;; To make sure the memory for the primes that hash tables use gets 56 | ;; allocated now, before I start poking said hash tables. 57 | (let ((upto 150000)) 58 | (let force-prime-numbers ((primes prime-numbers-stream)) 59 | (if (< upto (car primes)) 60 | (car primes) 61 | (force-prime-numbers (force (cdr primes)))))) 62 | 63 | ;;; For stabilizing the string values of printouts that include hash 64 | ;;; numbers. 65 | (define (force-hash-number number) 66 | (let loop ((the-hash-number (hash (list 'foo)))) 67 | (cond ((> the-hash-number number) 68 | (error "Cannot set hash number to" number)) 69 | ((= the-hash-number number) 70 | 'done) 71 | (else (loop (hash (list 'foo))))))) 72 | 73 | -------------------------------------------------------------------------------- /support/test/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009-2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (for-each load-relative 23 | '("profiler-test" 24 | "utils-test" 25 | "generics-test")) 26 | -------------------------------------------------------------------------------- /support/test/utils-test.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2010 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Propagator Network Prototype. 5 | ;;; 6 | ;;; Propagator Network Prototype is free software; you can 7 | ;;; redistribute it and/or modify it under the terms of the GNU 8 | ;;; General Public License as published by the Free Software 9 | ;;; Foundation, either version 3 of the License, or (at your option) 10 | ;;; any later version. 11 | ;;; 12 | ;;; Propagator Network Prototype is distributed in the hope that it 13 | ;;; will be useful, but WITHOUT ANY WARRANTY; without even the implied 14 | ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 15 | ;;; See the GNU General Public License for more details. 16 | ;;; 17 | ;;; You should have received a copy of the GNU General Public License 18 | ;;; along with Propagator Network Prototype. If not, see 19 | ;;; . 20 | ;;; ---------------------------------------------------------------------- 21 | 22 | (in-test-group 23 | utils 24 | 25 | (define-each-check 26 | (equal? "piasse assing" (string-replace "pirate rating" "rat" "ass")) 27 | )) 28 | --------------------------------------------------------------------------------