suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixed a subtle bug in annotator? in the debugger-model -- it was using eq? instead of equal?

Browse Source 
added (though it is broken) the dijkstra demo

updated the heap.ss file for frtime -- greg needs a copy of this.

added history-e

svn: r137
This commit is contained in:
Jono Spiro 2004-08-04 10:20:23 +00:00
parent 1bf87542d9
commit 94cc1c3b72
8 changed files with 683 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mztake/debugger-model.ss
View File

@ -52,7 +52,7 @@
clients)))]
[annotate-module? (lambda (fn m)
(memf (lambda (sym) (eq? sym fn))
(memf (lambda (sym) (equal? sym fn))
all-used-module-paths))]
[annotator (lambda (fn m stx)

49
collects/mztake/demos/dijkstra/dijkstra-solver.ss Normal file
View File

@ -0,0 +1,49 @@
(module dijkstra-solver mzscheme
(require (lib "heap.ss" "frtime")
(lib "list.ss")
"graph.ss")
(provide (all-defined))
(define (make-node label x y weight) (vector label x y weight))
(define (node-label n) (vector-ref n 0))
(define (node-x n) (vector-ref n 1))
(define (node-y n) (vector-ref n 2))
(define (node-weight n) (vector-ref n 3))
(define (set-node-weight! n v) (vector-set! n 3 v))
(define (node< a b) (< (node-weight a) (node-weight b)))
(define (sqr x) (* x x))
(define (distance-to a b)
(sqrt (+ (sqr (- (node-x a) (node-x b)))
(sqr (- (node-y a) (node-y b))))))
(define (hash-table-pairs hash)
(hash-table-map hash (lambda (key val) (list key val))))
(define (relax backtrace heap origin dest)
(let ([candidate-weight
(+ (node-weight origin)
(distance-to origin dest))])
(when (candidate-weight . < . (node-weight dest))
(set-node-weight! dest candidate-weight)
;;(heap-resort heap dest)
(hash-table-put! backtrace dest origin))))
(define (solve graph nodes source)
(let ([backtrace (make-hash-table)]
[heap (make-heap node< eq?)])
(set-node-weight! source 0)
(for-each (lambda (node) (heap-insert heap node))
nodes)
(let loop ()
(unless (heap-empty? heap)
(let* ([node (heap-pop heap)]
[successors (graph-succs graph node)])
(for-each
(lambda (succ) (relax backtrace heap node succ))
successors))
(loop)))
(hash-table-pairs backtrace))))

40
collects/mztake/demos/dijkstra/dijkstra-test.ss Normal file
View File

@ -0,0 +1,40 @@
(require "dijkstra-solver.ss"
(lib "match.ss"))
(mztake-process p
("dijkstra.ss")
((lib "heap.ss" "frtime")
[inserts 49 6 bind 'item]
[removes 67 10 bind 'result]))
(define (not-in-order e)
(filter-e
(match-lambda
[('reset _) false]
[(_ 'reset) false]
[(previous current) (> previous current)])
(history-e 2 e)))
(history-e 5 (history-e 2 (merge-e (removes . ==> . node-weight)
(inserts . -=> . 'reset))))
(define violations
(not-in-order (merge-e (removes . ==> . node-weight)
(inserts . -=> . 'reset))))
(define latest-violation (hold violations))
(define ((insert-in-model item) model) (cons item model))
(define ((remove-from-model item) model) (filter (lambda (i) (eq? i item)) model))
(define inserters (inserts . ==> . insert-in-model))
(define removers (removes . ==> . remove-from-model))
(define model (accum-b (merge-e inserters removers) empty))
(printf-b "latest-violation: ~a" latest-violation)
(printf-b "model: ~a" model)
(start/resume p)

40
collects/mztake/demos/dijkstra/dijkstra.ss Normal file
View File

@ -0,0 +1,40 @@
(module dijkstra mzscheme
(require "dijkstra-solver.ss"
"graph.ss"
(lib "list.ss"))
(print-struct #t)
(define g (make-graph 'directed))
(define (m-node label x y) (make-node label x y +inf.0))
(define nodes
(list
(m-node 'J 200 100)
(m-node 's 100 125)
(m-node '1 150 100)
(m-node '2 150 150)
(m-node '4 250 100)
(m-node '5 300 100)
(m-node '6 300 150)))
(for-each (lambda (n) (graph-node-add! g n)) nodes)
(define (n-ref label)
(first (filter (lambda (n) (eq? label (node-label n))) nodes)))
(define edges
(list (list (n-ref 's) (n-ref '1))
(list (n-ref 's) (n-ref '2))
(list (n-ref '1) (n-ref 'J))
(list (n-ref '4) (n-ref '5))
(list (n-ref 'J) (n-ref '4))
(list (n-ref 'J) (n-ref '6))))
(for-each (lambda (e) (graph-edge-add! g (first e) (second e)))
edges)
(require (lib "pretty.ss"))
;(printf "input:~n")
;(pretty-print (graph-to-list g))
(printf "output:~n")
(print-struct #t)
(pretty-print (solve g (reverse nodes) (n-ref 's)))
)

543
collects/mztake/demos/dijkstra/graph.ss Normal file
View File

@ -0,0 +1,543 @@
;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*-
(module graph mzscheme
(require (lib "more-useful-code.ss" "mztake" "private"))
(provide make-graph
;; --- Constructors :
graph?
graph-directed?
graph-make-similar
graph-copy
graph-add-all!
;; --- Functions on nodes:
graph-nodes
graph-nodes-size
graph-make-node!
graph-node-add!
graph-node-mem?
graph-node-set!
graph-node-remove!
graph-node-collapse!
graph-node-has-label?
graph-node-label
graph-for-each-node
graph-fold-nodes
;; --- Functions on neighbors:
graph-succs
graph-preds
graph-adjs
graph-for-each-adjs
;; --- Functions on edges:
graph-edges
graph-edges-size
graph-edge-add!
graph-edge-mem?
graph-edge-set!
graph-edge-remove!
graph-edge-has-label?
graph-edge-label
graph-for-each-edge
graph-fold-edges
;; --- Simple graph algorithms:
graph-dfs-from-node
graph-dfs-all
graph-components
graph-strongly-connected-components
graph-topological-sort
;; --- Debugging:
graph-to-list
graph-to-string
graph-test
)
(define-struct t (flags nNodes nEdges nodes successors predessessors))
;; Flags can be: 'equal 'directed 'unique-node 'unique-edge 'nodes-must-exists 'safe
;; 'safe is a short for '(unique-node unique-edge nodes-must-exists)
(define (make-graph . flags)
(let ((flag-hash (make-hash)))
(set! flags (expands-safe-flag flags))
(for-each-f flags (lambda (flag) (hash-put! flag-hash flag true)))
(if (member 'equal flags)
(make-t flag-hash 0 0 (make-hash 'equal) (make-hash 'equal) (make-hash 'equal))
(make-t flag-hash 0 0 (make-hash) (make-hash) (make-hash)))))
(define (graph? graph) (t? graph))
(define no-value (box empty))
;; Makes a hash with the same 'equal as the graph
(define (graph-make-hash graph)
(if (graph-has-flag? graph 'equal)
(make-hash 'equal)
(make-hash)))
(define (expands-safe-flag flags)
(let loop ((cur flags) (acc empty))
(cond [(empty? cur) acc]
[(eq? (first cur) 'safe) (loop (rest cur) (append '(unique-node unique-edge nodes-must-exists) flags))]
[true (loop (rest cur) (cons (first cur) acc))])))
;; Make a graph with mostly the same flags as another graph
(define (graph-make-similar graph plus-flags minus-flags)
(set! plus-flags (expands-safe-flag plus-flags))
(set! minus-flags (expands-safe-flag minus-flags))
(apply make-graph
(append plus-flags
(filter (lambda (i) (not (member i minus-flags)))
(hash-keys (t-flags graph))))))
(define (graph-copy graph)
(let* ((rtn-nodes (graph-make-hash graph))
(rtn-successors (graph-make-hash graph))
(rtn-predessessors (graph-make-hash graph))
(rtn (make-t (t-flags graph) (t-nNodes graph) (t-nEdges graph) rtn-nodes rtn-successors rtn-predessessors)))
(hash-add-all! rtn-nodes (t-nodes graph))
(hash-add-all! rtn-successors (t-successors graph))
(hash-add-all! rtn-predessessors (t-predessessors graph))
rtn))
(define (graph-add-all! dest-graph src-graph)
(graph-for-each-node
src-graph
(lambda (node)
(if (graph-node-has-label? src-graph node)
(graph-node-add! dest-graph node (graph-node-label src-graph node))
(graph-node-add! dest-graph node))))
(graph-for-each-edge
src-graph
(lambda (from to)
(if (graph-edge-has-label? src-graph from to)
(graph-edge-add! dest-graph from to (graph-edge-label src-graph from to))
(graph-edge-add! dest-graph from to)))))
(define (graph-has-flag? graph flag)
(hash-mem? (t-flags graph) flag))
(define (graph-directed? graph)
(hash-mem? (t-flags graph) 'directed))
;;; =====================================================================
;;; Nodes
(define (graph-nodes graph) (hash-keys (t-nodes graph)))
(define (graph-nodes-size graph) (t-nNodes graph))
(define graph-make-node!
(case-lambda
[(graph) (graph-make-node! graph no-value)]
[(graph val)
(let ((sym (string->symbol (string-append "node" (number->string (t-nNodes graph))))))
(graph-node-add! graph sym val)
sym)]))
;; Add a node to the graph. If the node already exists,
;; sets its label, unless the graph has the 'unique-node property,
;; in which case this will assert.
(define graph-node-add!
(case-lambda
[(graph node) (graph-node-add! graph node no-value)]
[(graph node val)
(if (hash-mem? (t-nodes graph) node)
(assert (not (graph-has-flag? graph 'unique-node)))
(begin
(set-t-nNodes! graph (+ 1 (t-nNodes graph)))
(hash-put! (t-successors graph) node (graph-make-hash graph))
(if (graph-directed? graph)
(hash-put! (t-predessessors graph) node (graph-make-hash graph)))))
(hash-put! (t-nodes graph) node val)]))
(define (graph-node-mem? graph node)
(hash-mem? (t-nodes graph) node))
(define (graph-node-set! graph node val)
(assert (hash-mem? (t-nodes graph) node))
(hash-put! (t-nodes graph) node val))
(define (graph-node-remove! graph node)
(assert (graph-node-mem? graph node))
(for-each-f (hash-get (t-successors graph) node)
(lambda (i) (graph-edge-remove! graph node i)))
(if (graph-directed? graph)
(for-each-f (hash-get (t-predessessors graph) node)
(lambda (i) (graph-edge-remove! graph i node))))
(hash-remove! (t-nodes graph) node)
(hash-remove! (t-successors graph) node)
(if (graph-directed? graph)
(hash-remove! (t-predessessors graph) node))
(set-t-nNodes! graph (- (t-nNodes graph) 1)))
(define graph-node-collapse!
(case-lambda
[(graph node with-self-loop) (graph-node-collapse! graph node with-self-loop (lambda (pred-label succ-label) no-value))]
[(graph node with-self-loop label-fn)
(let ((is-directed (graph-directed? graph)))
(for-each-f
(if is-directed
(hash-get (t-predessessors graph) node)
(hash-get (t-successors graph) node))
(lambda (pred)
(for-each-f
(hash-get (t-successors graph) node)
(lambda (succ)
(unless (or (and (not is-directed) (eq? pred succ))
(graph-edge-mem? graph pred succ))
(let* ((label-pred (hash-get (hash-get (t-successors graph) pred) node))
(label-succ (hash-get (hash-get (t-successors graph) node) succ))
(new-label (label-fn (if (eq? label-pred no-value) false label-pred)
(if (eq? label-succ no-value) false label-succ))))
(when (or with-self-loop (not (eq? pred succ)))
(hash-put! (hash-get (t-successors graph) pred) succ new-label)
(if is-directed
(hash-put! (hash-get (t-predessessors graph) succ) pred new-label)
(hash-put! (hash-get (t-successors graph) succ) pred new-label))))))))))
(graph-node-remove! graph node)]))
(define (graph-node-has-label? graph node)
(not (eq? (hash-get (t-nodes graph) node) no-value)))
(define (graph-node-label graph node)
(let ((r (hash-get (t-nodes graph) node)))
(if (eq? r no-value) (error "graph-node-label: no value for node" node)
r)))
(define (graph-succs graph node)
(assert (graph-directed? graph))
(hash-keys (hash-get (t-successors graph) node)))
(define (graph-preds graph node)
(assert (graph-directed? graph))
(hash-keys (hash-get (t-predessessors graph) node)))
(define (graph-adjs graph node)
(if (graph-directed? graph)
(append (hash-keys (hash-get (t-successors graph) node))
(hash-keys (hash-get (t-predessessors graph) node)))
(hash-keys (hash-get (t-successors graph) node))))
(define (graph-for-each-adjs graph node fn)
(for-each (lambda (succ) (fn node succ))
(hash-get (t-successors graph) node))
(when (graph-directed? graph)
(for-each (lambda (pred) (fn pred node))
(hash-get (t-predessessors graph) node))))
(define (graph-for-each-node graph fn)
(for-each-f (t-nodes graph) fn))
(define (graph-fold-nodes graph init fn)
(let ((acc init))
(graph-for-each-node
graph
(lambda (node) (set! acc (fn node acc))))
acc))
;;; =====================================================================
;;; Edges
(define (graph-edges graph)
(let ((rtn empty))
(graph-for-each-edge graph (lambda (from to) (set! rtn (cons from to))))
rtn))
(define (graph-edges-size graph) (t-nEdges graph))
;; Add an edge to the graph. If the edge already exists,
;; sets its label, unless the graph has the 'unique-edge property,
;; in which case this will assert.
(define graph-edge-add!
(case-lambda
[(graph from to) (graph-edge-add! graph from to no-value)]
[(graph from to val)
(if (graph-edge-mem? graph from to)
(assert (not (graph-has-flag? graph 'unique-edge)))
(set-t-nEdges! graph (+ (t-nEdges graph) 1)))
(if (graph-has-flag? graph 'nodes-must-exists)
(assert (and (graph-node-mem? graph from) (graph-node-mem? graph to)))
(begin (if (not (graph-node-mem? graph from)) (graph-node-add! graph from))
(if (not (graph-node-mem? graph to)) (graph-node-add! graph to))))
(hash-put! (hash-get (t-successors graph) from) to val)
(if (graph-directed? graph)
(hash-put! (hash-get (t-predessessors graph) to) from val)
(hash-put! (hash-get (t-successors graph) to) from val))]))
(define (graph-edge-mem? graph from to)
(if (graph-has-flag? graph 'nodes-must-exists)
(assert (and (graph-node-mem? graph from)
(graph-node-mem? graph to))))
(and (hash-mem? (t-successors graph) from)
(hash-mem? (hash-get (t-successors graph) from) to)))
(define (graph-edge-set! graph from to val)
(assert (graph-edge-mem? graph from to))
(hash-put! (hash-get (t-successors graph) from) to val)
(if (graph-directed? graph)
(hash-put! (hash-get (t-predessessors graph) to) from val)
(hash-put! (hash-get (t-successors graph) to) from val)))
(define (graph-edge-remove! graph from to)
(assert (graph-edge-mem? graph from to))
(hash-remove! (hash-get (t-successors graph) from) to)
(if (graph-directed? graph)
(hash-remove! (hash-get (t-predessessors graph) to) from)
(hash-remove! (hash-get (t-successors graph) to) from)))
(define (graph-edge-has-label? graph from to)
(not (eq? (hash-get (hash-get (t-successors graph) from) to) no-value)))
(define (graph-edge-label graph from to)
(let ((r (hash-get (hash-get (t-successors graph) from) to)))
(if (eq? r no-value) (error "graph-edge-label: no value for edge" (cons from to)))
r))
(define (graph-for-each-edge graph fn)
(graph-for-each-node
graph
(lambda (from)
(for-each-f (hash-get (t-successors graph) from)
(lambda (to) (fn from to))))))
(define (graph-fold-edges graph init fn)
(let ((acc init))
(graph-for-each-edge
graph
(lambda (from to) (set! acc (fn from to acc))))
acc))
;;; =====================================================================
;;; Algos
(define (graph-dfs-from-node-with-log graph node dealt-with pre-fn post-fn backward)
(assert (or (not backward) (graph-directed? graph)))
(if (not (hash-mem? dealt-with node))
(begin (hash-put! dealt-with node true)
(pre-fn node)
(for-each-f (if backward
(hash-get (t-predessessors graph) node)
(hash-get (t-successors graph) node))
(lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward)))
(post-fn node))))
(define graph-dfs-from-node
(case-lambda
[(graph node pre-fn) (graph-dfs-from-node graph node pre-fn (lambda (i) i))]
[(graph node pre-fn post-fn)
(graph-dfs-from-node-with-log graph node (graph-make-hash graph) pre-fn post-fn false)]))
(define graph-dfs-all
(case-lambda
[(graph pre-fn) (graph-dfs-all graph pre-fn (lambda (i) i))]
[(graph pre-fn post-fn)
(let ((dealt-with (graph-make-hash graph)))
(graph-for-each-node graph (lambda (n) (if (not (hash-mem? dealt-with n))
(graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn false)))))]))
(define (graph-components graph)
(let ((dealt-with (graph-make-hash graph)))
(graph-fold-nodes
graph
empty
(lambda (node acc)
(if (hash-mem? dealt-with node) acc
(let ((cur-component
(let loop ((cur node) (acc empty))
(if (hash-mem? dealt-with cur) acc
(begin (hash-put! dealt-with cur true)
(foldl (lambda (adj acc) (loop adj acc)) (cons cur acc)
(graph-adjs graph cur)))))))
(cons cur-component acc)))))))
(define (graph-strongly-connected-components graph)
(assert (graph-directed? graph))
(let ((finish-times empty)
(dealt-with (graph-make-hash graph)))
(graph-for-each-node
graph
(lambda (n) (graph-dfs-from-node-with-log
graph n dealt-with
(lambda (i) i)
(lambda (i) (set! finish-times (cons i finish-times)))
false)))
(set! dealt-with (graph-make-hash graph))
(let ((component-graph (graph-make-similar graph empty '(safe equal)))
(node2supernode (make-hash)))
(for-each-f
finish-times
(lambda (n)
(if (not (hash-mem? dealt-with n))
(let ((super-node (graph-make-node! component-graph empty)))
(graph-dfs-from-node-with-log
graph n dealt-with
(lambda (i)
(graph-node-set! component-graph super-node (cons i (graph-node-label component-graph super-node)))
(hash-put! node2supernode i super-node))
(lambda (i) i)
true)))))
(graph-for-each-edge graph
(lambda (from to)
(graph-edge-add! component-graph
(hash-get node2supernode from)
(hash-get node2supernode to))))
(cons component-graph node2supernode))))
(define (graph-topological-sort graph)
(assert (graph-directed? graph))
(let ((rtn empty))
(graph-dfs-all graph (lambda (i) i) (lambda (node) (set! rtn (cons node rtn))))
rtn))
;;; =====================================================================
;;; Utils
(define graph-to-list
(case-lambda
[(graph) (graph-to-list graph false)]
[(graph with-labels)
(hash-map (t-nodes graph)
(lambda (node node-val)
(let ((node-rep (if (and with-labels (graph-node-has-label? graph node))
(cons node (graph-node-label graph node))
node)))
(cons node-rep
(hash-fold (hash-get (t-successors graph) node) empty
(lambda (succ edge-val acc)
(if (and with-labels (graph-edge-has-label? graph node succ))
(cons (cons succ (graph-edge-label graph node succ)) acc)
(cons succ acc))))))))]))
(define (graph-to-string-prv graph with-labels to-string)
(let ([the-to-string (or to-string
(lambda (item) (format "~a" item)))])
(string-append (if (graph-directed? graph) "[di-graph: " "[undirected-graph:")
(the-to-string (map (lambda (n)
(cons (first n) (cons '--> (rest n))))
(graph-to-list graph with-labels)))
"]")))
(define (graph-to-string graph . to-string)
(graph-to-string-prv graph false (if (empty? to-string) false (first to-string))))
(define (graph-to-string-with-labels graph . to-string)
(graph-to-string-prv graph true (if (empty? to-string) true (first to-string))))
(define to-string-f (make-to-string `((,t? ,graph-to-string))))
(define debug-f (make-debug to-string-f))
(define for-each-f (make-for-each))
;;; =====================================================================
;;; Tests
(define (graph-test)
(define graph (make-graph 'safe 'directed))
(graph-node-add! graph 'a)
(graph-node-add! graph 'b 2)
(graph-node-add! graph 'c 3)
(graph-node-add! graph 'd)
(graph-edge-add! graph 'a 'c)
(graph-edge-add! graph 'a 'd "asd")
(graph-edge-add! graph 'b 'c "dfg")
(graph-edge-add! graph 'b 'd)
(graph-edge-add! graph 'd 'a)
(display (graph-node-mem? graph 'a))
(display (graph-edge-mem? graph 'a 'c))
(newline)
(display (graph-node-mem? graph 'v))
(display (graph-edge-mem? graph 'c 'a))
(display (graph-edge-mem? graph 'a 'b))
(newline)
(debug-f (graph-to-list graph true))
(graph-for-each-edge graph (lambda (a b) (debug-f "A " a b)))
(graph-dfs-from-node graph 'a (lambda (i) (display i)))
(newline)
(graph-dfs-from-node graph 'b (lambda (i) (display i)))
(newline)
(graph-dfs-from-node graph 'c (lambda (i) (display i)))
(newline)
(graph-dfs-from-node graph 'd (lambda (i) (display i)))
(newline)
(let ((star (make-graph 'directed)))
(graph-edge-add! star 1 'x)
(graph-edge-add! star 'x 1)
(graph-edge-add! star 2 'x)
(graph-edge-add! star 'x 3)
(graph-edge-add! star 'x 4)
(graph-edge-add! star 'x 5)
(graph-node-collapse! star 'x false)
(debug-f "collapsed:" (graph-to-list star)))
(let ((strong-graph (make-graph 'directed)))
(graph-edge-add! strong-graph 'e 'a)
(graph-edge-add! strong-graph 'a 'b)
(graph-edge-add! strong-graph 'b 'e)
(graph-edge-add! strong-graph 'e 'f)
(graph-edge-add! strong-graph 'b 'f)
(graph-edge-add! strong-graph 'b 'c)
(graph-edge-add! strong-graph 'f 'g)
(graph-edge-add! strong-graph 'g 'f)
(graph-edge-add! strong-graph 'c 'g)
(graph-edge-add! strong-graph 'c 'd)
(graph-edge-add! strong-graph 'd 'c)
(graph-edge-add! strong-graph 'g 'h)
(graph-edge-add! strong-graph 'd 'h)
(graph-edge-add! strong-graph 'h 'h)
(graph-edge-add! strong-graph 'xa 'xb)
(graph-edge-add! strong-graph 'xb 'xc)
(graph-edge-add! strong-graph 'xc 'xa)
(debug-f "strong-graph" strong-graph)
(debug-f "component" (graph-components strong-graph))
(let ((components (graph-strongly-connected-components strong-graph)))
(debug-f "strong-components" components)
(debug-f "toposort" (graph-topological-sort (first components)))))
(let ((u-graph (make-graph)))
(graph-edge-add! u-graph 'a 'b)
(graph-edge-add! u-graph 'b 'c)
(graph-edge-add! u-graph 'c 'd)
(graph-edge-add! u-graph 'd 'a)
(graph-edge-add! u-graph 'd 'e)
(graph-edge-add! u-graph 'e 'c)
(graph-edge-add! u-graph 'xa 'xb)
(graph-edge-add! u-graph 'xa 'xc)
(graph-edge-add! u-graph 'xb 'xd)
(newline)
(debug-f "u-graph" u-graph)
(graph-edge-remove! u-graph 'b 'a)
(graph-node-remove! u-graph 'd)
(debug-f "u-graph" u-graph)
(debug-f "component" (graph-components u-graph)))
)
;(graph-test)
)

6
collects/mztake/doc.txt
View File

@ -77,11 +77,15 @@ different uses of MzTake. You should be able to run
them in DrScheme by switching to the MzTake language
and clicking the "Run" button.
demos/highway/highway-test.ss - small MzTake example used above
demos/highway/highway-test.ss - a small MzTake example, used above
demos/sine/sine-test.ss - plots values extracted from the
running program
demos/djikstra/dijkstra-test.ss - debugs a buggy implementation of
Dijkstra's algorithm
demos/montecarlo/montecarlo-test.ss - visualizes Monte Carlo integration
used to derive the value of pi

2
collects/mztake/mztake.ss
View File

@ -337,7 +337,7 @@ TESTING/CAPABILITIES------------------------------------------------------------
(thread-wait (thread (lambda () (run))))
; program terminates
(stop process)
(print-info (format "process terminated: ~a" (main-client-name process))))))
(print-info (format "process exited normally: ~a" (main-client-name process))))))
; predicate - is the debugee supposed to be running now?

5
collects/mztake/private/useful-code.ss
View File

@ -8,8 +8,11 @@
; Keeps a list of the last n values of a behavior
(define (history-b n stream)
(hold (history-e n stream) empty))
(define (history-e n stream)
(define ((add-to-hist thing) hist) (append (if ((length hist) . < . n) hist (rest hist)) (list thing)))
(accum-b (stream . ==> . add-to-hist) empty))
(accum-e (stream . ==> . add-to-hist) empty))
; Counts number of event pings on an eventstream
(define (count-e evs)