├── .gitignore ├── COPYING ├── README ├── Rakefile ├── adventures └── ps07 │ ├── extra.scm │ ├── family.scm │ ├── load.scm │ ├── ps.scm │ ├── ps.txt │ └── ui.scm ├── core ├── amb-utils.scm ├── application.scm ├── carrying-cells.scm ├── cell-sugar.scm ├── cells.scm ├── code.ps ├── compound-data.scm ├── contradictions.scm ├── diagrams.scm ├── example-networks.scm ├── explain.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 ├── doc ├── Rakefile ├── art.pdf ├── bib.rkt ├── closures.tex ├── environments.tex ├── html4css1.css ├── phd-thesis.pdf ├── preamble.tex ├── programmer-guide.html ├── programmer-guide.rst ├── rake-latex.rb ├── revised-auto.bib ├── revised-html.aux ├── revised-html.bbl ├── revised-html.blg ├── revised-html.dvi ├── revised-html.html ├── revised-html.log ├── revised-html.out ├── revised-html.pdf ├── revised-html.tex ├── revised-html.toc ├── revised.aux ├── revised.bbl ├── revised.blg ├── revised.log ├── revised.out ├── revised.pdf ├── revised.scrbl ├── revised.tex ├── revised.toc ├── 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 ├── 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 ├── experiment ├── code.ps ├── depends.scm ├── lash-up.scm ├── load.scm └── to-work-on ├── 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 ├── foo.scm ├── load.scm ├── run-tests ├── support ├── auto-compilation.scm ├── coercions.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 ├── testing ├── COPYING ├── Rakefile ├── all-tests.scm ├── assertions.scm ├── checks.scm ├── doc │ ├── CHANGELOG │ └── testing.pod ├── failure-report-demo.scm ├── guile-conditions.scm ├── interactions.scm ├── load.scm ├── matching.scm ├── mit-scheme-tests.scm ├── mitscheme-conditions.scm ├── ordered-map.scm ├── portability.scm ├── srfi-69-hash-tables.scm ├── test-group.scm ├── test-runner.scm └── testing.scm └── workbook.ps /.gitignore: -------------------------------------------------------------------------------- 1 | *.bin 2 | *.com 3 | *.bci 4 | *.ext 5 | *~ 6 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 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 7 | and/or modify it under the terms of the GNU General Public License as 8 | published by the Free Software Foundation, either version 3 of the 9 | License, or (at your option) any later version. 10 | 11 | Propagator Network Prototype is distributed in the hope that it will 12 | be useful, but WITHOUT ANY WARRANTY; without even the implied warranty 13 | of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | 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 | 21 | 22 | INSTALLATION: 23 | 24 | Install MIT/GNU Scheme (required) 25 | sudo aptitude install mit-scheme mit-scheme-doc mit-scheme-dbg or 26 | http://www.gnu.org/software/mit-scheme/ 27 | 28 | Install Mechanics Scmutils (optional) 29 | http://groups.csail.mit.edu/mac/users/gjs/6946/linux-install.htm 30 | 31 | 32 | QUICK START: 33 | 34 | Execute ./run-tests in a shell to self-test 35 | 36 | Run (load "load") in Scheme to grab everything and start playing with it 37 | 38 | core/example-networks.scm and examples/* have usage examples 39 | 40 | 41 | CONTENT: 42 | 43 | The doc/ directory 44 | contains documents about the whole system, and aspects of it. The 45 | main attractions as of this writing are the Propagator Networks 46 | thesis and the Art of the Propagator paper. 47 | 48 | The core/ directory 49 | implements Alexey's thesis, much sanitized and extended and updated. 50 | 51 | The extensions/ directory 52 | adds (or attempts to add) various additional features and ideas. 53 | The rest of the software relies on the extensions in extensions/ as 54 | well as the core in core/. 55 | 56 | The examples/ directory 57 | contains extended examples of uses of propagator networks. This 58 | code is not in any sense part of the system, but is a series of 59 | clients. 60 | 61 | The support/ directory 62 | contains supporting stuff that isn't about propagators at all; just 63 | useful helpers and langauge facilities. 64 | - eq-properties 65 | - generic operations 66 | - profilers 67 | - miscellaneous utilities 68 | 69 | The testing/ directory 70 | is the unit testing framework this project uses, distributed here in 71 | source form. As software, testing/ is a separate entity and not 72 | part of the propagator project at all; but it so happens that Alexey 73 | also maintains it. 74 | 75 | 76 | LOADING CONVENTION: 77 | 78 | Loading is done through files called load.scm in every directory. 79 | They are responsible for collecting the contents of their own 80 | directory, and for loading their needed dependencies when appropriate. 81 | 82 | The toplevel load.scm is the main entry point. extensions/load.scm, 83 | core/load.scm, and examples/load.scm serve as secondary entry points 84 | for those portions of the system. 85 | 86 | 87 | UNIT TESTING: 88 | 89 | run-tests scripts run the unit tests for the portion of system in that 90 | directory. The toplevel run-tests runs all the unit tests. 91 | 92 | examples/run-examples exercises all the extended examples. This takes 93 | a minute, so is not considered part of the normal test suite. 94 | 95 | Unit tests are in test/ subdirectories of their respective 96 | directories. The test suites are independent of each other, and 97 | nothing depends on them. 98 | 99 | The unit tests are organized into test groups. Test groups are named 100 | after the test files they are in. 101 | 102 | Test suites can also be run from the REPL by loading the system, 103 | loading an appropriate test suite's test/load.scm file, and running 104 | (run-registered-tests). This offers interactive debugging of the 105 | tests. 106 | 107 | Some of the extensions rely on the symbolic algebra subsystems in 108 | Mechanics Scmutils. The full system will load just fine into a normal 109 | MIT/GNU Scheme, but extensions that need symbolic algebra will not 110 | work. The extensions/run-tests script will not run without a 111 | Mechanics install, and the extensions/test/load.scm test suite will 112 | fail if you run it from the REPL in MIT/GNU Scheme. 113 | 114 | None of this applies to the testing/ directory, since it is a separate 115 | software project that happens to be distributed here in source form. 116 | 117 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /adventures/ps07/extra.scm: -------------------------------------------------------------------------------- 1 | ;;;; This is the ps07 file extra.scm 2 | 3 | ;;; These make e: and p: propagators out of the scheme procedures 4 | (propagatify interval-low) 5 | (propagatify interval-high) 6 | 7 | (define-propagator (p:in-range? value interval bool) 8 | (p:and (e:<= (e:interval-low interval) value) 9 | (e:<= value (e:interval-high interval)) 10 | bool)) 11 | 12 | (define (add-interval-property estimate interval property-name) 13 | ;; Is there already such a property on the estimate? 14 | (let ((status-cell (eq-get estimate property-name))) ;Already defined? 15 | (if status-cell 16 | ;; Property already exists, get the range cell. 17 | (let ((range (eq-get estimate (symbol property-name ':range)))) 18 | (if (not range) 19 | (error "Interval property has no range" 20 | (name estimate) property-name)) 21 | (p:== interval range) 22 | 'range-updated) 23 | ;; New definition: 24 | ;; Create internal cells to hold the status of the symbolic 25 | ;; property and its defining range (initialized to the given interval). 26 | (let-cells (status-cell range) 27 | ;; Initialize the range cell. 28 | (p:== interval range) 29 | ;; Make the status cell and the range named properties of 30 | ;; the estimate cell. 31 | (eq-put! estimate (symbol property-name ':range) range) 32 | (eq-put! estimate property-name status-cell) 33 | ;; If the cell content is within the interval 34 | ;; then propagate #t to the status-cell. 35 | (p:in-range? estimate range status-cell) 36 | ;; If the status is true then propagate the content of the 37 | ;; interval-call to the estimate. 38 | (p:switch status-cell range estimate) 39 | 'property-added)))) 40 | 41 | (define ((c:bins named-ranges) numeric-interval) 42 | (for-each 43 | (lambda (named-range) 44 | (add-interval-property numeric-interval 45 | (cadr named-range) 46 | (car named-range))) 47 | named-ranges)) 48 | 49 | 50 | ;;; This can be used to support named ranges with a premise 51 | ;;; representing the range-defining authority: 52 | 53 | (define (named-ranges authority . named-ranges) 54 | (map (lambda (named-range) 55 | (list (car named-range) 56 | (depends-on (cadr named-range) authority))) 57 | named-ranges)) 58 | -------------------------------------------------------------------------------- /adventures/ps07/family.scm: -------------------------------------------------------------------------------- 1 | ;;;; A Small Financial Example 2 | 3 | ;;; First, we need a small database mechanism 4 | ;;; Parent and child here do not refer to biological 5 | ;;; things, but rather the relationships of parts 6 | ;;; of a database. 7 | 8 | (define (add-branch! parent child name) 9 | (eq-put! parent name child) 10 | (eq-put! child 'parent parent) 11 | (eq-put! child 'given-name name) 12 | 'done) 13 | 14 | (define (name-of thing) 15 | (let ((n (eq-get thing 'given-name))) 16 | (if n 17 | (let ((p (eq-get thing 'parent))) 18 | (if p 19 | (cons n (name-of p)) 20 | (list n))) 21 | (list (name thing))))) 22 | 23 | ;;; e.g. (thing-of Gaggle-salary gross-income Ben) 24 | 25 | (define (thing-of name-path) 26 | (let lp ((path name-path)) 27 | (cond ((= (length path) 1) (car path)) 28 | (else 29 | (eq-get (lp (cdr path)) 30 | (car path)))))) 31 | 32 | 33 | 34 | ;;; A financial entity has three cells 35 | 36 | (define (make-financial-entity entity) 37 | (eq-put! entity 'kind-of-entity 'financial) 38 | 39 | (let-cells (gross-income expenses net-income) 40 | 41 | (add-branch! entity gross-income 'gross-income) 42 | (add-branch! entity net-income 'net-income) 43 | (add-branch! entity expenses 'expenses) 44 | 45 | (c:+ expenses net-income gross-income) 46 | 'done 47 | )) 48 | 49 | (define (financial-entity? thing) 50 | (eq? (eq-get thing 'kind-of-entity) 'financial)) 51 | 52 | (define (gross-income entity) 53 | (assert (financial-entity? entity)) 54 | (eq-get entity 'gross-income)) 55 | 56 | (define (net-income entity) 57 | (assert (financial-entity? entity)) 58 | (eq-get entity 'net-income)) 59 | 60 | (define (expenses entity) 61 | (assert (financial-entity? entity)) 62 | (eq-get entity 'expenses)) 63 | 64 | (define (breakdown sum-node . part-names) 65 | (for-each (lambda (part-name) 66 | (let-cell part 67 | (add-branch! sum-node part part-name))) 68 | part-names) 69 | (cond ((= (length part-names) 2) 70 | (c:+ (eq-get sum-node (car part-names)) 71 | (eq-get sum-node (cadr part-names)) 72 | sum-node) 73 | 'done) 74 | (else 75 | (error "I don't know how to sum multiple parts")))) 76 | 77 | (define (combine-financial-entities compound . parts) 78 | (assert (every financial-entity? parts)) 79 | (cond ((= (length parts) 2) 80 | (let ((p1 (car parts)) (p2 (cadr parts))) 81 | (c:+ (gross-income p1) (gross-income p2) (gross-income compound)) 82 | (c:+ (net-income p1) (net-income p2) (net-income compound)) 83 | (c:+ (expenses p1) (expenses p2) (expenses compound)) 84 | 'done)) 85 | (else 86 | (error "I don't know how to combine multiple parts")))) 87 | 88 | #| 89 | (initialize-scheduler) 90 | 91 | (make-financial-entity 'Alyssa) 92 | (make-financial-entity 'Ben) 93 | 94 | ;;; Ben and Alyssa are married 95 | (make-financial-entity 'Ben-Alyssa) 96 | (combine-financial-entities 'Ben-Alyssa 'Ben 'Alyssa) 97 | 98 | ;;; Ben and Alyssa file income tax jointly 99 | (tell! (gross-income 'Ben-Alyssa) 427000 'IRS) 100 | 101 | ;;; Ben works at Gaggle as a software engineer. 102 | (breakdown (gross-income 'Ben) 'Gaggle-salary 'investments) 103 | 104 | ;;; He gets paid alot to make good apps. 105 | (tell! (thing-of '(Gaggle-salary gross-income Ben)) 200000 'Gaggle) 106 | 107 | ;;; Alyssa works as a PhD biochemist in big pharma. 108 | (breakdown (gross-income 'Alyssa) 'GeneScam-salary 'investments) 109 | 110 | ;;; Biochemists are paid poorly. 111 | (tell! (thing-of '(GeneScam-salary gross-income Alyssa)) 70000 'GeneScam) 112 | 113 | (tell! (thing-of '(investments gross-income Alyssa)) 114 | (make-interval 30000 40000) 'Alyssa) 115 | 116 | (inquire (thing-of '(investments gross-income Ben))) 117 | ;Value: #(supported #[interval 117000 127000] (gaggle genescam alyssa irs)) 118 | 119 | ;;; Ben is a tightwad 120 | (tell! (thing-of '(expenses Ben)) (make-interval 10000 20000) 'Ben) 121 | 122 | (inquire (thing-of '(net-income Ben))) 123 | ;Value: #(supported #[interval 297000 317000] (ben genescam alyssa irs)) 124 | 125 | ;;; But Alyssa is not cheap. She likes luxury. 126 | (tell! (thing-of '(expenses Alyssa)) (make-interval 200000 215000) 'Alyssa) 127 | 128 | (inquire (thing-of '(net-income Alyssa))) 129 | ;Value: #(supported #[interval -115000 -90000] (alyssa genescam)) 130 | 131 | ;;; But they are doing OK anyway! 132 | (inquire (thing-of '(net-income Ben-Alyssa))) 133 | ;Value: #(supported #[interval 192000 217000] (ben alyssa irs)) 134 | 135 | ;;; Notice that this conclusion does not depend on the details, such 136 | ;;; as Gaggle or GeneScam! 137 | |# 138 | 139 | -------------------------------------------------------------------------------- /adventures/ps07/load.scm: -------------------------------------------------------------------------------- 1 | ;;;; This is the ps07 file load.scm 2 | 3 | (load "ui") 4 | (load "extra") 5 | (load "family") 6 | -------------------------------------------------------------------------------- /adventures/ps07/ps.scm: -------------------------------------------------------------------------------- 1 | (initialize-scheduler) 2 | 3 | ;; Problem 7.1: Warmup 4 | 5 | ;; a. 6 | 7 | (define (make-person person) 8 | (let-cells (height weight) 9 | (eq-put! person 'height height) 10 | (eq-put! person 'weight weight) 11 | 'done)) 12 | 13 | (make-person 'Nada) 14 | (tell! (eq-get 'Nada 'height) (make-interval 168 172) 'nada-estimate) 15 | (tell! (eq-get 'Nada 'weight) (make-interval 50 56) 'nada-estimate) 16 | 17 | (make-person 'Fatso) 18 | (tell! (eq-get 'Fatso 'height) 170 'nada-estimate) 19 | (tell! (eq-get 'Fatso 'weight) 150 'nada-estimate) 20 | 21 | (make-person 'Skinny) 22 | (tell! (eq-get 'Skinny 'height) 170 'nada-estimate) 23 | (tell! (eq-get 'Skinny 'weight) 45 'nada-estimate) 24 | 25 | ;; b. 26 | 27 | (define (bmi person) 28 | (let ((height-m (ce:/ (eq-get person 'height) 100.0)) 29 | (weight-kg (eq-get person 'weight))) 30 | (eq-put! person 'bmi (ce:/ weight-kg (ce:* height-m height-m))) 31 | ((c:bins (named-ranges 'bmi-estimate 32 | `(underweight ,(make-interval 0.0 19.0)) 33 | `(normal ,(make-interval 19.0 25.0)) 34 | `(overweight ,(make-interval 25.0 30.0)) 35 | `(obese ,(make-interval 30.0 100.0)))) 36 | (eq-get person 'bmi)) 37 | 'done)) 38 | 39 | (bmi 'Nada) 40 | (bmi 'Fatso) 41 | (bmi 'Skinny) 42 | 43 | (run) 44 | 45 | (inquire (eq-get 'Nada 'bmi)) ;; 16.9 - 19.8 46 | (tell! (eq-get (eq-get 'Nada 'bmi) 'normal) #t 'badria-estimate) 47 | (inquire (eq-get 'Nada 'bmi)) ;; 19. - 19.8 48 | (inquire (eq-get 'Nada 'weight)) ;; 54 - 56 49 | 50 | (inquire (eq-get (eq-get 'Fatso 'bmi) 'obese)) ;; #t 51 | (inquire (eq-get (eq-get 'Skinny 'bmi) 'underweight)) ;; #t 52 | 53 | ;; Problem 7.2: Building more constraints 54 | 55 | (define (c:sum part-nodes sum-node) 56 | (let loop ((part-nodes part-nodes) (acc (e:constant 0))) 57 | (if (null? part-nodes) 58 | (c:== acc sum-node) 59 | (let ((new-acc (make-cell))) 60 | (c:+ (car part-nodes) acc new-acc) 61 | (loop (cdr part-nodes) new-acc))))) 62 | 63 | (define (breakdown sum-node . part-names) 64 | (for-each (lambda (part-name) 65 | (let-cell part 66 | (add-branch! sum-node part part-name))) 67 | part-names) 68 | (c:sum (map (lambda (part-name) (eq-get sum-node part-name)) part-names) 69 | sum-node) 70 | 'done) 71 | 72 | (define (combine-financial-entities compound . parts) 73 | (assert (every financial-entity? parts)) 74 | (define (c f) (c:sum (map f parts) (f compound))) 75 | (c gross-income) 76 | (c net-income) 77 | (c expenses) 78 | 'done) 79 | -------------------------------------------------------------------------------- /adventures/ps07/ui.scm: -------------------------------------------------------------------------------- 1 | ;;;; This is the ps07 file ui.scm 2 | 3 | ;;; This removes those annoying hash numbers after ;Value: 4 | (set! repl:write-result-hash-numbers? #f) 5 | 6 | ;;; This is part of paranoid programming. 7 | (define (assert p #!optional error-comment irritant) 8 | (if (not p) 9 | (begin 10 | (if (not (default-object? irritant)) 11 | (pp irritant)) 12 | (error 13 | (if (default-object? error-comment) 14 | "Failed assertion" 15 | error-comment))))) 16 | 17 | ;;; This abstracts an annoying composition 18 | (define (depends-on information . premises) 19 | (make-tms (contingent information premises))) 20 | 21 | ;;; This is required because (run) returns old value if there is 22 | ;;; nothing to do. This is a problem if a contradiction is resolved 23 | ;;; by a kick-out! with no propagation. 24 | 25 | (define (tell! cell information . informants) 26 | (assert (cell? cell) "Can only tell something to a cell.") 27 | (set! *last-value-of-run* 'done) 28 | (add-content cell (make-tms (contingent information informants))) 29 | (run)) 30 | 31 | (define (retract! premise) 32 | (set! *last-value-of-run* 'done) 33 | (kick-out! premise) 34 | (run)) 35 | 36 | (define (assert! premise) 37 | (set! *last-value-of-run* 'done) 38 | (bring-in! premise) 39 | (run)) 40 | 41 | 42 | (define (inquire cell) 43 | (assert (cell? cell) "Can only inquire of a cell.") 44 | (let ((v (run))) 45 | (if (not (eq? v 'done)) (write-line v))) 46 | (let ((c (content cell))) 47 | (if (tms? c) 48 | (let ((v (tms-query c))) 49 | (cond ((nothing? v) v) 50 | ((contingent? v) v) 51 | (else 52 | (error "Bug: TMS contains non-contingent statement" 53 | cell)))) 54 | c))) 55 | 56 | -------------------------------------------------------------------------------- /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 ,nogood))) 71 | 72 | (define-structure nogood-effect 73 | nogood) 74 | 75 | (defhandler execute-effect 76 | (lambda (nogood-effect) 77 | (if (all-premises-in? (nogood-effect-nogood nogood-effect)) 78 | (process-nogood! (nogood-effect-nogood nogood-effect)))) 79 | nogood-effect?) 80 | 81 | (defhandler generic-attach-premises 82 | (lambda (effect) 83 | (lambda (support) 84 | (make-nogood-effect 85 | (lset-union eq? (nogood-effect-nogood effect) support)))) 86 | nogood-effect?) 87 | -------------------------------------------------------------------------------- /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 | '("scheduler" 37 | ;"metadata" 38 | "diagrams" 39 | "merge-effects" 40 | "cells" 41 | "cell-sugar" 42 | "propagators" 43 | "application" 44 | "sugar" 45 | "generic-definitions" 46 | "compound-data" 47 | "physical-closures" 48 | "standard-propagators" 49 | "carrying-cells" 50 | 51 | ;;Intervals must follow standard-propagators in the load order 52 | ;;because it depends on interval-non-zero?, numerical-zero?, 53 | ;;binary-nothing, and binary-contradiction previously defined. 54 | 55 | "intervals" 56 | "premises" 57 | "supported-values" 58 | "truth-maintenance" 59 | "contradictions" 60 | "search" 61 | "amb-utils" 62 | 63 | "ui" 64 | "explain" 65 | 66 | "example-networks" 67 | "test-utils")) 68 | 69 | (maybe-warn-low-memory) 70 | (initialize-scheduler) 71 | -------------------------------------------------------------------------------- /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 | ;;(print-procedure #f) 37 | (print-procedure hypothetical-printer) 38 | (safe-accessors #t)) 39 | sign 40 | cell) 41 | 42 | (define *worldview-number* 0) 43 | (define *premise-outness* (make-eq-hash-table)) 44 | 45 | (define (premise-in? premise) 46 | (not (hash-table/get *premise-outness* premise #f))) 47 | 48 | (define (mark-premise-in! premise) 49 | (hash-table/remove! *premise-outness* premise)) 50 | 51 | (define (mark-premise-out! premise) 52 | (hash-table/put! *premise-outness* premise #t)) 53 | 54 | (define *premise-nogoods* (make-eq-hash-table)) 55 | 56 | (define (premise-nogoods premise) 57 | (hash-table/get *premise-nogoods* premise '())) 58 | 59 | (define (set-premise-nogoods! premise nogoods) 60 | (hash-table/put! *premise-nogoods* premise nogoods)) 61 | 62 | (define (reset-premise-info!) 63 | (set! *worldview-number* 0) 64 | (set! *premise-outness* (make-eq-hash-table)) 65 | (set! *premise-nogoods* (make-eq-hash-table))) 66 | 67 | ;;; We also need to arrange for the premise states to be reset for 68 | ;;; every new example. Better creativity having failed me, I will 69 | ;;; hang that action onto the initialize-scheduler procedure. 70 | ;;; TODO Can one do better than redefining initialize-scheduler? 71 | (define initialize-scheduler 72 | (let ((initialize-scheduler initialize-scheduler)) 73 | (lambda () 74 | (initialize-scheduler) 75 | (reset-premise-info!)))) 76 | 77 | (define with-independent-scheduler 78 | (let ((with-independent-scheduler with-independent-scheduler)) 79 | (lambda args 80 | (fluid-let ((*worldview-number* #f) 81 | (*premise-outness* #f) 82 | (*premise-nogoods* #f)) 83 | (apply with-independent-scheduler args))))) 84 | 85 | (define (disbelieving-func premise thunk) 86 | (let ((old-belief (premise-in? premise))) 87 | (kick-out! premise) 88 | (let ((answer (thunk))) 89 | (if old-belief 90 | (bring-in! premise) 91 | (kick-out! premise)) 92 | answer))) 93 | 94 | ;; (disbelieving premise body) 95 | ;; Syntax that executes the given body in a dynamic environment 96 | ;; where the given premise is not believed. 97 | (define-syntax disbelieving 98 | (syntax-rules () 99 | ((_ premise body ...) 100 | (disbelieving-func premise (lambda () body ...))))) 101 | -------------------------------------------------------------------------------- /core/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(set! load-debugging-info-on-demand? #t)' --eval '(begin (load "load") (load "test/load") (show-time run-registered-tests) (newline) (flush-output) (%exit 0))' 4 | -------------------------------------------------------------------------------- /core/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-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 | -------------------------------------------------------------------------------- /core/test/barometer-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 | 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 | (define-test (early-access-test) 48 | (interaction 49 | (initialize-scheduler) 50 | (define-cell source-car) 51 | (define-cell source-cdr) 52 | (define-cell the-pair (e:carry-cons source-car source-cdr)) 53 | (check (eq? source-car (e:carry-car the-pair))) 54 | (check (eq? source-cdr (e:carry-cdr the-pair))) 55 | )) 56 | 57 | (define-test (deposit) 58 | (interaction 59 | (initialize-scheduler) 60 | (define-cell two-cell (e:deposit 2)) 61 | (run) 62 | (check (cell? two-cell)) 63 | (check (cell? (content two-cell))) 64 | (content (content two-cell)) 65 | (produces 2) 66 | (define-cell examined (e:examine two-cell)) 67 | (content examined) 68 | (produces 2))) 69 | 70 | (define-test (examine) 71 | (interaction 72 | (initialize-scheduler) 73 | (define-cell examinee) 74 | (define-cell exam (e:examine examinee)) 75 | (add-content exam 2) 76 | (run) 77 | (check (cell? (content examinee))) 78 | (content (content examinee)) 79 | (produces 2))) 80 | ) 81 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/namin/propagators/ae694dfe680125e53a3d49e5e91c378f2d333937/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/namin/propagators/ae694dfe680125e53a3d49e5e91c378f2d333937/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/revised-html.bbl: -------------------------------------------------------------------------------- 1 | \begin{thebibliography}{1} 2 | 3 | \bibitem{mcbride-paterson-2008-applicative-functors} 4 | Conor McBride and Ross Paterson. 5 | \newblock {Applicative programming with effects}. 6 | \newblock {\em Journal of Functional Programming}, 18(1):1--13, 2008. 7 | 8 | \bibitem{art-thesis} 9 | Alexey Radul. 10 | \newblock {\em {Propagation Networks: A Flexible and Expressive Substrate for 11 | Computation}}. 12 | \newblock PhD thesis, Massachusetts Institute of Technology, Cambridge, MA, 13 | September 2009. 14 | \newblock \url{http://hdl.handle.net/1721.1/49525}. 15 | 16 | \bibitem{art} 17 | Alexey Radul and Gerald~Jay Sussman. 18 | \newblock {The Art of the Propagator}. 19 | \newblock CSAIL Tech Report MIT-CSAIL-TR-2009-002, MIT Computer Science and 20 | Artificial Intelligence Laboratory, Cambridge, MA, 2009. 21 | \newblock \url{http://hdl.handle.net/1721.1/44215}. 22 | 23 | \end{thebibliography} 24 | -------------------------------------------------------------------------------- /doc/revised-html.blg: -------------------------------------------------------------------------------- 1 | This is BibTeX, Version 0.99c (Web2C 7.5.6) 2 | The top-level auxiliary file: revised-html.aux 3 | The style file: plain.bst 4 | Database file #1: revised-auto.bib 5 | You've used 3 entries, 6 | 2118 wiz_defined-function locations, 7 | 568 strings with 5242 characters, 8 | and the built_in function-call counts, 779 in all, are: 9 | = -- 80 10 | > -- 33 11 | < -- 1 12 | + -- 13 13 | - -- 10 14 | * -- 50 15 | := -- 152 16 | add.period$ -- 11 17 | call.type$ -- 3 18 | change.case$ -- 13 19 | chr.to.int$ -- 0 20 | cite$ -- 3 21 | duplicate$ -- 29 22 | empty$ -- 54 23 | format.name$ -- 10 24 | if$ -- 154 25 | int.to.chr$ -- 0 26 | int.to.str$ -- 3 27 | missing$ -- 1 28 | newline$ -- 20 29 | num.names$ -- 6 30 | pop$ -- 6 31 | preamble$ -- 1 32 | purify$ -- 11 33 | quote$ -- 0 34 | skip$ -- 20 35 | stack$ -- 0 36 | substring$ -- 27 37 | swap$ -- 3 38 | text.length$ -- 1 39 | text.prefix$ -- 0 40 | top$ -- 0 41 | type$ -- 12 42 | warning$ -- 0 43 | while$ -- 7 44 | width$ -- 4 45 | write$ -- 41 46 | -------------------------------------------------------------------------------- /doc/revised-html.dvi: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/namin/propagators/ae694dfe680125e53a3d49e5e91c378f2d333937/doc/revised-html.dvi -------------------------------------------------------------------------------- /doc/revised-html.out: -------------------------------------------------------------------------------- 1 | \BOOKMARK [1][-]{section.1}{Propagator System}{} 2 | \BOOKMARK [1][-]{section.2}{Getting Started}{} 3 | \BOOKMARK [2][-]{subsection.2.1}{Examples}{section.2} 4 | \BOOKMARK [1][-]{section.3}{The Details}{} 5 | \BOOKMARK [1][-]{section.4}{Making Propagator Networks}{} 6 | \BOOKMARK [2][-]{subsection.4.1}{Attaching Basic Propagators: d@}{section.4} 7 | \BOOKMARK [2][-]{subsection.4.2}{Propagator Expressions: e@}{section.4} 8 | \BOOKMARK [2][-]{subsection.4.3}{Late Binding of Application}{section.4} 9 | \BOOKMARK [2][-]{subsection.4.4}{Provided Primitives: p:foo and e:foo}{section.4} 10 | \BOOKMARK [2][-]{subsection.4.5}{Cells are Data Too}{section.4} 11 | \BOOKMARK [2][-]{subsection.4.6}{Compound Data}{section.4} 12 | \BOOKMARK [2][-]{subsection.4.7}{Propagator Constraints: c:foo and ce:foo}{section.4} 13 | \BOOKMARK [2][-]{subsection.4.8}{Constants and Literal Values}{section.4} 14 | \BOOKMARK [2][-]{subsection.4.9}{Constant Conversion}{section.4} 15 | \BOOKMARK [2][-]{subsection.4.10}{Making Cells}{section.4} 16 | \BOOKMARK [2][-]{subsection.4.11}{Conditional Network Construction}{section.4} 17 | \BOOKMARK [1][-]{section.5}{Making New Compound Propagators}{} 18 | \BOOKMARK [2][-]{subsection.5.1}{Lexical Scope}{section.5} 19 | \BOOKMARK [2][-]{subsection.5.2}{Recursion}{section.5} 20 | \BOOKMARK [1][-]{section.6}{Using Partial Information}{} 21 | \BOOKMARK [1][-]{section.7}{Built-in Partial Information Structures}{} 22 | \BOOKMARK [2][-]{subsection.7.1}{Nothing}{section.7} 23 | \BOOKMARK [2][-]{subsection.7.2}{Just a Value}{section.7} 24 | \BOOKMARK [2][-]{subsection.7.3}{Numerical Intervals}{section.7} 25 | \BOOKMARK [2][-]{subsection.7.4}{Propagator Cells as Partial Information}{section.7} 26 | \BOOKMARK [2][-]{subsection.7.5}{Compound Data}{section.7} 27 | \BOOKMARK [2][-]{subsection.7.6}{Closures}{section.7} 28 | \BOOKMARK [2][-]{subsection.7.7}{Truth Maintenance Systems}{section.7} 29 | \BOOKMARK [2][-]{subsection.7.8}{Contradiction}{section.7} 30 | \BOOKMARK [2][-]{subsection.7.9}{Implicit Dependency-Directed Search}{section.7} 31 | \BOOKMARK [1][-]{section.8}{Making New Kinds of Partial Information}{} 32 | \BOOKMARK [2][-]{subsection.8.1}{An Example: Adding Interval Arithmetic}{section.8} 33 | \BOOKMARK [2][-]{subsection.8.2}{Generic Coercions}{section.8} 34 | \BOOKMARK [2][-]{subsection.8.3}{The Partial Information Generics}{section.8} 35 | \BOOKMARK [3][-]{subsubsection.8.3.1}{The Full Story on Merge}{subsection.8.3} 36 | \BOOKMARK [2][-]{subsection.8.4}{Individual Propagator Generics}{section.8} 37 | \BOOKMARK [2][-]{subsection.8.5}{Uniform Applicative Extension of Propagators}{section.8} 38 | \BOOKMARK [2][-]{subsection.8.6}{Interoperation with Existing Partial Information Types}{section.8} 39 | \BOOKMARK [1][-]{section.9}{Making New Primitive Propagators}{} 40 | \BOOKMARK [2][-]{subsection.9.1}{Direct Construction from Functions}{section.9} 41 | \BOOKMARK [3][-]{subsubsection.9.1.1}{Expression Style Variants}{subsection.9.1} 42 | \BOOKMARK [2][-]{subsection.9.2}{Propagatify}{section.9} 43 | \BOOKMARK [2][-]{subsection.9.3}{Compound Cell Carrier Construction}{section.9} 44 | \BOOKMARK [2][-]{subsection.9.4}{Fully-manual Low-level Propagator Construction}{section.9} 45 | \BOOKMARK [1][-]{section.10}{Debugging}{} 46 | \BOOKMARK [1][-]{section.11}{Miscellany}{} 47 | \BOOKMARK [2][-]{subsection.11.1}{Macrology}{section.11} 48 | \BOOKMARK [2][-]{subsection.11.2}{Reboots}{section.11} 49 | \BOOKMARK [2][-]{subsection.11.3}{Compiling}{section.11} 50 | \BOOKMARK [2][-]{subsection.11.4}{Scmutils}{section.11} 51 | \BOOKMARK [2][-]{subsection.11.5}{Editing}{section.11} 52 | \BOOKMARK [2][-]{subsection.11.6}{Hacking}{section.11} 53 | \BOOKMARK [2][-]{subsection.11.7}{Arbitrary Choices}{section.11} 54 | \BOOKMARK [3][-]{subsubsection.11.7.1}{Default Application and Definition Style}{subsection.11.7} 55 | \BOOKMARK [3][-]{subsubsection.11.7.2}{Locus of Delayed Construction}{subsection.11.7} 56 | \BOOKMARK [3][-]{subsubsection.11.7.3}{Strategy for Compound Data}{subsection.11.7} 57 | \BOOKMARK [1][-]{section.12}{How this supports the goal}{} 58 | -------------------------------------------------------------------------------- /doc/revised-html.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/namin/propagators/ae694dfe680125e53a3d49e5e91c378f2d333937/doc/revised-html.pdf -------------------------------------------------------------------------------- /doc/revised.bbl: -------------------------------------------------------------------------------- 1 | \begin{thebibliography}{1} 2 | 3 | \bibitem{mcbride-paterson-2008-applicative-functors} 4 | Conor McBride and Ross Paterson. 5 | \newblock {Applicative programming with effects}. 6 | \newblock {\em Journal of Functional Programming}, 18(1):1--13, 2008. 7 | 8 | \bibitem{art-thesis} 9 | Alexey Radul. 10 | \newblock {\em {Propagation Networks: A Flexible and Expressive Substrate for 11 | Computation}}. 12 | \newblock PhD thesis, Massachusetts Institute of Technology, Cambridge, MA, 13 | September 2009. 14 | \newblock \url{http://hdl.handle.net/1721.1/49525}. 15 | 16 | \bibitem{art} 17 | Alexey Radul and Gerald~Jay Sussman. 18 | \newblock {The Art of the Propagator}. 19 | \newblock CSAIL Tech Report MIT-CSAIL-TR-2009-002, MIT Computer Science and 20 | Artificial Intelligence Laboratory, Cambridge, MA, 2009. 21 | \newblock \url{http://hdl.handle.net/1721.1/44215}. 22 | 23 | \end{thebibliography} 24 | -------------------------------------------------------------------------------- /doc/revised.blg: -------------------------------------------------------------------------------- 1 | This is BibTeX, Version 0.99c (Web2C 7.5.6) 2 | The top-level auxiliary file: revised.aux 3 | The style file: plain.bst 4 | Database file #1: revised-auto.bib 5 | You've used 3 entries, 6 | 2118 wiz_defined-function locations, 7 | 568 strings with 5232 characters, 8 | and the built_in function-call counts, 779 in all, are: 9 | = -- 80 10 | > -- 33 11 | < -- 1 12 | + -- 13 13 | - -- 10 14 | * -- 50 15 | := -- 152 16 | add.period$ -- 11 17 | call.type$ -- 3 18 | change.case$ -- 13 19 | chr.to.int$ -- 0 20 | cite$ -- 3 21 | duplicate$ -- 29 22 | empty$ -- 54 23 | format.name$ -- 10 24 | if$ -- 154 25 | int.to.chr$ -- 0 26 | int.to.str$ -- 3 27 | missing$ -- 1 28 | newline$ -- 20 29 | num.names$ -- 6 30 | pop$ -- 6 31 | preamble$ -- 1 32 | purify$ -- 11 33 | quote$ -- 0 34 | skip$ -- 20 35 | stack$ -- 0 36 | substring$ -- 27 37 | swap$ -- 3 38 | text.length$ -- 1 39 | text.prefix$ -- 0 40 | top$ -- 0 41 | type$ -- 12 42 | warning$ -- 0 43 | while$ -- 7 44 | width$ -- 4 45 | write$ -- 41 46 | -------------------------------------------------------------------------------- /doc/revised.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/namin/propagators/ae694dfe680125e53a3d49e5e91c378f2d333937/doc/revised.pdf -------------------------------------------------------------------------------- /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) (show-time run-registered-tests) (newline) (flush-output) (%exit 0))' 4 | -------------------------------------------------------------------------------- /examples/run-mechanics-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ../extensions/mechanics --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(begin (load "load") (load "test/mechanics-load") (show-time run-registered-tests) (newline) (flush-output) (%exit 0))' 4 | -------------------------------------------------------------------------------- /examples/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(begin (load "load") (load "test/load") (show-time run-registered-tests) (newline) (flush-output) (%exit 0))' 4 | -------------------------------------------------------------------------------- /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 | *number-of-calls-to-fail* 34 | (produces (if *false-premise-starts-out* 35 | (if *avoid-false-true-flips* 33 51) 63)) 36 | ))) 37 | -------------------------------------------------------------------------------- /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 (= (if *avoid-false-true-flips* 52 49) 48 | *number-of-calls-to-fail*))) 49 | 50 | ) 51 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /experiment/lash-up.scm: -------------------------------------------------------------------------------- 1 | 2 | (define supported make-depends) 3 | (define more-informative-supports? more-informative-needs?) 4 | 5 | (define contingent make-depends) 6 | (define contingent? depends?) 7 | (define ->contingent ->depends) 8 | (define contingent-able? depends-able?) 9 | (define contingent-info depends-info) 10 | (define contingent-premises depends-premises) 11 | 12 | (define v&s-> v&d->) 13 | (define v&s-equivalent? v&d-equivalent?) 14 | (define v&s-support v&d-needs) 15 | (define v&s-value v&d-value) 16 | (define v&s? v&d?) 17 | 18 | (define ???? #f) -------------------------------------------------------------------------------- /experiment/load.scm: -------------------------------------------------------------------------------- 1 | (define (self-relatively thunk) 2 | (let ((place (ignore-errors current-load-pathname))) 3 | (if (pathname? place) 4 | (with-working-directory-pathname 5 | (directory-namestring place) 6 | thunk) 7 | (thunk)))) 8 | 9 | (define (load-relative filename) 10 | (self-relatively (lambda () (load filename)))) 11 | 12 | 13 | (load-relative "../support/load") 14 | 15 | (cd "../core") 16 | (for-each load 17 | '("scheduler" 18 | "metadata" 19 | "merge-effects" 20 | "cells" 21 | "cell-sugar" 22 | "propagators" 23 | "application" 24 | "sugar" 25 | "generic-definitions" 26 | "compound-data" 27 | "physical-closures" 28 | "standard-propagators" 29 | "carrying-cells" 30 | 31 | ;;Intervals must follow standard-propagators in the load order 32 | ;;because it depends on interval-non-zero?, numerical-zero?, 33 | ;;binary-nothing, and binary-contradiction previously defined. 34 | 35 | "intervals" 36 | "premises")) 37 | 38 | (cd "../experiment") 39 | (for-each load 40 | '("depends" 41 | "lash-up")) 42 | 43 | (cd "../core") 44 | (for-each load 45 | '("truth-maintenance" 46 | "contradictions" 47 | "search" 48 | "amb-utils" 49 | 50 | "example-networks" 51 | "test-utils")) 52 | 53 | (define *virtual-copies* #t) 54 | 55 | (define (maybe thing bool) 56 | (if bool 57 | (list thing) 58 | '())) 59 | 60 | 61 | (cd "../extensions") 62 | (for-each load 63 | `(,@(maybe "virtual-environments" *virtual-copies*) 64 | ,@(maybe "virtual-closures" *virtual-copies*) 65 | "info-alist" 66 | "functional-reactivity" 67 | "solve" ; Requires mechanics to work 68 | "inequalities" ; Requires mechanics to work 69 | "symbolics" ; Requires mechanics to work 70 | "symbolics-ineq" ; Requires mechanics to work 71 | "test-utils")) 72 | 73 | (for-each load 74 | `(,@(maybe "example-closures" *virtual-copies*) 75 | "draw" 76 | "dot-writer" 77 | "graphml-writer")) 78 | 79 | (maybe-warn-low-memory) 80 | (initialize-scheduler) 81 | -------------------------------------------------------------------------------- /experiment/to-work-on: -------------------------------------------------------------------------------- 1 | ;;; in depends.scm figure out ???? 2 | 3 | 4 | 5 | 6 | cd metacirc/prop/ 7 | gjs@maharal:prop$ fgrep "v&s" */*.scm 8 | core/contradictions.scm: (v&s-support consequence))))))))) 9 | core/contradictions.scm:(define (check-consistent! v&s) 10 | core/contradictions.scm: (if (contradictory? v&s) 11 | core/contradictions.scm: (process-nogood! (v&s-support v&s)))) 12 | core/truth-maintenance.scm: ((v&s? stuff) (tms-assimilate-one tms stuff)) 13 | core/truth-maintenance.scm:(define (subsumes? v&s1 v&s2) 14 | core/truth-maintenance.scm: (and (lset<= eq? (v&s-support v&s1) (v&s-support v&s2)) 15 | core/truth-maintenance.scm: (implies? (v&s-value v&s1) (v&s-value v&s2)))) 16 | core/truth-maintenance.scm:(define (tms-assimilate-one tms v&s) 17 | core/truth-maintenance.scm: (if (any (lambda (old-v&s) (subsumes? old-v&s v&s)) 18 | core/truth-maintenance.scm: (filter (lambda (old-v&s) (subsumes? v&s old-v&s)) 19 | core/truth-maintenance.scm: v&s))))) 20 | core/truth-maintenance.scm: (let ((relevant-v&ss 21 | core/truth-maintenance.scm: (filter v&s-believed? (tms-values tms)))) 22 | core/truth-maintenance.scm: (merge* relevant-v&ss))) 23 | core/truth-maintenance.scm:(define (v&s-believed? v&s) 24 | core/truth-maintenance.scm: (all-premises-in? (v&s-support v&s))) 25 | core/truth-maintenance.scm:(define contingency-object-believed? v&s-believed?) 26 | core/truth-maintenance.scm: (lambda (v&s) 27 | core/truth-maintenance.scm: (supported (tms-query (v&s-value v&s)) (v&s-support v&s)))))) 28 | core/truth-maintenance.scm: (lambda (thing) (and (v&s? thing) (tms? (v&s-value thing))))) 29 | core/truth-maintenance.scm:(declare-coercion v&s? ->tms) 30 | core/truth-maintenance.scm: (lset= v&s-equivalent? (tms-values tms1) (tms-values tms2))) 31 | core/truth-maintenance.scm: (let ((values (filter v&s? (map v&s-> (map ->contingent (tms-values tms)))))) 32 | core/truth-maintenance.scm: (v&s? (car values)) 33 | core/truth-maintenance.scm: (null? (v&s-support (car values)))) 34 | core/truth-maintenance.scm: (v&s-value (car values))) 35 | examples/albatross-conundrum.scm: (map v&s-value (map tms-query answer)) 36 | examples/masyu.scm: (v&s-value (tms-query (content cell))))) 37 | examples/masyu.scm: (not (v&s-value (tms-query (content cell)))))) 38 | examples/masyu.scm:(define (fail-together v&ss) 39 | examples/masyu.scm: (process-nogood! (apply lset-union eq? (map v&s-support v&ss)))) 40 | examples/masyu.scm: (let* ((decided (filter v&s? (map tms-query 41 | examples/masyu.scm: (on (filter v&s-value decided))) 42 | examples/masyu.scm: (let ((v&s (tms-query content))) 43 | examples/masyu.scm: (if (nothing? v&s) 44 | examples/masyu.scm: (if (v&s-value v&s) 45 | examples/multiple-dwelling.scm: (map v&s-value (map tms-query (map content answers))) 46 | examples/multiple-dwelling.scm: (map v&s-value (map tms-query (map content answers))) 47 | examples/riddle-of-the-knights.scm: (map v&s-value (map tms-query answer)) 48 | examples/slow-examples.scm: (map v&s-value (map tms-query (show-time find-solution))))) 49 | examples/slow-examples.scm: (let ((answer (map v&s-value (map tms-query (show-time 50 | examples/sudoku.scm: (v&s-value (tms-query thing)))) 51 | extensions/symbolics-ineq.scm: (generic-flatten (v&s-value the-value)) 52 | extensions/symbolics-ineq.scm: (v&s-support the-value)))))))) 53 | extensions/symbolics.scm: (generic-flatten (v&s-value the-value)) 54 | extensions/symbolics.scm: (v&s-support the-value)))))))) 55 | extensions/test-utils.scm: (apply append (map v&s-support (filter v&s? (map tms-query (filter tms? (map content cells)))))))) 56 | support/generics-again.scm: (4 #[compiled-procedure 369 (v&s? "supported-values" #x4) #xf #xed97e7]) 57 | support/generics-again.scm: (1 #[compiled-procedure 369 (v&s? "supported-values" #x4) #xf #xed97e7]) 58 | support/generics-again.scm: #[compiled-procedure 369 (v&s? "supported-values" #x4) #xf #xed97e7] 59 | gjs@maharal:prop$ -------------------------------------------------------------------------------- /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 | mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --load load.scm' 4 | 5 | exec ./mechanics --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --load load.scm --load test/load --eval '(let ((v (show-time run-registered-tests))) (newline) (flush-output) (%exit v))' 6 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /foo.scm: -------------------------------------------------------------------------------- 1 | `(((m87:distance) 2 | has-value 3 | ,(make-interval 16.826740610704704 22.18196419800221) 4 | by 5 | ((p:/) (1000000.) (cell1813)) 6 | with-premises 7 | vandenbergh1985) 8 | ((cell1813) 9 | has-value 10 | ,(make-interval 16826740.610704705 22181964.19800221) 11 | by 12 | ((exp:p) (cell1810)) 13 | with-premises 14 | vandenbergh1985) 15 | ((cell1810) 16 | has-value 17 | ,(make-interval 16.638479881974977 16.91479009313426) 18 | by 19 | ((p:*) (2.302585092994046) (cell1809)) 20 | with-premises 21 | vandenbergh1985) 22 | ((cell1809) 23 | has-value 24 | ,(make-interval 7.226 7.346) 25 | by 26 | ((+:p) (cell1804) (1)) 27 | with-premises 28 | vandenbergh1985) 29 | ((cell1804) 30 | has-value 31 | ,(make-interval 6.226 6.346) 32 | by 33 | ((p:/) (5) (m87:distance-modulus)) 34 | with-premises 35 | vandenbergh1985) 36 | ((m87:distance-modulus) 37 | has-value 38 | ,(make-interval 31.13 31.73) 39 | by 40 | (user) 41 | with-premises 42 | vandenbergh1985)) 43 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | cd support 4 | ./run-tests 5 | 6 | cd ../core 7 | ./run-tests 8 | 9 | cd ../extensions 10 | ./run-tests 11 | 12 | cd ../examples 13 | ./run-tests 14 | ./run-mechanics-tests 15 | 16 | #cd ../explorations/circuits 17 | #./run-tests 18 | -------------------------------------------------------------------------------- /support/auto-compilation.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 (compiled-code-type) 23 | ;; Trying to support the C backend 24 | (if (lexical-unbound? 25 | (nearest-repl/environment) 26 | 'compiler:compiled-code-pathname-type) 27 | "com" 28 | (compiler:compiled-code-pathname-type))) 29 | 30 | (define (cf-conditionally filename) 31 | (fluid-let ((sf/default-syntax-table (nearest-repl/environment))) 32 | (sf-conditionally filename)) 33 | (if (cf-seems-necessary? filename) 34 | (compile-bin-file filename))) 35 | 36 | (define (compiler-available?) 37 | (not (lexical-unbound? (nearest-repl/environment) 'cf))) 38 | 39 | (define (compilation-seems-necessary? filename) 40 | (or (sf-seems-necessary? filename) 41 | (cf-seems-necessary? filename))) 42 | 43 | (define (sf-seems-necessary? filename) 44 | (not (file-processed? filename "scm" "bin"))) 45 | 46 | (define (cf-seems-necessary? filename) 47 | (not (file-processed? filename "bin" (compiled-code-type)))) 48 | 49 | (define (load-compiled filename) 50 | (if (compiler-available?) 51 | (begin (cf-conditionally filename) 52 | (load filename)) 53 | (if (compilation-seems-necessary? filename) 54 | (begin (warn "The compiler does not seem to be loaded") 55 | (warn "Are you running Scheme with --compiler?") 56 | (warn "Skipping compilation; loading source interpreted") 57 | (load (pathname-default-type filename "scm"))) 58 | (load filename)))) 59 | 60 | (define (load-relative-compiled filename) 61 | (self-relatively (lambda () (load-compiled filename)))) 62 | 63 | -------------------------------------------------------------------------------- /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/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-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" 46 | "utils" 47 | "test-utils")) 48 | 49 | (maybe-warn-low-memory) 50 | -------------------------------------------------------------------------------- /support/run-tests: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | mit-scheme --compiler -heap 6000 --batch-mode --no-init-file --eval '(set! load/suppress-loading-message? #t)' --eval '(begin (load "load") (load "test/load") (show-time run-registered-tests) (newline) (flush-output) (%exit 0))' 4 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /testing/Rakefile: -------------------------------------------------------------------------------- 1 | ### ---------------------------------------------------------------------- 2 | ### Copyright 2007-2008 Alexey Radul. 3 | ### ---------------------------------------------------------------------- 4 | ### This file is part of Test Manager. 5 | ### 6 | ### Test Manager 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 | ### Test Manager 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 Test Manager. If not, see . 18 | ### ---------------------------------------------------------------------- 19 | 20 | # -*- ruby-mode -*- 21 | 22 | require 'rake' 23 | 24 | task :default => :test 25 | 26 | desc "Run the full test suite in MIT Scheme and Guile" 27 | task :test => [ :mit_scheme_test, :guile_test ] 28 | 29 | desc "Run the full test suite in MIT Scheme" 30 | task :mit_scheme_test do 31 | sh %Q{mit-scheme --batch-mode --eval "(set! load/suppress-loading-message? #t)" --load load.scm --load all-tests.scm --eval "(%exit (run-registered-tests))"} 32 | end 33 | 34 | desc "Run the full test suite in Guile" 35 | task :guile_test do 36 | sh %Q{guile -l load.scm -l all-tests.scm -c "(exit (run-registered-tests))"} 37 | end 38 | 39 | desc "Run a demonstration test suite to show off failure reports in MIT Scheme" 40 | task :demo do 41 | sh %Q{mit-scheme --batch-mode --eval "(set! load/suppress-loading-message? #t)" --load load.scm --load failure-report-demo.scm --eval "(%exit 0)"} 42 | end 43 | 44 | desc "Run a demonstration test suite to show off failure reports in Guile" 45 | task :guile_demo do 46 | sh %Q{guile -l load.scm -l failure-report-demo.scm -c "(exit 0)"} 47 | end 48 | 49 | desc "Generate html documentation" 50 | task :doc do 51 | sh "cd #{File.dirname(__FILE__)}/doc/; cat testing.pod | pod2html > testing.html" 52 | end 53 | 54 | desc "Delete random temporary files that arise as one works" 55 | task :clean do 56 | sh "cd #{File.dirname(__FILE__)}; find . -name '*~' | xargs rm -f; find . -name 'actions.log' | xargs rm -f; find . -name 'pod2htm*.tmp' | xargs rm -f; " 57 | end 58 | 59 | desc "Prepare a release tarball" 60 | task :release => [:doc, :clean] do 61 | sh "cd #{File.dirname(__FILE__)}; " + %Q{tar --create --verbose --file ../test-manager-1.2.tar --directory .. --exclude="*.svn*" --exclude=.commitmail --exclude=todo.txt test-manager/} 62 | end 63 | -------------------------------------------------------------------------------- /testing/checks.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (cond-expand 21 | (guile 22 | (define-macro (check assertion) 23 | (if (list? assertion) 24 | (compute-check-form assertion "" #f) 25 | `(assert-true assertion)))) 26 | (else 27 | (define-syntax check 28 | (sc-macro-transformer 29 | (lambda (form env) 30 | (let ((assertion (cadr form)) 31 | (message (if (null? (cddr form)) "" (caddr form)))) 32 | (if (list? assertion) 33 | (compute-check-form assertion message env) 34 | `(assert-true ,(close-syntax assertion env) 35 | ,(close-syntax message env))))))))) 36 | 37 | (define (compute-check-form assertion message env) 38 | (define (wrap form) 39 | (close-syntax form env)) 40 | (let loop ((bindings '()) 41 | (names '()) 42 | (assertion-left assertion)) 43 | (if (null? assertion-left) 44 | `(let ,bindings 45 | (assert-proc 46 | (better-message 47 | (list ,@(reverse names)) ',assertion ,(wrap message)) 48 | (lambda () ,(reverse names)))) 49 | (let ((fresh-name (generate-uninterned-symbol))) 50 | (loop (cons (list fresh-name (wrap (car assertion-left))) 51 | bindings) 52 | (cons fresh-name names) 53 | (cdr assertion-left)))))) 54 | 55 | (define (better-message values quoted-form message) 56 | (build-message 57 | message 58 | '("Form : " "\nArg values: " "\n") 59 | quoted-form 60 | (cdr values))) ; cdr avoids the value of the operator 61 | 62 | (define-syntax check-all 63 | (syntax-rules () 64 | ((check-all form ...) 65 | (begin (check form) ...)))) 66 | -------------------------------------------------------------------------------- /testing/doc/CHANGELOG: -------------------------------------------------------------------------------- 1 | From 1.1 to 1.2: 2 | - Official support for Guile dropped. Most everything should still 3 | work. I don't know how hard the rest is to port. 4 | - There is now a check macro that is largely meant to replace the 5 | assert-foo procedures. 6 | - Also define-each-check, which is a combination of define-each-test 7 | and check 8 | - The notion of "matching" is now extensible via the generic (in the 9 | sense of SOS) procedure generic-match. Default methods are provided 10 | for general objects, vectors, lists, and floating-point numbers, as 11 | well as interpreting string patterns as regular expressions. 12 | (MIT Scheme only) 13 | - There is now an interaction macro for writing tests that look 14 | like REPL sessions. It does with a produces procedure that refers 15 | to the value of the last evaluated form, and works within calls to 16 | the interaction macro and at the REPL (REPL is MIT Scheme only). 17 | - Assertions assert-< assert-> assert-<= assert->= added 18 | - It is now an intentional, supported feature that you can use 19 | a delayed expression in the assertion failure message position 20 | to do arbitrary computation if the assertion fails. The return 21 | value of said computation will be printed as an additional message 22 | in the failure report; and the suite will not crash even if that 23 | value fails to be a string. 24 | - There is now a clear-registered-tests! procedure for interactive use. 25 | 26 | From 1.0 to 1.1: 27 | 28 | - You can now use promises (made by delay) as assertion failure 29 | messages. If the message is a promise, the framework will only 30 | force it if the assertion fails. 31 | - Added assert-no-match to complement assert-matches. 32 | - Tests now understand docstrings, meaning they print them if the test 33 | fails. Single-form tests use the test form itself as the docstring. 34 | - Added define-each-test to make single-form tests out of each of its 35 | argument expressions. This is a convenience over writing 36 | (define-test (assert-foo ... )) over and over. 37 | 38 | 39 | -------------------------------------------------------------------------------- /testing/failure-report-demo.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-test (this-test-passes) 21 | (assert-eqv 4 (+ 2 2) "Two plus two isn't four.")) 22 | 23 | (define-test (this-test-fails) 24 | (assert-eqv 5 (+ 2 2) "Two plus two isn't five.")) 25 | 26 | (in-test-group 27 | a-test-group 28 | (define-test (happy-internal-test) 29 | (assert-= 12 (* 3 4) "Three by four should be twelve")) 30 | (define-test (unhappy-internal-test) 31 | (assert-equal '() #f "Nil and false are different")) 32 | (define-test (broken-internal-test) 33 | (foo)) 34 | (let ((this-test-group *current-test-group*)) 35 | (define-test (meta-internal-test) 36 | (assert-equal '(happy-internal-test unhappy-internal-test 37 | broken-internal-test 38 | meta-internal-test) 39 | (omap:key-list (tg:test-map this-test-group)))))) 40 | 41 | (in-test-group 42 | failed-assertion-showcase 43 | (define-test (fail-generic-assert-equivalent) 44 | ((assert-equivalent (lambda (x y) 45 | (or (eq? x y) 46 | (and (list? x) 47 | (list? y))))) 48 | #(a) #(f)))) 49 | 50 | (define-test (this-test-errors) 51 | (assert-eqv 4 (+ 2 (/ 2 0)) "Don't divide by zero.")) 52 | 53 | (define-test 54 | (error "Anonymous tests can fail too")) 55 | 56 | (define-test (check-smoke) 57 | (check (< (+ 2 5) (* 3 2)) "There is a check macro that tries to DWIM.")) 58 | 59 | (define-test (check-error) 60 | (check (error "Errors can happen in checks."))) 61 | 62 | (run-registered-tests) 63 | -------------------------------------------------------------------------------- /testing/guile-conditions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; I apologize to the reader for this horrible collection of hacks, 21 | ;;; but Guile appears to lack a condition system worth the name, so I 22 | ;;; am synthesizing one with exactly (read: only) the characteristics 23 | ;;; I need on top of catch-throw. 24 | 25 | (define-record-type condition 26 | (make-condition type throw-args continuation) 27 | condition? 28 | (type condition/type) 29 | (throw-args condition/throw-args) 30 | (continuation condition/continuation)) 31 | 32 | (define (condition/test-failure? condition) 33 | (eq? 'test-failure (condition/type condition))) 34 | 35 | (define (condition/error? condition) 36 | (not (condition/test-failure? condition))) 37 | 38 | (define (test-fail message) 39 | (throw 'test-failure "test-fail" message #f)) 40 | 41 | (define (capture-unhandled-errors thunk) 42 | "Run the given thunk. If it returns normally, return its return 43 | value. If it signals an error, return an object representing that 44 | error instead." 45 | (let ((error-object #f)) 46 | (catch 47 | #t 48 | thunk 49 | (lambda (key . args) 50 | error-object) 51 | (lambda (key . args) 52 | (call-with-current-continuation 53 | (lambda (thrown-at) 54 | (set! error-object 55 | (make-condition key args thrown-at)))))))) 56 | 57 | (define (write-condition-report condition port) 58 | (define (extract-message throw-arguments) 59 | ;; TODO This relies on the arguments following Guile's throwing 60 | ;; convention. 61 | (let ((message-template (cadr throw-arguments)) 62 | (template-parameters (caddr throw-arguments))) 63 | (if template-parameters 64 | (apply format #f message-template template-parameters) 65 | message-template))) 66 | (display (extract-message (condition/throw-args condition)) port)) 67 | -------------------------------------------------------------------------------- /testing/interactions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; This is an MIT-Scheme specific facility for faking out the repl 21 | ;;; history in tests. For example: 22 | ;; (define-test (interactions) 23 | ;; (interaction 24 | ;; (define foo 5) 25 | ;; (+ foo 2) 26 | ;; (produces 7))) 27 | ;;; will actually verify that (+ foo 2) produces 7 (using the 28 | ;;; generic-match facility). Furthermore, the entire body of the 29 | ;;; (interaction ...) form can be copied into a repl wholesale, and 30 | ;;; will retain the same effect. This relies on fluid-rebinding 31 | ;;; the (out) procedure provided by MIT Scheme. 32 | 33 | (cond-expand 34 | (guile 35 | (define-macro (interaction . subforms) 36 | (compute-interaction-form subforms))) 37 | (else 38 | (define-syntax interaction 39 | (sc-macro-transformer 40 | (lambda (form use-env) 41 | (compute-interaction-form (cdr form))))))) 42 | 43 | (define (compute-interaction-form subforms) 44 | (let ((history-name (make-synthetic-identifier 'history))) 45 | `(let ((,history-name (make-interaction-history))) 46 | (fluid-let ((out (read-interaction ,history-name))) 47 | ,@(map (attach-history-tracking history-name) subforms) 48 | (cadr ,history-name))))) 49 | 50 | (define (attach-history-tracking history-name) 51 | (lambda (subform) 52 | (if (apparent-definition? subform) 53 | subform 54 | `(record-interaction ,subform ,history-name)))) 55 | 56 | (define (apparent-definition? form) 57 | (and (pair? form) 58 | (symbol? (car form)) 59 | (string-search-forward "define" (symbol->string (car form))))) 60 | 61 | (define (make-interaction-history) 62 | (list '*interaction-history*)) 63 | 64 | (define (record-interaction thing history) 65 | (set-cdr! history (cons thing (cdr history)))) 66 | 67 | (define (read-interaction history) 68 | (lambda args 69 | (let-optional args ((index 1)) 70 | (list-ref (cdr history) (- index 1))))) 71 | 72 | (define (produces pattern) 73 | (check (generic-match pattern (out)))) 74 | -------------------------------------------------------------------------------- /testing/load.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; load-relative, broken in Guile, depends on MIT Scheme's pathname 21 | ;; system. 22 | ;; TODO Fix for interactive use? 23 | (cond-expand 24 | (guile 25 | (if (defined? 'load-relative) 26 | 'ok 27 | (define (load-relative filename) 28 | ;; Guile's load appears to magically do the right thing... 29 | (load (string-concatenate (list filename ".scm")))))) 30 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 31 | (define (load-relative filename) 32 | (with-working-directory-pathname 33 | (directory-namestring (current-load-pathname)) 34 | (lambda () (load filename)))))) 35 | 36 | (load-relative "portability") 37 | (load-relative "ordered-map") 38 | (load-relative "matching") 39 | (load-relative "assertions") 40 | (load-relative "test-runner") 41 | (load-relative "test-group") 42 | (load-relative "testing") 43 | (load-relative "checks") 44 | (load-relative "interactions") 45 | 46 | ;; MIT Scheme specific features 47 | (cond-expand 48 | (guile 49 | 'ok) 50 | (else 51 | 'ok)) 52 | -------------------------------------------------------------------------------- /testing/matching.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; Sigh, different object systems 21 | ;; TODO Document user-extensibility of assert-match 22 | ;; TODO Make assert-match user extensible in guile 23 | (cond-expand 24 | (guile 25 | (define (generic-match pattern object) 26 | (cond ((and (string? pattern) 27 | (string? object)) 28 | (re-string-search-forward pattern object)) 29 | (else 30 | (equal? pattern object))))) 31 | (else 32 | (define-generic generic-match (pattern object)) 33 | 34 | (define-method generic-match (pattern object) 35 | (equal? pattern object)) 36 | 37 | (define-method generic-match ((pattern ) (object )) 38 | (re-string-search-forward pattern object)) 39 | 40 | (define-method generic-match ((pattern ) (object )) 41 | (reduce boolean/and #t (map generic-match 42 | (vector->list pattern) 43 | (vector->list object)))) 44 | 45 | (define-method generic-match ((pattern ) (object )) 46 | (and (generic-match (car pattern) (car object)) 47 | (generic-match (cdr pattern) (cdr object)))) 48 | 49 | (define-method generic-match ((pattern ) (object )) 50 | (or (= pattern object) 51 | (= pattern (->significant-figures 5 object)) 52 | (= (->significant-figures 12 pattern) 53 | (->significant-figures 12 object)))))) 54 | 55 | ;; TODO Am I still trying to support Guile? Really? 56 | (cond-expand 57 | (guile 58 | (define (->significant-figures places number) 59 | (define (round-down? digit-trail) 60 | (or (null? digit-trail) 61 | (memq (car digit-trail) '(#\0 #\1 #\2 #\3 #\4)) 62 | (and (eq? (car digit-trail) #\.) 63 | (or (null? (cdr digit-trail)) 64 | (memq (cadr digit-trail) '(#\0 #\1 #\2 #\3 #\4)))))) 65 | (define (decimal-increment reversed-digit-list) 66 | (cond ((null? reversed-digit-list) 67 | '(#\1)) 68 | ((eq? (car reversed-digit-list) #\.) 69 | (cons (car reversed-digit-list) 70 | (decimal-increment (cdr reversed-digit-list)))) 71 | ((eq? (car reversed-digit-list) #\9) 72 | (cons #\0 (decimal-increment (cdr reversed-digit-list)))) 73 | (else 74 | (cons (integer->char (+ 1 (char->integer (car reversed-digit-list)))) 75 | (cdr reversed-digit-list))))) 76 | (let ((digits (string->list (number->string number)))) 77 | (let loop ((result '()) 78 | (more-digits digits) 79 | (places places) 80 | (zeros-matter? #f)) 81 | (cond ((null? more-digits) 82 | (string->number (list->string (reverse result)))) 83 | ;; TODO This relies on being after the decimal point 84 | ((= places 0) 85 | (string->number 86 | (list->string 87 | (reverse 88 | (if (round-down? more-digits) 89 | result 90 | (decimal-increment result)))))) 91 | ((eq? #\. (car more-digits)) 92 | (loop (cons (car more-digits) result) 93 | (cdr more-digits) 94 | places 95 | zeros-matter?)) 96 | ((eq? #\0 (car more-digits)) 97 | (loop (cons (car more-digits) result) 98 | (cdr more-digits) 99 | (if zeros-matter? (- places 1) places) 100 | zeros-matter?)) 101 | (else 102 | (loop (cons (car more-digits) result) 103 | (cdr more-digits) 104 | (- places 1) 105 | #t))))))) 106 | (else 107 | (define (->significant-figures places number) 108 | (string->number 109 | (fluid-let ((flonum-unparser-cutoff `(relative ,places normal))) 110 | (number->string number)))))) 111 | -------------------------------------------------------------------------------- /testing/mit-scheme-tests.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | 21 | -------------------------------------------------------------------------------- /testing/mitscheme-conditions.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;; These are the definitions that are actively intertwined with MIT 21 | ;;; Scheme's condition system, which this test manager originally 22 | ;;; used. They are replaced by equivalent (I hope) domain-specific 23 | ;;; definitions tailored for other condition systems in other 24 | ;;; *-conditions.scm files. 25 | 26 | (define condition-type:test-failure 27 | (make-condition-type 'test-failure condition-type:error 28 | '(message) (lambda (condition port) 29 | (display (access-condition condition 'message) port)))) 30 | 31 | (define condition/test-failure? 32 | (condition-predicate condition-type:test-failure)) 33 | 34 | (define test-fail 35 | (condition-signaller condition-type:test-failure 36 | '(message) standard-error-handler)) 37 | 38 | ;;; Gaah! The signaling of a condition in a flexible language like 39 | ;;; Scheme does not, unlike the raising of an exception in Java, 40 | ;;; entail that the code signaling the condition failed. In fact, it 41 | ;;; is quite possible that the condition will be handled by some 42 | ;;; toplevel condition handler in a manner that will cause the 43 | ;;; underlying code to continue, and eventually produce a normal 44 | ;;; return. For example, Mechanics allows vectors to be applied by 45 | ;;; just such a mechanism. The unit test framework must, 46 | ;;; consequently, try its best to allow such shenanigans to succeed, 47 | ;;; without disrupting the operation of the test framework itself. 48 | ;;; Hence the ugliness below. 49 | ;;; TODO Port this crap to Guile 50 | (define (capture-unhandled-errors thunk) 51 | (if standard-error-hook 52 | ;; Fix this for the test-within-a-test case. 53 | (warn "If the standard error hook is already bound, I can't be sure which errors are unhandled.")) 54 | (call-with-current-continuation 55 | (lambda (k) 56 | (fluid-let ((standard-error-hook k)) 57 | (thunk))))) 58 | -------------------------------------------------------------------------------- /testing/ordered-map.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-record-type ordered-map 21 | (%make-ordered-map entry-list entry-table) 22 | ordered-map? 23 | (entry-list omap:entry-list set-omap:entry-list!) 24 | (entry-table omap:entry-table set-omap:entry-table!)) 25 | 26 | (define (make-ordered-map) 27 | (%make-ordered-map #f (make-hash-table))) 28 | 29 | (define-record-type omap-entry 30 | (make-omap-entry key item next prev) 31 | omap-entry? 32 | (key omap-entry-key set-omap-entry-key!) 33 | (item omap-entry-item set-omap-entry-item!) 34 | (next omap-entry-next set-omap-entry-next!) 35 | (prev omap-entry-prev set-omap-entry-prev!)) 36 | 37 | (define (omap:fetch-entry omap key) 38 | (hash-table-ref/default (omap:entry-table omap) key #f)) 39 | 40 | (define (omap:put! omap key datum) 41 | (let ((entry (omap:fetch-entry omap key))) 42 | (if entry 43 | (set-omap-entry-item! entry datum) 44 | (omap:put-new-entry! omap key datum)))) 45 | 46 | (define (omap:put-new-entry! omap key datum) 47 | (let* ((head (omap:entry-list omap)) 48 | (new-entry (make-omap-entry key datum head #f))) 49 | (if head (set-omap-entry-prev! head new-entry)) 50 | (set-omap:entry-list! omap new-entry) 51 | (hash-table-set! (omap:entry-table omap) key new-entry))) 52 | 53 | (define (omap:get omap key default) 54 | (let ((entry (omap:fetch-entry omap key))) 55 | (if entry 56 | (omap-entry-item entry) 57 | default))) 58 | 59 | (define (omap:remove! omap key) 60 | (let ((entry (omap:fetch-entry omap key))) 61 | (if entry 62 | (omap:remove-entry! omap key entry)))) 63 | 64 | (define (omap:remove-entry! omap key entry) 65 | (hash-table-delete! (omap:entry-table omap) key) 66 | (let ((old-prev (omap-entry-prev entry)) 67 | (old-next (omap-entry-next entry))) 68 | (if old-prev (set-omap-entry-next! old-prev old-next)) 69 | (if old-next (set-omap-entry-prev! old-next old-prev)))) 70 | 71 | (define (omap:count omap) 72 | (hash-table-size (omap:entry-table omap))) 73 | 74 | (define (omap:clear! omap) 75 | (set-omap:entry-table! omap (make-hash-table)) 76 | (set-omap:entry-list! omap #f)) 77 | 78 | (define (omap:key-list omap) 79 | (reverse 80 | (let loop ((head (omap:entry-list omap))) 81 | (if head 82 | (cons (omap-entry-key head) 83 | (loop (omap-entry-next head))) 84 | '())))) 85 | 86 | (define (omap:for-each omap procedure) 87 | (let loop ((head (omap:entry-list omap))) 88 | (if head 89 | (begin (loop (omap-entry-next head)) 90 | (procedure (omap-entry-key head) (omap-entry-item head)))))) 91 | 92 | -------------------------------------------------------------------------------- /testing/portability.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;; Macros 21 | (cond-expand 22 | (guile 23 | (use-modules (ice-9 syncase))) 24 | (else)) 25 | 26 | ;; SRFI-9: define-record-type 27 | (cond-expand 28 | (guile 29 | (use-modules (srfi srfi-9))) 30 | (srfi-9)) 31 | 32 | ;; Structured conditions 33 | (cond-expand 34 | (guile 35 | (load-relative "guile-conditions")) 36 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 37 | (load-relative "mitscheme-conditions"))) 38 | 39 | ;; SRFI-69: Hash tables 40 | (cond-expand 41 | (srfi-69) 42 | (else ; Do I want to use Guile's hash tables instead? 43 | (load-relative "srfi-69-hash-tables"))) 44 | 45 | ;; Optional arguments 46 | (cond-expand 47 | (guile 48 | (use-modules (ice-9 optargs))) 49 | (else ;; The MIT Scheme that knows it is 'mit' isn't in Debian Stable yet 50 | (define-syntax let-optional 51 | (syntax-rules () 52 | ((_ arg-list () expr ...) 53 | (begin expr ...)) 54 | ((_ arg-list ((variable1 default1) binding ...) expr ...) 55 | (if (null? arg-list) 56 | (let ((variable1 default1) binding ...) 57 | expr ...) 58 | (let ((variable1 (car arg-list)) 59 | (arg-list (cdr arg-list))) 60 | (let-optional 61 | arg-list 62 | (binding ...) 63 | expr ...)))) 64 | ((_ arg-list (variable1 binding ...) expr ...) 65 | (let ((variable1 (car arg-list)) 66 | (arg-list (cdr arg-list))) 67 | (let-optional 68 | arg-list 69 | (binding ...) 70 | expr ...))) 71 | )) 72 | )) 73 | 74 | ;; Fluid-let (in the MIT Scheme sense of the word 'fluid'. 75 | (cond-expand 76 | (guile 77 | (define-syntax fluid-let 78 | (syntax-rules () 79 | ((_ () expr ...) 80 | (begin expr ...)) 81 | ((_ ((variable1 value1) binding ...) expr ...) 82 | (let ((out-value variable1) 83 | (in-value value1)) 84 | (dynamic-wind 85 | (lambda () 86 | (set! out-value variable1) 87 | (set! variable1 in-value)) 88 | (lambda () 89 | (fluid-let (binding ...) 90 | expr ...)) 91 | (lambda () 92 | (set! in-value variable1) 93 | (set! variable1 out-value)))))))) 94 | (else)) 95 | 96 | ;; Regexes (using MIT Scheme's name for no good reason) 97 | (cond-expand 98 | (guile 99 | (use-modules (ice-9 regex)) 100 | (define re-string-search-forward string-match)) 101 | (else 102 | (load-option 'regular-expression))) 103 | 104 | (cond-expand 105 | (guile 106 | (define (string-search-forward pattern string) 107 | (string-contains string pattern))) 108 | (else 109 | 'ok)) 110 | 111 | ;; Pretty printing 112 | (cond-expand 113 | (guile 114 | ;; TODO Does Guile have pretty printing? 115 | (define (pp thing) (display thing) (newline))) 116 | (else)) 117 | 118 | ;; Object system 119 | (cond-expand 120 | (guile 121 | 'ok) 122 | (else 123 | (load-option 'sos))) 124 | 125 | ;; Symbols 126 | (cond-expand 127 | (guile 128 | (define (generate-uninterned-symbol) 129 | (make-symbol "symbol")) 130 | (define (make-synthetic-identifier prefix) 131 | (make-symbol (symbol->string prefix)))) 132 | (else 133 | 'ok)) 134 | 135 | ;; Hackery to make syntactic-closures macro code work (with less 136 | ;; hygiene!) in Guile's defmacro system. 137 | (cond-expand 138 | (guile 139 | (define (close-syntax form env) 140 | form)) 141 | (else 142 | 'ok)) 143 | 144 | ;; Faking out the repl history. (produces foo) will not work at the 145 | ;; Guile repl. 146 | (cond-expand 147 | (guile 148 | (define (out) 149 | #f)) 150 | (else 151 | 'ok)) 152 | -------------------------------------------------------------------------------- /testing/test-runner.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2008 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | (define-record-type 21 | (make-test-runner x y z) 22 | test-runner? 23 | (x tr:run-one) 24 | (y tr:run-group) 25 | (z tr:report-results)) 26 | 27 | ;; TODO This currying is kind of nasty, but preferable to a single global 28 | ;; *test-result-map*. Is there a way to get around this nastiness and 29 | ;; preserve a reasonable api for these functions? 30 | (define ((standard-run-one-test result-map) test-name-stack test) 31 | (let ((test-result (capture-unhandled-errors (st:thunk test)))) 32 | (cond 33 | ((and (condition? test-result) 34 | (condition/test-failure? test-result)) 35 | (omap:put! result-map test-name-stack test-result) 36 | (display "F")) 37 | ((and (condition? test-result) 38 | (condition/error? test-result)) 39 | (omap:put! result-map test-name-stack test-result) 40 | (display "E")) 41 | (else (omap:put! result-map test-name-stack 'pass) 42 | (display "."))))) 43 | 44 | (define ((standard-run-test-group result-map) group name-stack) 45 | (define (run-test-in-context name test) 46 | (tg:in-test-context group 47 | (lambda () 48 | (if (single-test? test) 49 | ((standard-run-one-test result-map) 50 | (cons name name-stack) test) 51 | ((standard-run-test-group result-map) 52 | test (cons name name-stack)))))) 53 | (tg:in-group-context group 54 | (lambda () 55 | (omap:for-each 56 | (tg:test-map group) 57 | run-test-in-context)))) 58 | 59 | (define ((standard-report-results result-map)) 60 | (newline) ; Finish the run-one-test wallpaper 61 | (let ((passes 0) 62 | (failures 0) 63 | (errors 0)) 64 | (define (report-misbehavior kind test-name-stack condition) 65 | (display " ") 66 | (display (+ failures errors)) 67 | (display ") ") 68 | (display kind) 69 | (display " (") 70 | (display (condition/continuation condition)) 71 | (display "): ") 72 | (newline) 73 | (display (reverse test-name-stack)) 74 | (display ": ") 75 | (newline) 76 | ;; TODO Oh, what a mess! 77 | (let ((test (tg:get (current-test-group) (reverse test-name-stack)))) 78 | (if test 79 | (let ((docstring (st:docstring test))) 80 | (if docstring 81 | (if (string? docstring) 82 | (begin (display docstring) (newline)) 83 | (pp docstring)))))) 84 | (write-condition-report condition (current-output-port)) 85 | (newline) 86 | (newline)) 87 | (newline) 88 | (omap:for-each 89 | result-map 90 | (lambda (test-name-stack result) 91 | (cond 92 | ((and (condition? result) 93 | (condition/test-failure? result)) 94 | (set! failures (+ failures 1)) 95 | (report-misbehavior "Failure" test-name-stack result)) 96 | ((and (condition? result) 97 | (condition/error? result)) 98 | (set! errors (+ errors 1)) 99 | (report-misbehavior "Error" test-name-stack result)) 100 | ((eq? 'never-ran result)) ; Skip tests that haven't run 101 | (else 102 | (set! passes (+ passes 1)))))) 103 | 104 | (display (+ passes failures errors)) 105 | (display " tests, ") 106 | (display failures) 107 | (display " failures, ") 108 | (display errors) 109 | (display " errors.") 110 | (newline) 111 | (+ failures errors))) 112 | 113 | (define (make-standard-test-runner) 114 | (let ((result-map (make-ordered-map))) 115 | (make-test-runner (standard-run-one-test result-map) 116 | (standard-run-test-group result-map) 117 | (standard-report-results result-map)))) 118 | -------------------------------------------------------------------------------- /testing/testing.scm: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------------- 2 | ;;; Copyright 2007-2009 Alexey Radul. 3 | ;;; ---------------------------------------------------------------------- 4 | ;;; This file is part of Test Manager. 5 | ;;; 6 | ;;; Test Manager 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 | ;;; Test Manager 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 Test Manager. If not, see . 18 | ;;; ---------------------------------------------------------------------- 19 | 20 | ;;;; Test Registration 21 | 22 | (define (register-test test) 23 | (tg:register-test! *current-test-group* test)) 24 | 25 | (define *anonymous-test-count* 0) 26 | 27 | (define (generate-test-name) 28 | (set! *anonymous-test-count* (+ *anonymous-test-count* 1)) 29 | (string->symbol 30 | (string-append "anonymous-test-" (number->string *anonymous-test-count*)))) 31 | 32 | (define (detect-docstring structure) 33 | (if (string? structure) 34 | structure 35 | #f)) 36 | 37 | ;; TODO Teach Emacs to syntax-highlight this just like define 38 | (define-syntax define-test 39 | (syntax-rules () 40 | ((define-test (name formal ...) body-exp1 body-exp2 ...) 41 | (let ((proc (lambda (formal ...) body-exp1 body-exp2 ...))) 42 | (register-test 43 | (make-single-test 'name proc (detect-docstring (quote body-exp1)))))) 44 | ((define-test () body-exp1 body-exp2 ...) 45 | (let ((proc (lambda () body-exp1 body-exp2 ...))) 46 | (register-test 47 | (make-single-test (generate-test-name) proc (detect-docstring (quote body-exp1)))))) 48 | ((define-test form) 49 | (let ((proc (lambda () form))) 50 | (register-test 51 | (make-single-test (generate-test-name) proc (quote form))))))) 52 | 53 | (define-syntax define-each-test 54 | (syntax-rules () 55 | ((define-each-test form ...) 56 | (begin (define-test form) ...)))) 57 | 58 | (define-syntax define-each-check 59 | (syntax-rules () 60 | ((define-each-check form ...) 61 | (begin (define-test () (check form)) ...)))) 62 | 63 | ;;;; Test Running 64 | 65 | ;; Poor man's dynamic dispatch by storing the 66 | ;; procedures that do the job in a record 67 | (define (run-given-test test-runner test) 68 | ((tr:run-one test-runner) (list (st:name test)) test)) 69 | 70 | (define (run-given-group test-runner group name-stack) 71 | ((tr:run-group test-runner) group name-stack)) 72 | 73 | (define (run-given-test-or-group test-runner test name-stack) 74 | (cond ((test-group? test) 75 | (run-given-group test-runner test name-stack)) 76 | ((single-test? test) 77 | (run-given-test test-runner test)) 78 | (else 79 | (error "Unknown test type" test)))) 80 | 81 | (define (report-results test-runner) 82 | ((tr:report-results test-runner))) 83 | 84 | ;; Allows access to old test results if needed and keeps failure 85 | ;; continuations from getting garbage collected. 86 | (define *last-test-runner* #f) 87 | 88 | (define (run-test test-name-stack . opt-test-runner) 89 | (let-optional opt-test-runner ((test-runner (make-standard-test-runner))) 90 | (let loop ((test (current-test-group)) 91 | (stack-left test-name-stack) 92 | (stack-traversed '())) 93 | (cond ((null? stack-left) 94 | (run-given-test-or-group test-runner test (reverse stack-traversed))) 95 | ((test-group? test) 96 | (tg:in-group-context test 97 | (lambda () 98 | (tg:in-test-context test 99 | (lambda () 100 | (loop (tg:get test (car stack-left)) 101 | (cdr stack-left) 102 | (cons (car stack-left) stack-traversed))))))) 103 | (else 104 | (error "Name stack did not lead to a valid test" test-name-stack)))) 105 | (set! *last-test-runner* test-runner) 106 | (report-results test-runner))) 107 | 108 | (define (run-registered-tests . opt-test-runner) 109 | (apply run-test (cons '() opt-test-runner))) 110 | 111 | (define (clear-registered-tests!) 112 | (tg:clear! (current-test-group))) 113 | --------------------------------------------------------------------------------