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

cleaned up and fixed base-gm.ss in frtime and mztake

Browse Source 
svn: r2596
This commit is contained in:
Guillaume Marceau 2006-04-04 23:22:49 +00:00
parent 3d50bb27f2
commit 1f702fab15
15 changed files with 171 additions and 401 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/mztake/TODO.txt
View File

@ -2,16 +2,6 @@
- Automated tests
- Trace by function name
#|:::::::::LOAD/ANNOTATOR BUGS:::::::::::
* catch oops exception
* catch the other two exceptions that my loaders throw
* detect if the source code for a certain module is missing and throw an exception
* do I want to parameterize it over a given namespace?
* does this handle module prefixes?
* what happens if two modules have the same name in different directories
* MAKE SURE THERE WONT BE COLLISIONS WHEN EVAL'NG MODULES...GIVE THEM UNIQUE NAMES BASED ON PATH!
::::::::::::::::::::::::::::::::::::::::::
CHANGES TO MAKE-----------------------------------------------------------------------------
Ability to add named anchors into code using Special menu in DRS -- use those anchors as tracepoints.
@ -19,42 +9,15 @@ Demo monitoring DrScheme for Robby?
Bind Stop button to kill-all.
Test Suite for debugger annotator
Demo and docs for debugging multiple files, to make Robby happy. It is true that the docs are not very helpful on this count. It'd be nice if you could mock up a quick example of tracing something inside DrScheme....
On the whole, I like the tool, although it'd be nice to have either
(a) an interactive pointy-clicky interface rather than figuring
out line/column co-ordinates, or
(b) an AST-based description of the thing to be monitored (shades
of aspect-oriented programming).
Re-direct, or at least prefix, program output from the client so that it can be distinguished from the script
Paramterize print-struct to #f for printing in the script
DEMOS---------------------------------------------------------------------------------------
* Data structure examples
Binary search over a tree, show which node is being examined, or the most commonly taken path
Parse, graph the AST -- show OR and AND precedence getting messed up
* MST example
* something with multiple threads doing something and draw the threads in different colors in a window
OPTIMIZATIONS-------------------------------------------------------------------------------
* improve speed of lookup for line-col->pos; load them into a hashtable? not important since this is just startup time for the script.
* improve speed of load/annotate
* improve speed of functions in (run)
* Remove marks.ss from MzTake as soon as the new version of it becomes standard with releases.
ERROR-CHECKING/HANDLING---------------------------------------------------------------------
* Make all exposed cells and evstreams read-only by lifting the identity function on them

1
collects/mztake/annotator.ss
View File

@ -6,6 +6,7 @@
(lib "marks.ss" "mztake")
(lib "mred.ss" "mred")
(lib "pretty.ss")
(lib "base-gm.ss" "frtime")
(lib "load-sandbox.ss" "mztake")
(prefix srfi: (lib "search.ss" "srfi" "1"))
)

6
collects/mztake/demos/dijkstra/dijkstra-mztake.ss
View File

