From 1f702fab15e85a89f7261a8a514b7b63467ef765 Mon Sep 17 00:00:00 2001 From: Guillaume Marceau Date: Tue, 4 Apr 2006 23:22:49 +0000 Subject: [PATCH] cleaned up and fixed base-gm.ss in frtime and mztake svn: r2596 --- collects/mztake/TODO.txt | 37 --- collects/mztake/annotator.ss | 1 + .../mztake/demos/dijkstra/dijkstra-mztake.ss | 6 +- .../mztake/demos/dijkstra/dijkstra-solver.ss | 2 +- collects/mztake/demos/dijkstra/graph.ss | 249 +++++++++--------- .../demos/dijkstra/heap-speed-mztake.ss | 2 +- collects/mztake/demos/dijkstra/heap.ss | 162 ------------ collects/mztake/demos/random/random-mztake.ss | 2 +- collects/mztake/demos/sine/sine-mztake.ss | 3 +- .../demos/sprofiler/sprofiler-mztake.ss | 2 +- collects/mztake/doc.txt | 21 +- collects/mztake/engine.ss | 27 +- collects/mztake/more-useful-code.ss | 54 ---- collects/mztake/mztake-structs.ss | 2 +- collects/mztake/mztake.ss | 2 +- 15 files changed, 171 insertions(+), 401 deletions(-) delete mode 100644 collects/mztake/demos/dijkstra/heap.ss delete mode 100644 collects/mztake/more-useful-code.ss diff --git a/collects/mztake/TODO.txt b/collects/mztake/TODO.txt index f7e16cc002..7c65107e91 100644 --- a/collects/mztake/TODO.txt +++ b/collects/mztake/TODO.txt @@ -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 diff --git a/collects/mztake/annotator.ss b/collects/mztake/annotator.ss index eeecafcfe3..6efd036108 100644 --- a/collects/mztake/annotator.ss +++ b/collects/mztake/annotator.ss @@ -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")) ) diff --git a/collects/mztake/demos/dijkstra/dijkstra-mztake.ss b/collects/mztake/demos/dijkstra/dijkstra-mztake.ss index 9b5b427eb2..c26fb55945 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-mztake.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-mztake.ss @@ -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 diff --git a/collects/mztake/demos/dijkstra/dijkstra-solver.ss b/collects/mztake/demos/dijkstra/dijkstra-solver.ss index 1f0aabebdc..636198033d 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-solver.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-solver.ss @@ -1,5 +1,5 @@ (module dijkstra-solver mzscheme - (require "heap.ss" + (require (lib "heap.ss" "frtime") (lib "list.ss") "graph.ss") diff --git a/collects/mztake/demos/dijkstra/graph.ss b/collects/mztake/demos/dijkstra/graph.ss index 9616713b45..6802352db1 100644 --- a/collects/mztake/demos/dijkstra/graph.ss +++ b/collects/mztake/demos/dijkstra/graph.ss @@ -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) ) - + diff --git a/collects/mztake/demos/dijkstra/heap-speed-mztake.ss b/collects/mztake/demos/dijkstra/heap-speed-mztake.ss index fe0c44639d..9284ed10df 100644 --- a/collects/mztake/demos/dijkstra/heap-speed-mztake.ss +++ b/collects/mztake/demos/dijkstra/heap-speed-mztake.ss @@ -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) diff --git a/collects/mztake/demos/dijkstra/heap.ss b/collects/mztake/demos/dijkstra/heap.ss deleted file mode 100644 index 89fea19f45..0000000000 --- a/collects/mztake/demos/dijkstra/heap.ss +++ /dev/null @@ -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)) - - ) - diff --git a/collects/mztake/demos/random/random-mztake.ss b/collects/mztake/demos/random/random-mztake.ss index 7c4553c2cb..e0b773a969 100644 --- a/collects/mztake/demos/random/random-mztake.ss +++ b/collects/mztake/demos/random/random-mztake.ss @@ -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)] diff --git a/collects/mztake/demos/sine/sine-mztake.ss b/collects/mztake/demos/sine/sine-mztake.ss index dc94bd1a9e..00b70e6ff1 100644 --- a/collects/mztake/demos/sine/sine-mztake.ss +++ b/collects/mztake/demos/sine/sine-mztake.ss @@ -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) diff --git a/collects/mztake/demos/sprofiler/sprofiler-mztake.ss b/collects/mztake/demos/sprofiler/sprofiler-mztake.ss index 9407f934a7..9de1e4c979 100644 --- a/collects/mztake/demos/sprofiler/sprofiler-mztake.ss +++ b/collects/mztake/demos/sprofiler/sprofiler-mztake.ss @@ -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") diff --git a/collects/mztake/doc.txt b/collects/mztake/doc.txt index 4dd895f779..0b617774b9 100644 --- a/collects/mztake/doc.txt +++ b/collects/mztake/doc.txt @@ -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) ) +> (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) _)) ) + > (trace loc body ...) Install a trace point at the location indicated by the LOC value. diff --git a/collects/mztake/engine.ss b/collects/mztake/engine.ss index d703bd40ef..bc200b3b51 100644 --- a/collects/mztake/engine.ss +++ b/collects/mztake/engine.ss @@ -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 diff --git a/collects/mztake/more-useful-code.ss b/collects/mztake/more-useful-code.ss deleted file mode 100644 index 428d84828e..0000000000 --- a/collects/mztake/more-useful-code.ss +++ /dev/null @@ -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)))) diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index c0fc4ae21d..413e6111b0 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -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)) diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 3bfed60c86..68d26560cb 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -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"