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)))] clients)))]
[annotate-module? (lambda (fn m) [annotate-module? (lambda (fn m)
(memf (lambda (sym) (eq? sym fn)) (memf (lambda (sym) (equal? sym fn))
all-used-module-paths))] all-used-module-paths))]
[annotator (lambda (fn m stx) [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 them in DrScheme by switching to the MzTake language
and clicking the "Run" button. 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 demos/sine/sine-test.ss - plots values extracted from the
running program running program
demos/djikstra/dijkstra-test.ss - debugs a buggy implementation of
Dijkstra's algorithm
demos/montecarlo/montecarlo-test.ss - visualizes Monte Carlo integration demos/montecarlo/montecarlo-test.ss - visualizes Monte Carlo integration
used to derive the value of pi 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)))) (thread-wait (thread (lambda () (run))))
; program terminates ; program terminates
(stop process) (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? ; 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 ; Keeps a list of the last n values of a behavior
(define (history-b n stream) (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))) (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 ; Counts number of event pings on an eventstream
(define (count-e evs) (define (count-e evs)