@ -37,9 +37,9 @@
"dijkstra-solver.ss"
(lib "match.ss"))
(define inserts (trace (loc "heap.ss" 49 6) item))
;(define removes (trace (loc "heap.ss" 67 10) result))
(define removes (trace (loc/r 66 22)))
(define inserts (trace (loc '(lib "heap.ss" "frtime") '(let* ((sorter _) _) _))
item))
(define removes (trace (loc/r '(dv:ref (t-data _) _))))
#| The following code
merely observes the insertions and removals

2
collects/mztake/demos/dijkstra/dijkstra-solver.ss
View File

@ -1,5 +1,5 @@
(module dijkstra-solver mzscheme
(require "heap.ss"
(require (lib "heap.ss" "frtime")
(lib "list.ss")
"graph.ss")

249
collects/mztake/demos/dijkstra/graph.ss
View File

@ -1,6 +1,8 @@
;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*-
(module graph mzscheme
(require (lib "more-useful-code.ss" "mztake"))
(require (lib "base-gm.ss" "frtime")
(lib "etc.ss")
(lib "list.ss"))
(provide make-graph
;; --- Constructors :
@ -49,36 +51,36 @@
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)))
(for-each (lambda (flag) (hash-put! flag-hash flag true)) flags)
(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))
@ -87,7 +89,7 @@
(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))
@ -98,7 +100,7 @@
(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
@ -115,17 +117,17 @@
(define (graph-has-flag? graph flag)
(hash-mem? (t-flags graph) flag))
(define (graph-directed? graph)
(hash-mem? (t-flags graph) 'directed))
;;; =====================================================================
;;; Nodes
;;; =====================================================================
;;; 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)]
@ -133,7 +135,7 @@
(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.
@ -149,43 +151,38 @@
(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)))
(for-each (lambda (i) (graph-edge-remove! graph node i))
(hash-keys (hash-get (t-successors graph) node)))
(if (graph-directed? graph)
(for-each-f (hash-get (t-predessessors graph) node)
(lambda (i) (graph-edge-remove! graph i node))))
(for-each (lambda (i) (graph-edge-remove! graph i node))
(hash-keys (hash-get (t-predessessors graph) 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))
(for-each
(lambda (pred)
(for-each-f
(hash-get (t-successors graph) node)
(for-each
(lambda (succ)
(unless (or (and (not is-directed) (eq? pred succ))
(graph-edge-mem? graph pred succ))
@ -197,21 +194,26 @@
(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))))))))))
(hash-put! (hash-get (t-successors graph) succ) pred new-label))))))
(hash-keys (hash-get (t-successors graph) node))))
(hash-keys (hash-get
(if is-directed (t-predessessors graph) (t-successors graph))
node))))
(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)))
@ -221,34 +223,34 @@
(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))
(for-each (hash-keys (hash-get (t-successors graph) node))
(lambda (succ) (fn node succ)))
(when (graph-directed? graph)
(for-each (lambda (pred) (fn pred node))
(hash-get (t-predessessors graph) node))))
(for-each (hash-keys (hash-get (t-predessessors graph) node))
(lambda (pred) (fn pred node)))))
(define (graph-for-each-node graph fn)
(for-each-f (t-nodes graph) fn))
(for-each fn (hash-keys (t-nodes graph))))
(define (graph-fold-nodes graph init fn)
(let ((acc init))
(graph-for-each-node
graph
(lambda (node) (set! acc (fn node acc))))
acc))
;;; =====================================================================
;;; Edges
;;; =====================================================================
;;; 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.
@ -260,18 +262,18 @@
(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)
@ -279,66 +281,66 @@
(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))))))
(for-each (lambda (to) (fn from to))
(hash-keys (hash-get (t-successors graph) from))))))
(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
;;; =====================================================================
;;; 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)))
(for-each (lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward))
(if backward
(hash-keys (hash-get (t-predessessors graph) node))
(hash-keys (hash-get (t-successors graph) node))))
(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))]
@ -346,8 +348,8 @@
(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
@ -356,18 +358,18 @@
(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)))))))
(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
@ -377,12 +379,11 @@
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
(for-each
(lambda (n)
(if (not (hash-mem? dealt-with n))
(let ((super-node (graph-make-node! component-graph empty)))
@ -392,24 +393,25 @@
(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)))))
true))))
finish-times)
(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
;;; =====================================================================
;;; Utils
(define graph-to-list
(case-lambda
[(graph) (graph-to-list graph false)]
@ -437,20 +439,17 @@
(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
;;; =====================================================================
;;; 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)
@ -470,8 +469,8 @@
(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)))
(print-each (graph-to-list graph true))
(graph-for-each-edge graph (lambda (a b) (print-each "A " a b)))
(graph-dfs-from-node graph 'a (lambda (i) (display i)))
(newline)
@ -490,7 +489,7 @@
(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)))
(print-each "collapsed:" (graph-to-list star)))
(let ((strong-graph (make-graph 'directed)))
@ -508,17 +507,17 @@
(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))
(print-each "strong-graph" strong-graph)
(print-each "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)))))
(print-each "strong-components" components)
(print-each "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)
@ -526,18 +525,18 @@
(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)
(print-each "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)))
(print-each "u-graph" u-graph)
(print-each "component" (graph-components u-graph)))
)
;(graph-test)
)

2
collects/mztake/demos/dijkstra/heap-speed-mztake.ss
View File

@ -1,5 +1,5 @@
(require (lib "mztake.ss" "mztake"))
(set-main! "heap.ss")
(set-main! '(lib "heap.ss" "frtime"))
(define start (current-milliseconds))
(set-running! #t)

162
collects/mztake/demos/dijkstra/heap.ss
View File

@ -1,162 +0,0 @@
(module heap mzscheme
(require (lib "etc.ss")
"dv.ss")
(provide make-heap heap-empty? heap-size heap-insert heap-pop
heap-peak heap-remove heap-find
heap-contains heap-resort)
(define-struct t (sorter equality data))
;; sorter: elements which have the most trueness according to
;; the sorter pop out first
(define (make-heap sorter equality)
(let ((data (dv:make 5)))
(dv:append data 0)
(make-t sorter equality data)))
(define (heap-size heap)
(- (dv:length (t-data heap)) 1))
(define (heap-empty? heap)
(= (heap-size heap) 0))
(define (heap-last heap)
(- (dv:length (t-data heap)) 1))
(define (heap-parent i)
(floor (/ i 2)))
(define (heap-left i) (* i 2))
(define (heap-right i) (+ 1 (* i 2)))
(define (heap-has-right heap i)
(<= (heap-right i) (heap-last heap)))
(define (heap-has-left heap i)
(<= (heap-left i) (heap-last heap)))
(define (heap-insert heap item)
(let* ((sorter (t-sorter heap))
(data (t-data heap)))
(dv:append data item)
(let ((d (let loop ((prev (heap-last heap))
(current (heap-parent (heap-last heap))))
(cond ((= current 0) prev)
((sorter item (dv:ref data current))
(dv:set! data prev (dv:ref data current))
(loop current (heap-parent current)))
(#t prev)))))
(dv:set! data d item))))
(define (heap-peak heap)
(if (= (heap-size heap) 0) (error "heap-peak: empty")
(dv:ref (t-data heap) 1)))
(define (heap-pop heap)
(if (= (heap-size heap) 0) (error "heap-pop: empty")
(let ([result (dv:ref (t-data heap) 1)])
(heap-remove-pos heap 1)
result)))
(define (heap-remove-pos heap pos)
(let* ((data (t-data heap))
(sorter (t-sorter heap)))
(cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
((= pos (heap-last heap)) (dv:remove-last data))
(#t (let ((item (dv:ref data (heap-last heap))))
(dv:remove-last data)
(let loop ((current pos))
(dv:set! data current item)
(let* ((left (heap-left current))
(right (heap-right current))
(best-1 (if (and (heap-has-left heap current)
(sorter (dv:ref data left) item))
left current))
(best-2 (if (and (heap-has-right heap current)
(sorter (dv:ref data right)
(dv:ref data best-1)))
right best-1)))
(if (not (= best-2 current))
(begin (dv:set! data current (dv:ref data best-2))
(loop best-2))))))))))
;; return false if the object is not found
(define (heap-remove heap item)
(let ((pos (heap-find heap item)))
(if (not pos) false
(begin (heap-remove-pos heap pos) true))))
(define (heap-contains heap item)
(if (heap-find heap item) true false))
(define (heap-find heap item)
(let ((data (t-data heap))
(equality (t-equality heap))
(sorter (t-sorter heap)))
(let loop ((current 1))
(let ((current-item (dv:ref data current)))
(cond ((equality item current-item) current)
((sorter item current-item) #f)
(#t (or (and (heap-has-left heap current)
(not (sorter item (dv:ref data (heap-left current))))
(loop (heap-left current)))
(and (heap-has-right heap current)
(not (sorter item (dv:ref data (heap-right current))))
(loop (heap-right current))))))))))
(define (heap-resort heap item)
(heap-remove heap item)
(heap-insert heap item))
(define (test)
(define f (make-heap > eq?))
(define d (t-data f))
(heap-insert f 99)
;(debug "A " d)
(heap-remove-pos f 1)
;(debug "B " d)
(for-each (lambda (x) (heap-insert f x)) '(1 2 3 4 5 6 7 8 9 10 11 12 13 14))
;(debug "C " d)
(heap-remove f 10) ;(debug " " d)
(heap-remove f 5) ;(debug " " d)
(heap-remove f 8) ;(debug " " d)
(heap-remove f 13) ;(debug " " d)
;(debug (heap-contains f 11))
;(debug (heap-contains f 123))
(heap-pop f)
(heap-pop f)
(heap-pop f)
(heap-pop f) ;(debug " " d)
;(debug (heap-contains f 11))
;(debug (heap-contains f 4))
;(debug (heap-tostring f))
(heap-remove f 2)
;(debug (heap-tostring f))
(heap-remove f 3)
;(debug (heap-tostring f))
)
(define (test-speed)
(let loop ([count 3000])
(when (> count 0)
(test)
(loop (sub1 count)))))
; (time (test-speed))
)

2
collects/mztake/demos/random/random-mztake.ss
View File

@ -3,7 +3,7 @@
(lib "useful-code.ss" "mztake")
(as-is mzscheme assoc))
(define/bind (loc "random.ss" 4 6) x)
(define/bind (loc "random.ss" '(loop _)) x)
(define (assoc-inc l x)
(let ([filtered (filter (lambda (y) (not (eq? x (first y)))) l)]

3
collects/mztake/demos/sine/sine-mztake.ss
View File

@ -2,8 +2,7 @@
(lib "useful-code.ss" "mztake"))
(require (lib "mztake.ss" "mztake"))
;(define/bind (loc "sine.ss" 5 ) x sin-x)
(define/bind (loc "sine.ss" '(if _ ...) ) x sin-x)
(define/bind (loc "sine.ss" '(if _) ) x sin-x)
(define (pick-cute-color x y)
(if (< 200 y)

2
collects/mztake/demos/sprofiler/sprofiler-mztake.ss
View File

@ -1,6 +1,6 @@
(require (lib "mztake.ss" "mztake" )
(lib "match.ss")
(lib "more-useful-code.ss" "mztake"))
(lib "base-gm.ss" "frtime"))
(set-main! "picture.ss")

21
collects/mztake/doc.txt
View File

@ -26,14 +26,14 @@ behavior of the program "highway-mztake.ss", in the demos directory of
the MzTake collection:
(require (lib "mztake.ss" "mztake"))
(define/bind (loc "highway.ss" 3) speed)
(define/bind (loc "highway.ss" 4) speed)
(printf-b "current speed: ~a" speed)
;; more code
(set-running! true)
This code executes a target module in the file "highway.ss"
after installing a _trace point_ (also known as a _watch
point_) just before the Scheme expression on the third line
point_) just before the Scheme expression on the fourth line
of "highway.ss". SPEED is a FrTime behavior that always
contains the *current* value of the variable named SPEED in
the target program.
@ -167,8 +167,23 @@ _Installing Trace Points_
datum. For instance, to install a trace point on the tenth line of
the MzLib's list library, use:
(trace (loc '(lib "list.ss") 10) ...)
(trace (loc '(lib "list.ss") 10) <body> )
> (loc require-spec pattern)
The LOC function can also accept a pattern. MzTake will scan the
text of the target source file and install a breakpoint at every
location where the text matches the pattern. The pattern language
is very simple. Every symbol in the pattern is taken literally,
with the exception of the underscore. In a pattern, and underscore
stand for zero, one, or many items. Unlike the patterns used by
match.ss, MzTake does not make use of an ellipsis to indicate
repetition. The repetition is always implicit. The following
expression inserts a tracepoint on every lambda expression that has
exactly one argument, called "l" :
(trace (loc '(lib "list.ss") '(lambda (l) _)) <body> )
> (trace loc body ...)
Install a trace point at the location indicated by the LOC value.

27
collects/mztake/engine.ss
View File

@ -2,11 +2,12 @@
(require "marks.ss"
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(prefix frp: (lib "lang-ext.ss" "frtime"))
(rename (lib "frp-core.ss" "frtime")
frp:signal-thunk signal-thunk)
"useful-code.ss"
"more-useful-code.ss" ; mostly for hash- bindings
(lib "base-gm.ss" "frtime")
"mztake-structs.ss"
"load-sandbox.ss"
"annotator.ss"
@ -71,13 +72,13 @@
(define (pattern->pos stx-lst)
(define (quote-symbols lst)
(cond
[(empty? lst) empty]
[(eq? lst '_) lst]
[(eq? lst '...) lst]
[(symbol? lst) `(quote ,lst)]
[else (cons (quote-symbols (first lst))
(quote-symbols (rest lst)))]))
(match lst
[(? symbol? s) `(quote ,s)]
[() empty]
[('_ tl ...) `(_ ... ,@(quote-symbols tl))]
[(hd tl ...) (cons (quote-symbols hd)
(quote-symbols tl))]
[item item]))
(define (collect-locations h stx lst)
(let loop ([stx stx] [lst lst])
@ -271,6 +272,11 @@
;; annotate-module?
(lambda (filename module-name)
#;(print-each "annotate-module?"
filename
(process-has-file? process filename)
(policy-requests-annotatation? (debug-process-policy process) filename))
(or (process-has-file? process filename)
(policy-requests-annotatation? (debug-process-policy process) filename)))
@ -278,7 +284,10 @@
(lambda (stx)
(if (not (syntax-source stx))
stx
(let*-values ([(client) (find-client/create process (path->string (syntax-source stx)))]
(let*-values ([(client)
(find-client/create
process
(path->string (syntax-source stx)))]
[(annotated-stx pos-list)
(annotate-for-single-stepping
stx

54
collects/mztake/more-useful-code.ss
View File

@ -1,54 +0,0 @@
(module more-useful-code mzscheme
(require (lib "list.ss")
(lib "etc.ss"))
(provide make-hash
hash?
hash-get
hash-put!
hash-remove!
hash-map
hash-for-each
hash-size/slow
hash-mem?
hash-fold
hash-filter!
hash-keys
hash-values
hash-pairs
hash-add-all!
hash-get-or-define!)
(define make-hash make-hash-table)
(define hash? hash-table?)
(define hash-get hash-table-get)
(define hash-put! hash-table-put!)
(define hash-remove! hash-table-remove!)
(define hash-map hash-table-map)
(define hash-for-each hash-table-for-each)
(define (hash-empty? hash)(let/ec k (hash-for-each hash (lambda (k v) (k false))) true))
(define (hash-size/slow hash) (hash-fold hash 0 (lambda (key val acc) (+ acc 1))))
(define (hash-mem? hash item) (let/ec k (begin (hash-get hash item (lambda () (k false))) true)))
(define (hash-fold hash init fn)
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
(define (hash-filter! hash predicate)
(hash-for-each
hash (lambda (key val) (if (not (predicate key val))
(hash-remove! hash key)))))
(define (hash-keys hash)
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
(define (hash-values hash)
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
(define (hash-pairs hash)
(hash-fold hash empty (lambda (key val acc) (cons (list key val) acc))))
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
(hash-for-each from-hash
(lambda (key val) (hash-put! to-hash key val))))
(define (hash-get-or-define! hash key val-fn)
(if (not (hash-mem? hash key))
(begin (let ((v (val-fn)))
(hash-put! hash key v)
v))
(hash-get hash key))))

2
collects/mztake/mztake-structs.ss
View File

@ -1,7 +1,7 @@
(module mztake-structs mzscheme
(require (lib "match.ss")
(lib "etc.ss")
(lib "more-useful-code.ss" "mztake"))
(lib "base-gm.ss" "frtime"))
(provide (all-defined))

2
collects/mztake/mztake.ss
View File

@ -6,7 +6,7 @@
(rename (lib "frtime.ss" "frtime") frp:value-nowable? value-nowable?)
(rename (lib "frtime.ss" "frtime") frp:behaviorof behaviorof)
"mztake-structs.ss"
"more-useful-code.ss"
(lib "base-gm.ss" "frtime")
(lib "etc.ss")
(lib "list.ss")
"marks.ss"