From cfce6631b36f95a97153a644ba2da6c33ba02c78 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 16 Jun 2005 00:22:41 +0000 Subject: [PATCH] props etc svn: r187 --- .../dijkstra/dijkstra-mztake-uncommented.ss | 78 +- .../mztake/demos/dijkstra/dijkstra-mztake.ss | 168 +- .../mztake/demos/dijkstra/dijkstra-solver.ss | 98 +- collects/mztake/demos/dijkstra/dijkstra.ss | 62 +- collects/mztake/demos/dijkstra/graph.ss | 1086 ++++++------ collects/mztake/demos/dijkstra/heap.ss | 324 ++-- .../exception/exception-mztake-uncommented.ss | 12 +- .../demos/exception/exception-mztake.ss | 30 +- collects/mztake/demos/exception/exception.ss | 2 +- .../first-class-mztake-uncommented.ss | 28 +- .../demos/first-class/first-class-mztake.ss | 54 +- .../mztake/demos/first-class/first-class.ss | 10 +- .../highway/highway-mztake-uncommented.ss | 56 +- .../mztake/demos/highway/highway-mztake.ss | 108 +- collects/mztake/demos/highway/highway.ss | 8 +- .../montecarlo-mztake-uncommented.ss | 50 +- .../demos/montecarlo/montecarlo-mztake.ss | 142 +- .../mztake/demos/montecarlo/montecarlo.ss | 28 +- .../demos/random/random-mztake-uncommented.ss | 86 +- collects/mztake/demos/random/random-mztake.ss | 212 +-- collects/mztake/demos/random/random.ss | 8 +- collects/mztake/demos/sine/sine-mztake.ss | 124 +- collects/mztake/demos/sine/sine.ss | 14 +- collects/mztake/doc.txt | 1462 ++++++++--------- collects/mztake/info.ss | 14 +- collects/mztake/make-clean.bat | 2 +- collects/mztake/make-plt.ss | 40 +- collects/mztake/make.bat | 0 collects/mztake/mztake-lang.ss | 282 ++-- collects/mztake/mztake-structs.ss | 140 +- collects/mztake/private/load-annotator.ss | 214 +-- collects/mztake/private/more-useful-code.ss | 584 +++---- collects/mztake/private/useful-code.ss | 130 +- 33 files changed, 2828 insertions(+), 2828 deletions(-) mode change 100644 => 100755 collects/mztake/make-clean.bat mode change 100644 => 100755 collects/mztake/make.bat diff --git a/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss b/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss index 2cf4183a27..ad576e22f6 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-mztake-uncommented.ss @@ -1,40 +1,40 @@ -(require (lib "mztake.ss" "mztake") - "dijkstra-solver.ss" - (lib "match.ss")) - -(define/bind (loc "heap.ss" 49 6) item) -(define/bind (loc "heap.ss" 67 10) result) - -(define (not-in-order e) - (filter-e - (match-lambda - [('reset _) false] - [(_ 'reset) false] - [(previous current) (> previous current)] - [else false]) - (history-e 2 e))) - - -(define inserts-and-removes-e (merge-e (removes . ==> . node-weight) - (inserts . -=> . 'reset))) -(define violations (not-in-order inserts-and-removes-e)) - - -(printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e)) -(printf-b "all violations: ~a" (history-b violations)) -(printf-b "latest-violation: ~a" (hold violations)) - - -#| Implementation of the local model follows... |# -(define ((insert-in-model item) model) - (printf "~nInserting ~a into model containing:~n~a~n" item (value-now model)) - (cons item model)) - -(define ((remove-from-model item) model) - (printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model)) - (filter (lambda (i) (not (equal? i item))) model)) - -(define inserters (accum-b (inserts . ==> . insert-in-model) empty)) -(define removers (accum-b (removes . ==> . remove-from-model) inserters)) - +(require (lib "mztake.ss" "mztake") + "dijkstra-solver.ss" + (lib "match.ss")) + +(define/bind (loc "heap.ss" 49 6) item) +(define/bind (loc "heap.ss" 67 10) result) + +(define (not-in-order e) + (filter-e + (match-lambda + [('reset _) false] + [(_ 'reset) false] + [(previous current) (> previous current)] + [else false]) + (history-e 2 e))) + + +(define inserts-and-removes-e (merge-e (removes . ==> . node-weight) + (inserts . -=> . 'reset))) +(define violations (not-in-order inserts-and-removes-e)) + + +(printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e)) +(printf-b "all violations: ~a" (history-b violations)) +(printf-b "latest-violation: ~a" (hold violations)) + + +#| Implementation of the local model follows... |# +(define ((insert-in-model item) model) + (printf "~nInserting ~a into model containing:~n~a~n" item (value-now model)) + (cons item model)) + +(define ((remove-from-model item) model) + (printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model)) + (filter (lambda (i) (not (equal? i item))) model)) + +(define inserters (accum-b (inserts . ==> . insert-in-model) empty)) +(define removers (accum-b (removes . ==> . remove-from-model) inserters)) + (set-running-e! (violations . -=> . false)) \ No newline at end of file diff --git a/collects/mztake/demos/dijkstra/dijkstra-mztake.ss b/collects/mztake/demos/dijkstra/dijkstra-mztake.ss index 3d72f77241..e44da55202 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-mztake.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-mztake.ss @@ -1,84 +1,84 @@ -#| This script tests a priority queue (heap) that is correctly implemented, but incorrectly used. - It is not commented because it uses a some advanced FrTime concepts that can easily be looked - up in the help desk, and both the description and motivation of the example can be found in - "A Dataflow Language for Scriptable Debugging" (Marceau, Cooper, Krishnamurthi, Reiss), - available at: - - http://www.cs.brown.edu/~sk/Publications/Papers/Published/mckr-dataflow-lang-script-debug/ - - This script uses the concept of maintaining a local model of the heap being debugged, as a simple, - and very slow, list. The difference is that a fancy heap used can be naively implemented as a list, - simply removing only the smallest element each time. Models are external to your program, you don't - have to add any test code to your program to use them. By adding and removing the items to our local - "model" (the values come from the heap code we used), we can compare the results and assert whether - it is working correctly or not. Our model shows the values we should be getting from the program, - but clearly are not. - - To provide some context for this demo, and what debugging problem MzTake helps us explore, I offer - the following, out of context, taken directly from the paper: - We find that the queue's elements are not in sorted order while those in the model - are. More revealingly, the queue's elements are not the same as those in the model. - A little further study shows that the bug is in our usage of the priority queue: - we have failed to account for the fact that the assignment to dest.weight - in relax (figure 1) updates the weights of nodes already in the queue. Because - the queue is not sensitive to these updates, what it returns is no longer the - smallest element in the queue. - - On further reading, we trace the error to a subtle detail in the description of - Dijkstra's algorithm in Cormen, et al.'s book [9, page 530]. The book permits - the use of a binary heap (which is how we implemented the priority queue) for - sparse graphs, but subsequently amends the pseudocode to say that the assignment - to dest.weight must explicitly invoke a key-decrement operation. Our error, - therefore, was not in the implementation of the heap, but in using the (faster) - binary heap implementation without satisfying its (stronger) contract. |# - -(require "dijkstra-solver.ss" - (lib "match.ss")) - -(define-mztake-process p - ("dijkstra.ss") - ("heap.ss" [inserts 49 6 bind 'item] - [removes 67 10 bind 'result])) - -#| The following code merely observes the insertions and removals - from the heap. We notice whether any of the removals are out - of order based on the last item removed, as long as there are - no insertions between the two events. We can keep track of the - last 2 using history-e. |# - -(define (not-in-order e) - (filter-e - (match-lambda - [('reset _) false] - [(_ 'reset) false] - [(previous current) (> previous current)] - [else false]) - (history-e 2 e))) - - -(define inserts-and-removes-e (merge-e (removes . ==> . node-weight) - (inserts . -=> . 'reset))) -(define violations (not-in-order inserts-and-removes-e)) - - -(printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e)) -(printf-b "all violations: ~a" (history-b violations)) -(printf-b "latest-violation: ~a" (hold violations)) -#| This output indicates that the queue has yielded nodes whose weights are out of order. - This confirms our suspicion that the problem somehow involves the priority queue. |# - - - -#| Implementation of the local model follows... |# -(define ((insert-in-model item) model) - (printf "~nInserting ~a into model containing:~n~a~n" item (value-now model)) - (cons item model)) - -(define ((remove-from-model item) model) - (printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model)) - (filter (lambda (i) (not (equal? i item))) model)) - -(define inserters (accum-b (inserts . ==> . insert-in-model) empty)) -(define removers (accum-b (removes . ==> . remove-from-model) inserters)) - -(start/resume p) +#| This script tests a priority queue (heap) that is correctly implemented, but incorrectly used. + It is not commented because it uses a some advanced FrTime concepts that can easily be looked + up in the help desk, and both the description and motivation of the example can be found in + "A Dataflow Language for Scriptable Debugging" (Marceau, Cooper, Krishnamurthi, Reiss), + available at: + + http://www.cs.brown.edu/~sk/Publications/Papers/Published/mckr-dataflow-lang-script-debug/ + + This script uses the concept of maintaining a local model of the heap being debugged, as a simple, + and very slow, list. The difference is that a fancy heap used can be naively implemented as a list, + simply removing only the smallest element each time. Models are external to your program, you don't + have to add any test code to your program to use them. By adding and removing the items to our local + "model" (the values come from the heap code we used), we can compare the results and assert whether + it is working correctly or not. Our model shows the values we should be getting from the program, + but clearly are not. + + To provide some context for this demo, and what debugging problem MzTake helps us explore, I offer + the following, out of context, taken directly from the paper: + We find that the queue's elements are not in sorted order while those in the model + are. More revealingly, the queue's elements are not the same as those in the model. + A little further study shows that the bug is in our usage of the priority queue: + we have failed to account for the fact that the assignment to dest.weight + in relax (figure 1) updates the weights of nodes already in the queue. Because + the queue is not sensitive to these updates, what it returns is no longer the + smallest element in the queue. + + On further reading, we trace the error to a subtle detail in the description of + Dijkstra's algorithm in Cormen, et al.'s book [9, page 530]. The book permits + the use of a binary heap (which is how we implemented the priority queue) for + sparse graphs, but subsequently amends the pseudocode to say that the assignment + to dest.weight must explicitly invoke a key-decrement operation. Our error, + therefore, was not in the implementation of the heap, but in using the (faster) + binary heap implementation without satisfying its (stronger) contract. |# + +(require "dijkstra-solver.ss" + (lib "match.ss")) + +(define-mztake-process p + ("dijkstra.ss") + ("heap.ss" [inserts 49 6 bind 'item] + [removes 67 10 bind 'result])) + +#| The following code merely observes the insertions and removals + from the heap. We notice whether any of the removals are out + of order based on the last item removed, as long as there are + no insertions between the two events. We can keep track of the + last 2 using history-e. |# + +(define (not-in-order e) + (filter-e + (match-lambda + [('reset _) false] + [(_ 'reset) false] + [(previous current) (> previous current)] + [else false]) + (history-e 2 e))) + + +(define inserts-and-removes-e (merge-e (removes . ==> . node-weight) + (inserts . -=> . 'reset))) +(define violations (not-in-order inserts-and-removes-e)) + + +(printf-b "all inserts and removes: ~a" (history-b inserts-and-removes-e)) +(printf-b "all violations: ~a" (history-b violations)) +(printf-b "latest-violation: ~a" (hold violations)) +#| This output indicates that the queue has yielded nodes whose weights are out of order. + This confirms our suspicion that the problem somehow involves the priority queue. |# + + + +#| Implementation of the local model follows... |# +(define ((insert-in-model item) model) + (printf "~nInserting ~a into model containing:~n~a~n" item (value-now model)) + (cons item model)) + +(define ((remove-from-model item) model) + (printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model)) + (filter (lambda (i) (not (equal? i item))) model)) + +(define inserters (accum-b (inserts . ==> . insert-in-model) empty)) +(define removers (accum-b (removes . ==> . remove-from-model) inserters)) + +(start/resume p) diff --git a/collects/mztake/demos/dijkstra/dijkstra-solver.ss b/collects/mztake/demos/dijkstra/dijkstra-solver.ss index 782e8260f7..1f0aabebdc 100644 --- a/collects/mztake/demos/dijkstra/dijkstra-solver.ss +++ b/collects/mztake/demos/dijkstra/dijkstra-solver.ss @@ -1,49 +1,49 @@ -(module dijkstra-solver mzscheme - (require "heap.ss" - (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)))) +(module dijkstra-solver mzscheme + (require "heap.ss" + (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)))) diff --git a/collects/mztake/demos/dijkstra/dijkstra.ss b/collects/mztake/demos/dijkstra/dijkstra.ss index 32fd8fe695..beb28515d7 100644 --- a/collects/mztake/demos/dijkstra/dijkstra.ss +++ b/collects/mztake/demos/dijkstra/dijkstra.ss @@ -1,32 +1,32 @@ -(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) - - (printf "~n~n---output from dijkstra.ss:~n~a~n---~n" +(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) + + (printf "~n~n---output from dijkstra.ss:~n~a~n---~n" (solve g (reverse nodes) (n-ref 's)))) \ No newline at end of file diff --git a/collects/mztake/demos/dijkstra/graph.ss b/collects/mztake/demos/dijkstra/graph.ss index da86dbf4c5..8d42b6a4be 100644 --- a/collects/mztake/demos/dijkstra/graph.ss +++ b/collects/mztake/demos/dijkstra/graph.ss @@ -1,543 +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) - ) - +;; -*- 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) + ) + diff --git a/collects/mztake/demos/dijkstra/heap.ss b/collects/mztake/demos/dijkstra/heap.ss index 4400962f63..0ed5efe363 100644 --- a/collects/mztake/demos/dijkstra/heap.ss +++ b/collects/mztake/demos/dijkstra/heap.ss @@ -1,162 +1,162 @@ -(module heap mzscheme - - (require (lib "etc.ss") - "base-gm.ss" - "dv.ss") - - - (provide make-heap heap-empty? heap-size heap-insert heap-pop - heap-peak heap-remove heap-find - heap-contains heap-resort heap-tostring) - - - - - (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 (heap-tostring heap . fns) - (let* ((data (t-data heap)) - (data-list (let loop ((i 1)) - (if (> i (heap-last heap)) empty - (cons (dv:ref data i) (loop (+ i 1))))))) - - (string-append "heap: sz " (number->string (heap-size heap)) ", " - (apply to-string (cons data-list fns))))) - - (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)) - ) - - ) - +(module heap mzscheme + + (require (lib "etc.ss") + "base-gm.ss" + "dv.ss") + + + (provide make-heap heap-empty? heap-size heap-insert heap-pop + heap-peak heap-remove heap-find + heap-contains heap-resort heap-tostring) + + + + + (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 (heap-tostring heap . fns) + (let* ((data (t-data heap)) + (data-list (let loop ((i 1)) + (if (> i (heap-last heap)) empty + (cons (dv:ref data i) (loop (+ i 1))))))) + + (string-append "heap: sz " (number->string (heap-size heap)) ", " + (apply to-string (cons data-list fns))))) + + (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)) + ) + + ) + diff --git a/collects/mztake/demos/exception/exception-mztake-uncommented.ss b/collects/mztake/demos/exception/exception-mztake-uncommented.ss index 1e8e42383b..c741712b36 100644 --- a/collects/mztake/demos/exception/exception-mztake-uncommented.ss +++ b/collects/mztake/demos/exception/exception-mztake-uncommented.ss @@ -1,7 +1,7 @@ -(set-main! "exception.ss") - -(printf-b "exception.ss exited? ~a" (process:exited?)) - -(printf-b "last exception seen: ~a" (hold (process:exceptions))) - +(set-main! "exception.ss") + +(printf-b "exception.ss exited? ~a" (process:exited?)) + +(printf-b "last exception seen: ~a" (hold (process:exceptions))) + (set-running! true) \ No newline at end of file diff --git a/collects/mztake/demos/exception/exception-mztake.ss b/collects/mztake/demos/exception/exception-mztake.ss index e83b7277dc..339b07254f 100644 --- a/collects/mztake/demos/exception/exception-mztake.ss +++ b/collects/mztake/demos/exception/exception-mztake.ss @@ -1,16 +1,16 @@ -#| This program starts a thread, the thread raises an exception, - this tests how MzTake catches exceptions, even if they come from - anonymous locations. - - We don't even need to bind any variables or add any breaks, we just - run the program and catch the exception it throws. |# - -(define-mztake-process p ("exception.ss")) - -(printf-b "exception.ss exited? ~a" (process:exited? p)) -#| Prints out a behavior that tells you whether the debug-process is still running... |# - -(printf-b "last exception seen: ~a" (hold (process:exceptions p))) -#| Prints out the last exception that the program threw |# - +#| This program starts a thread, the thread raises an exception, + this tests how MzTake catches exceptions, even if they come from + anonymous locations. + + We don't even need to bind any variables or add any breaks, we just + run the program and catch the exception it throws. |# + +(define-mztake-process p ("exception.ss")) + +(printf-b "exception.ss exited? ~a" (process:exited? p)) +#| Prints out a behavior that tells you whether the debug-process is still running... |# + +(printf-b "last exception seen: ~a" (hold (process:exceptions p))) +#| Prints out the last exception that the program threw |# + (start/resume p) \ No newline at end of file diff --git a/collects/mztake/demos/exception/exception.ss b/collects/mztake/demos/exception/exception.ss index 2c69f73e5d..8a42fe40a4 100644 --- a/collects/mztake/demos/exception/exception.ss +++ b/collects/mztake/demos/exception/exception.ss @@ -1,2 +1,2 @@ -(module exception mzscheme +(module exception mzscheme (thread (lambda () (raise 'exn:oops-made-a-mztake!)))) \ No newline at end of file diff --git a/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss b/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss index 9f8199e64d..2a6599ae0f 100644 --- a/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss +++ b/collects/mztake/demos/first-class/first-class-mztake-uncommented.ss @@ -1,15 +1,15 @@ -(define x-before-let (trace (loc "first-class.ss" 3 29) (bind (x) x))) -(define x-in-let (trace (loc "first-class.ss" 4 25) (bind (x) x))) -(define x-after-let (trace (loc "first-class.ss" 5 11) (bind (x) x))) - - -(printf-b "Number of times x updates, should be 12: ~a" - (count-b (merge-e x-before-let - x-in-let - x-after-let))) - -(printf-b "x before let, should be (2 4 6 7): ~a" (history-b 4 x-before-let)) -(printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let)) -(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) - +(define x-before-let (trace (loc "first-class.ss" 3 29) (bind (x) x))) +(define x-in-let (trace (loc "first-class.ss" 4 25) (bind (x) x))) +(define x-after-let (trace (loc "first-class.ss" 5 11) (bind (x) x))) + + +(printf-b "Number of times x updates, should be 12: ~a" + (count-b (merge-e x-before-let + x-in-let + x-after-let))) + +(printf-b "x before let, should be (2 4 6 7): ~a" (history-b 4 x-before-let)) +(printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let)) +(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) + (set-running! true) \ No newline at end of file diff --git a/collects/mztake/demos/first-class/first-class-mztake.ss b/collects/mztake/demos/first-class/first-class-mztake.ss index ad758287f4..f6245595a2 100644 --- a/collects/mztake/demos/first-class/first-class-mztake.ss +++ b/collects/mztake/demos/first-class/first-class-mztake.ss @@ -1,28 +1,28 @@ -#| This program demonstrates how you can add traces to first class, anonymous functions, - such as those passed to map, and the traces will still respond from anywhere - the code is executed. - - This test also shows how you can bind to the same variable at different locations, - and recieve different values, watching how an algorithm unfolds. - - Be sure you look at first-class.ss to see where the bindings are taken from, to get - and idea of why they recieve different values from the same "x". |# - -(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] - [x-in-let 4 25 bind 'x] - [x-after-let 5 11 bind 'x])) - -(printf-b "Number of times x updates, should be 12: ~a" - (count-b (merge-e x-before-let - x-in-let - x-after-let))) -#| merge-e takes multiple event streams and turns them into one event stream. - count-e then counts how many pings are recieved on all three streams, - in other words, how many times "x" updates in all the traces. |# - -(printf-b "x before let, should be (2 4 6 7): ~a" (history-b 4 x-before-let)) -(printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let)) -(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) -#| Prints out a FIFO list containing the last 4 values seen by each trace. |# - +#| This program demonstrates how you can add traces to first class, anonymous functions, + such as those passed to map, and the traces will still respond from anywhere + the code is executed. + + This test also shows how you can bind to the same variable at different locations, + and recieve different values, watching how an algorithm unfolds. + + Be sure you look at first-class.ss to see where the bindings are taken from, to get + and idea of why they recieve different values from the same "x". |# + +(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] + [x-in-let 4 25 bind 'x] + [x-after-let 5 11 bind 'x])) + +(printf-b "Number of times x updates, should be 12: ~a" + (count-b (merge-e x-before-let + x-in-let + x-after-let))) +#| merge-e takes multiple event streams and turns them into one event stream. + count-e then counts how many pings are recieved on all three streams, + in other words, how many times "x" updates in all the traces. |# + +(printf-b "x before let, should be (2 4 6 7): ~a" (history-b 4 x-before-let)) +(printf-b "x in let, should be (6 10 14 16): ~a" (history-b 4 x-in-let)) +(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let)) +#| Prints out a FIFO list containing the last 4 values seen by each trace. |# + (start/resume p) \ No newline at end of file diff --git a/collects/mztake/demos/first-class/first-class.ss b/collects/mztake/demos/first-class/first-class.ss index 7078f3f531..3146f48568 100644 --- a/collects/mztake/demos/first-class/first-class.ss +++ b/collects/mztake/demos/first-class/first-class.ss @@ -1,6 +1,6 @@ -(module first-class mzscheme - (map (lambda (x) - (let* ([x (* 2 (+ 1 x))] - [x (sub1 x)]) - x)) +(module first-class mzscheme + (map (lambda (x) + (let* ([x (* 2 (+ 1 x))] + [x (sub1 x)]) + x)) '(2 4 6 7))) \ No newline at end of file diff --git a/collects/mztake/demos/highway/highway-mztake-uncommented.ss b/collects/mztake/demos/highway/highway-mztake-uncommented.ss index 5e56cfaa39..31328125a9 100644 --- a/collects/mztake/demos/highway/highway-mztake-uncommented.ss +++ b/collects/mztake/demos/highway/highway-mztake-uncommented.ss @@ -1,28 +1,28 @@ -(require (lib "mztake.ss" "mztake") - (lib "animation.ss" "frtime")) - -(define/bind (loc "highway.ss" 3 4) speed) - -(printf-b "current speed: ~a" (hold values-of-speed)) -(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) - - -(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program))) - values-of-speed) - - -(define (make-speed-gauge speed) - (let ([center (make-posn 200 200)]) - (list (make-circle center 170 "black") - (make-circle center 160 "white") - (make-rect (make-posn 0 202) 1000 1000 "white") - (make-line (make-posn 30 201) (make-posn 370 201) "black") - (make-line center - (posn+ center (make-posn (- (* 150 (cos (/ speed 30)))) - (- (* 150 (sin (/ speed 30)))))) - "red")))) - - -(display-shapes (make-speed-gauge (hold values-of-speed))) - -(set-runnning! true) +(require (lib "mztake.ss" "mztake") + (lib "animation.ss" "frtime")) + +(define/bind (loc "highway.ss" 3 4) speed) + +(printf-b "current speed: ~a" (hold values-of-speed)) +(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) + + +(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program))) + values-of-speed) + + +(define (make-speed-gauge speed) + (let ([center (make-posn 200 200)]) + (list (make-circle center 170 "black") + (make-circle center 160 "white") + (make-rect (make-posn 0 202) 1000 1000 "white") + (make-line (make-posn 30 201) (make-posn 370 201) "black") + (make-line center + (posn+ center (make-posn (- (* 150 (cos (/ speed 30)))) + (- (* 150 (sin (/ speed 30)))))) + "red")))) + + +(display-shapes (make-speed-gauge (hold values-of-speed))) + +(set-runnning! true) diff --git a/collects/mztake/demos/highway/highway-mztake.ss b/collects/mztake/demos/highway/highway-mztake.ss index bd603e33e3..8f8d206c72 100644 --- a/collects/mztake/demos/highway/highway-mztake.ss +++ b/collects/mztake/demos/highway/highway-mztake.ss @@ -1,55 +1,55 @@ -#| The program being debugged (a module in "highway.ss") generates fake speed readings over and over. |# - -(require (lib "animation.ss" "frtime")) #| needed for display-shapes |# - - -(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) -#| * Create a process to debug highway.ss - - * Add a tracepoint at line 3, column 4; in the program, - this is right before the program sleeps for 1 second. - - * At this tracepoint, define "values-of-speed" to a FrTime eventstream that - recieves events containing the current value of the variable `speed', - which are sent every time the code at line 3, column 4, is reached. |# - - - -(printf-b "current speed: ~a" (hold values-of-speed)) -#| Prints the current speed being recorded |# - - - -(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) -#| prints a FIFO list of the last 10 speeds seen |# - -(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program))) - values-of-speed) -#| pauses the program for inspection when a speed is too fast |# - - - -#| produces a list of shapes to draw/animate, taking in a number for speed |# -(define (make-speed-gauge speed) - (let ([center (make-posn 200 200)]) - (list (make-circle center 170 "black") - (make-circle center 160 "white") - (make-rect (make-posn 0 202) 1000 1000 "white") - (make-line (make-posn 30 201) (make-posn 370 201) "black") - #| draws the the half-circle guage |# - - #| draws the red line for the current speed |# - (make-line center - (posn+ center (make-posn (- (* 150 (cos (/ speed 30)))) - (- (* 150 (sin (/ speed 30)))))) - "red")))) - - -(display-shapes (make-speed-gauge (hold values-of-speed))) -#| display-shapes takes a list of objects to draw. - (hold values-of-speed) keeps track of the current value of speed, - as seen on the eventstream, and that is passed to make-speed-guage, - which gets called every time values-of-speed gets a new speed. |# - - +#| The program being debugged (a module in "highway.ss") generates fake speed readings over and over. |# + +(require (lib "animation.ss" "frtime")) #| needed for display-shapes |# + + +(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed])) +#| * Create a process to debug highway.ss + + * Add a tracepoint at line 3, column 4; in the program, + this is right before the program sleeps for 1 second. + + * At this tracepoint, define "values-of-speed" to a FrTime eventstream that + recieves events containing the current value of the variable `speed', + which are sent every time the code at line 3, column 4, is reached. |# + + + +(printf-b "current speed: ~a" (hold values-of-speed)) +#| Prints the current speed being recorded |# + + + +(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) +#| prints a FIFO list of the last 10 speeds seen |# + +(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program))) + values-of-speed) +#| pauses the program for inspection when a speed is too fast |# + + + +#| produces a list of shapes to draw/animate, taking in a number for speed |# +(define (make-speed-gauge speed) + (let ([center (make-posn 200 200)]) + (list (make-circle center 170 "black") + (make-circle center 160 "white") + (make-rect (make-posn 0 202) 1000 1000 "white") + (make-line (make-posn 30 201) (make-posn 370 201) "black") + #| draws the the half-circle guage |# + + #| draws the red line for the current speed |# + (make-line center + (posn+ center (make-posn (- (* 150 (cos (/ speed 30)))) + (- (* 150 (sin (/ speed 30)))))) + "red")))) + + +(display-shapes (make-speed-gauge (hold values-of-speed))) +#| display-shapes takes a list of objects to draw. + (hold values-of-speed) keeps track of the current value of speed, + as seen on the eventstream, and that is passed to make-speed-guage, + which gets called every time values-of-speed gets a new speed. |# + + (start/resume radar-program) #| Start the process for highway.ss |# \ No newline at end of file diff --git a/collects/mztake/demos/highway/highway.ss b/collects/mztake/demos/highway/highway.ss index 7e5580a1f8..775bef0786 100644 --- a/collects/mztake/demos/highway/highway.ss +++ b/collects/mztake/demos/highway/highway.ss @@ -1,5 +1,5 @@ -(module highway mzscheme - (let loop ([speed 0]) - (sleep 1) - ;; Generate some fake speeds readings: +(module highway mzscheme + (let loop ([speed 0]) + (sleep 1) + ;; Generate some fake speeds readings: (loop (+ speed 4)))) \ No newline at end of file diff --git a/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss b/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss index e57b675b31..ef26854792 100644 --- a/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss +++ b/collects/mztake/demos/montecarlo/montecarlo-mztake-uncommented.ss @@ -1,25 +1,25 @@ -(require (lib "graphics.ss" "graphics") - (lib "match.ss")) - - -(open-graphics) -(define window (open-viewport "Debugger" 400 400)) - -(define/bind (loc "montecarlo.ss" 13 13) x y pi) - - -(printf-b "total points chosen: ~a" (count-b (changes x))) -(printf-b "current computed value of pi: ~a" current-pi) -(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653)))) - - -((draw-viewport window) "wheat") -((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black") -((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna") - - -(map-e (match-lambda [(x y) ((draw-solid-ellipse window) (make-posn x y) - 3 3 "black")]) - (changes (list x y))) - -(set-running! true) +(require (lib "graphics.ss" "graphics") + (lib "match.ss")) + + +(open-graphics) +(define window (open-viewport "Debugger" 400 400)) + +(define/bind (loc "montecarlo.ss" 13 13) x y pi) + + +(printf-b "total points chosen: ~a" (count-b (changes x))) +(printf-b "current computed value of pi: ~a" current-pi) +(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653)))) + + +((draw-viewport window) "wheat") +((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black") +((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna") + + +(map-e (match-lambda [(x y) ((draw-solid-ellipse window) (make-posn x y) + 3 3 "black")]) + (changes (list x y))) + +(set-running! true) diff --git a/collects/mztake/demos/montecarlo/montecarlo-mztake.ss b/collects/mztake/demos/montecarlo/montecarlo-mztake.ss index f455c7389b..5a8b4898f7 100644 --- a/collects/mztake/demos/montecarlo/montecarlo-mztake.ss +++ b/collects/mztake/demos/montecarlo/montecarlo-mztake.ss @@ -1,71 +1,71 @@ -#| The program being debugged (a module in the file "montecarlo.ss") runs - an infinite loop, binding "x" and "y" to a random number between - [-199,199], each iteration. - - This is supposed to represent throwing darts at a circular dartboard. - You keep a count of how many darts you have thrown, and a side count - for each time the dart is thrown within the circle. The ratio of - hits to total tries, multiplied by 4, approaches "pi" with some error, - usually closing in around 3.13. The target program does this computation - and binds it to the variable "pi". - - This MzTake script visualizes the process, drawing points (darts) - that "hit" the circle, a radius of 200 pixels from the center of - the window. |# - - -(require (lib "graphics.ss" "graphics")) - #| Needed for open-graphics, open-viewport, and draw-solid-ellipse |# - - -(open-graphics) -(define window (open-viewport "Debugger" 400 400)) -#| This file doesn't animate a list of objects since the number of - objects quickly reaches the thousands (slowing drawing time severly), - and the dots are stationary -- so we just keep drawing the circles at - the random coordinates that we get from the target program. - - See the doc for more information on this kind of drawing. |# - - -(define-mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 13 bind '(x y pi)])) -#| * Create a process to debug montecarlo.ss - - * Add a tracepoint at line 13, column 13; in the program, - this is right after the cond determined that the point *is* within - the radius of the circle, before starting the next iteration of the loop. - - * At this tracepoint, define "x/y/pi-trace" to a FrTime eventstream that - recieves events containing a list of the latest values of "x" "y" and "pi" - in a list, every time the code at line 13, column 18, is reached. |# - - -(define x/y/pi (hold x/y/pi-trace)) -#| The local, time-varying variable "x/y/pi" is now is a FrTime behavior that always - holds the current (latest) list of values from x/y/pi-trace. |# - - -(define x (+ 200 (first x/y/pi))) -(define y (+ 200 (second x/y/pi))) -(define current-pi (third x/y/pi)) -#| The local, time-varying variables "x" "y" and "current-pi" are bound to - their respective values in the list from x/y/pi. |# - - -(printf-b "total points chosen: ~a" (count-b (changes x))) -(printf-b "current computed value of pi: ~a" current-pi) -(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653)))) ;; the more negative, the better... - -((draw-viewport window) "wheat") -((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black") -((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna") -#| Draw the dartboard |# - -(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y)) - 3 3 "black")) - (changes (list x y))) -#| Every time the list (x y) changes (x and y get a new value), take this latest list value ("==>") - and pass it to a function which draws a circle at the x,y coordinates in the list. |# - - -(start/resume p) #| Start the process for montecarlo.ss |# +#| The program being debugged (a module in the file "montecarlo.ss") runs + an infinite loop, binding "x" and "y" to a random number between + [-199,199], each iteration. + + This is supposed to represent throwing darts at a circular dartboard. + You keep a count of how many darts you have thrown, and a side count + for each time the dart is thrown within the circle. The ratio of + hits to total tries, multiplied by 4, approaches "pi" with some error, + usually closing in around 3.13. The target program does this computation + and binds it to the variable "pi". + + This MzTake script visualizes the process, drawing points (darts) + that "hit" the circle, a radius of 200 pixels from the center of + the window. |# + + +(require (lib "graphics.ss" "graphics")) + #| Needed for open-graphics, open-viewport, and draw-solid-ellipse |# + + +(open-graphics) +(define window (open-viewport "Debugger" 400 400)) +#| This file doesn't animate a list of objects since the number of + objects quickly reaches the thousands (slowing drawing time severly), + and the dots are stationary -- so we just keep drawing the circles at + the random coordinates that we get from the target program. + + See the doc for more information on this kind of drawing. |# + + +(define-mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 13 bind '(x y pi)])) +#| * Create a process to debug montecarlo.ss + + * Add a tracepoint at line 13, column 13; in the program, + this is right after the cond determined that the point *is* within + the radius of the circle, before starting the next iteration of the loop. + + * At this tracepoint, define "x/y/pi-trace" to a FrTime eventstream that + recieves events containing a list of the latest values of "x" "y" and "pi" + in a list, every time the code at line 13, column 18, is reached. |# + + +(define x/y/pi (hold x/y/pi-trace)) +#| The local, time-varying variable "x/y/pi" is now is a FrTime behavior that always + holds the current (latest) list of values from x/y/pi-trace. |# + + +(define x (+ 200 (first x/y/pi))) +(define y (+ 200 (second x/y/pi))) +(define current-pi (third x/y/pi)) +#| The local, time-varying variables "x" "y" and "current-pi" are bound to + their respective values in the list from x/y/pi. |# + + +(printf-b "total points chosen: ~a" (count-b (changes x))) +(printf-b "current computed value of pi: ~a" current-pi) +(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653)))) ;; the more negative, the better... + +((draw-viewport window) "wheat") +((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black") +((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna") +#| Draw the dartboard |# + +(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y)) + 3 3 "black")) + (changes (list x y))) +#| Every time the list (x y) changes (x and y get a new value), take this latest list value ("==>") + and pass it to a function which draws a circle at the x,y coordinates in the list. |# + + +(start/resume p) #| Start the process for montecarlo.ss |# diff --git a/collects/mztake/demos/montecarlo/montecarlo.ss b/collects/mztake/demos/montecarlo/montecarlo.ss index b05444e0b1..5f7480afd6 100644 --- a/collects/mztake/demos/montecarlo/montecarlo.ss +++ b/collects/mztake/demos/montecarlo/montecarlo.ss @@ -1,15 +1,15 @@ -(module montecarlo mzscheme - ;; a seed specially chosen because it isn't terribly erratic when converging on pi - (random-seed 846259386) - - (define (run) - (let loop ([hits 1] - [total 1]) - (let* ([x (- (random 401) 200)] - [y (- (random 401) 200)] - [length (sqrt (+ (* x x) (* y y)))] - [pi (* 4. (/ hits total))]) - (cond [(length . < . 200) - (loop (add1 hits) (add1 total))] - [else (loop hits (add1 total))])))) +(module montecarlo mzscheme + ;; a seed specially chosen because it isn't terribly erratic when converging on pi + (random-seed 846259386) + + (define (run) + (let loop ([hits 1] + [total 1]) + (let* ([x (- (random 401) 200)] + [y (- (random 401) 200)] + [length (sqrt (+ (* x x) (* y y)))] + [pi (* 4. (/ hits total))]) + (cond [(length . < . 200) + (loop (add1 hits) (add1 total))] + [else (loop hits (add1 total))])))) (run)) \ No newline at end of file diff --git a/collects/mztake/demos/random/random-mztake-uncommented.ss b/collects/mztake/demos/random/random-mztake-uncommented.ss index ce27c303bc..333ef94702 100644 --- a/collects/mztake/demos/random/random-mztake-uncommented.ss +++ b/collects/mztake/demos/random/random-mztake-uncommented.ss @@ -1,44 +1,44 @@ -(require (lib "graphics.ss" "graphics") - (lib "mztake.ss" "mztake") - (lifted mzscheme - make-hash-table - hash-table-put! - hash-table-get)) - - -(open-graphics) -(define window (open-viewport "Debugger" 600 500)) -((draw-viewport window) (make-rgb 0.95 0.95 0.95)) - - -(define/bind (loc "random.ss" 4 6) x) - - -(define largest-bin 0) -(define valcount (make-hash-table)) - - -(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin))) - - -(map-e (lambda (x) - (let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))] - [color (/ new-cnt (add1 largest-bin))]) - - (when (= largest-bin 250) - (kill p)) - - (when (> new-cnt largest-bin) (set! largest-bin new-cnt)) - - (hash-table-put! valcount x new-cnt) - - ((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt))) - 6 10 ;; width height - (make-rgb 0 (* 0.75 color) color)))) - x-trace) - - -(printf-b "count: ~a" (count-b x-trace)) - - +(require (lib "graphics.ss" "graphics") + (lib "mztake.ss" "mztake") + (lifted mzscheme + make-hash-table + hash-table-put! + hash-table-get)) + + +(open-graphics) +(define window (open-viewport "Debugger" 600 500)) +((draw-viewport window) (make-rgb 0.95 0.95 0.95)) + + +(define/bind (loc "random.ss" 4 6) x) + + +(define largest-bin 0) +(define valcount (make-hash-table)) + + +(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin))) + + +(map-e (lambda (x) + (let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))] + [color (/ new-cnt (add1 largest-bin))]) + + (when (= largest-bin 250) + (kill p)) + + (when (> new-cnt largest-bin) (set! largest-bin new-cnt)) + + (hash-table-put! valcount x new-cnt) + + ((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt))) + 6 10 ;; width height + (make-rgb 0 (* 0.75 color) color)))) + x-trace) + + +(printf-b "count: ~a" (count-b x-trace)) + + (set-running! true) \ No newline at end of file diff --git a/collects/mztake/demos/random/random-mztake.ss b/collects/mztake/demos/random/random-mztake.ss index ec53fb2b9c..9f2195e715 100644 --- a/collects/mztake/demos/random/random-mztake.ss +++ b/collects/mztake/demos/random/random-mztake.ss @@ -1,107 +1,107 @@ -#| The program being debugged (a module in the file "random.ss") runs an infinite loop, - binding "x" to a random number between [0,100) each iteration. - - This MzTake script draws a histogram of the values of x seen over time, - in sync with the execution of "random.ss". This will run until one - bar reaches the top of the screen. - - This histogram provides three pieces of information: - * Each bar represents a bin, the height represents how many times - that "random" number was generated. - - * The brighter the blue, the faster that bin is growing compared - to the others. The darker, the slower. - - * You can see a history of speeds over time based on how the colors - change in each bin. - - Try looking for small groupings of bins where all are light, or all - are dark -- these represent small trends in the numbers. - - Look for tortoises that stay low and black, and hares which are very - active and bright. - - The bars drag a bit when moving upwards (the height goes up by 2, but - the redrawing of the latest color goes down 10 pixels) so that you can - spot vertical trends more easily. |# - - -(require (lib "graphics.ss" "graphics") - #| Needed for open-graphics, open-viewport, and draw-solid-ellipse |# - - (lifted mzscheme - make-hash-table - hash-table-put! - hash-table-get)) -#| "Lifted" is explained in FrTime's own documentation (plt/collects/frtime/doc.txt) - Quickly put, lifting extends the functions listed above so they can take FrTime time-varying - values (such as MzTake traces) as arguments. |# - - - -(open-graphics) -(define window (open-viewport "Debugger" 600 500)) -((draw-viewport window) (make-rgb 0.95 0.95 0.95)) -#| This file doesn't animate a list of objects since the number of - objects quickly reaches the thousands (slowing drawing time severly), - and they are stationary -- so we just keep drawing the circles at - their new heights based on the value in the hashtable. - - See the doc for more information on this kind of drawing. |# - - - -(define-mztake-process p ("random.ss" [x-trace 4 6 bind 'x])) -#| * Create a process to debug random.ss - - * Add a tracepoint at line 4, column 6; in the program, - this is right before the next iteration of the loop is called, - ->(loop (random 200)) - - * At this tracepoint, define "x-trace" to a FrTime eventstream that - recieves events containing the latest value of "x" seen, - every time the code at line 4, column 6, is reached. |# - -(define largest-bin 0) -(define valcount (make-hash-table)) -#| this will hold the counts for the histogram - x is the key, and the number of times x shows up is the value |# - - -(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin))) -#| Prints out the largest count every time we get a new x-trace event |# - - -(map-e (lambda (x) - (let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))] - [color (/ new-cnt (add1 largest-bin))]) - - (when (= largest-bin 250) - (kill p)) - ; when one of the bars reaches the top of the screen, kill the program. - - (when (> new-cnt largest-bin) (set! largest-bin new-cnt)) - ; keep track of the largest count - - (hash-table-put! valcount x new-cnt) - ;; increment the value in the hashtable, starting from 0 if none exists. - - ((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt))) - 6 10 ;; width height - (make-rgb 0 (* 0.75 color) color)))) - x-trace) -#| Every time x-trace gets a new value, take this latest value and pass it to a function - which increments the count in the hashtable, and draws a circle in the window at - (* x 6) pixels from the left, and the height is (2 * the latest count in the hashtable for that x), - making a color (MAKE-RGB) that is lighter based on how fast it is growing. -|# - - -(printf-b "count: ~a" (count-b x-trace)) -#| prints the count of how many events x-trace got, - aka how many values are in the histogram and on the screen. -|# - - -(start/resume p) +#| The program being debugged (a module in the file "random.ss") runs an infinite loop, + binding "x" to a random number between [0,100) each iteration. + + This MzTake script draws a histogram of the values of x seen over time, + in sync with the execution of "random.ss". This will run until one + bar reaches the top of the screen. + + This histogram provides three pieces of information: + * Each bar represents a bin, the height represents how many times + that "random" number was generated. + + * The brighter the blue, the faster that bin is growing compared + to the others. The darker, the slower. + + * You can see a history of speeds over time based on how the colors + change in each bin. + + Try looking for small groupings of bins where all are light, or all + are dark -- these represent small trends in the numbers. + + Look for tortoises that stay low and black, and hares which are very + active and bright. + + The bars drag a bit when moving upwards (the height goes up by 2, but + the redrawing of the latest color goes down 10 pixels) so that you can + spot vertical trends more easily. |# + + +(require (lib "graphics.ss" "graphics") + #| Needed for open-graphics, open-viewport, and draw-solid-ellipse |# + + (lifted mzscheme + make-hash-table + hash-table-put! + hash-table-get)) +#| "Lifted" is explained in FrTime's own documentation (plt/collects/frtime/doc.txt) + Quickly put, lifting extends the functions listed above so they can take FrTime time-varying + values (such as MzTake traces) as arguments. |# + + + +(open-graphics) +(define window (open-viewport "Debugger" 600 500)) +((draw-viewport window) (make-rgb 0.95 0.95 0.95)) +#| This file doesn't animate a list of objects since the number of + objects quickly reaches the thousands (slowing drawing time severly), + and they are stationary -- so we just keep drawing the circles at + their new heights based on the value in the hashtable. + + See the doc for more information on this kind of drawing. |# + + + +(define-mztake-process p ("random.ss" [x-trace 4 6 bind 'x])) +#| * Create a process to debug random.ss + + * Add a tracepoint at line 4, column 6; in the program, + this is right before the next iteration of the loop is called, + ->(loop (random 200)) + + * At this tracepoint, define "x-trace" to a FrTime eventstream that + recieves events containing the latest value of "x" seen, + every time the code at line 4, column 6, is reached. |# + +(define largest-bin 0) +(define valcount (make-hash-table)) +#| this will hold the counts for the histogram + x is the key, and the number of times x shows up is the value |# + + +(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin))) +#| Prints out the largest count every time we get a new x-trace event |# + + +(map-e (lambda (x) + (let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))] + [color (/ new-cnt (add1 largest-bin))]) + + (when (= largest-bin 250) + (kill p)) + ; when one of the bars reaches the top of the screen, kill the program. + + (when (> new-cnt largest-bin) (set! largest-bin new-cnt)) + ; keep track of the largest count + + (hash-table-put! valcount x new-cnt) + ;; increment the value in the hashtable, starting from 0 if none exists. + + ((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt))) + 6 10 ;; width height + (make-rgb 0 (* 0.75 color) color)))) + x-trace) +#| Every time x-trace gets a new value, take this latest value and pass it to a function + which increments the count in the hashtable, and draws a circle in the window at + (* x 6) pixels from the left, and the height is (2 * the latest count in the hashtable for that x), + making a color (MAKE-RGB) that is lighter based on how fast it is growing. +|# + + +(printf-b "count: ~a" (count-b x-trace)) +#| prints the count of how many events x-trace got, + aka how many values are in the histogram and on the screen. +|# + + +(start/resume p) ;; Start the process for random.ss \ No newline at end of file diff --git a/collects/mztake/demos/random/random.ss b/collects/mztake/demos/random/random.ss index 4db147f315..f61bacce7d 100644 --- a/collects/mztake/demos/random/random.ss +++ b/collects/mztake/demos/random/random.ss @@ -1,5 +1,5 @@ -(module random mzscheme - (define (run) - (let loop ([x (random 100)]) - (loop (random 100)))) +(module random mzscheme + (define (run) + (let loop ([x (random 100)]) + (loop (random 100)))) (run)) \ No newline at end of file diff --git a/collects/mztake/demos/sine/sine-mztake.ss b/collects/mztake/demos/sine/sine-mztake.ss index 3e9677992b..772ef5d17c 100644 --- a/collects/mztake/demos/sine/sine-mztake.ss +++ b/collects/mztake/demos/sine/sine-mztake.ss @@ -1,63 +1,63 @@ -#| The program being debugged (a module in "sine.ss") runs an infinite loop, - binding "x" to a moment in time [-200,200], and "sin-x" to the sin(x/20) each iteration. - - This MzTake script plots the value of x over time, in sync with the execution of "sine.ss". |# - -(require (lib "animation.ss" "frtime")) ;; needed for display-shapes - - -(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)])) -#| * Create a process to debug sine.ss - - * Add a tracepoint at line 5, column 8; in the program, - this is right after the let values are bound, ->(if (x ...) - - * At this tracepoint, define "x/sinx-trace" to be a FrTime eventstream that - recieves events containing a list of two elements -- the current values - of the variables `x' and `sin-x', respectively. |# - - -(define x/sinx (hold x/sinx-trace)) -#| the local variable "sin/x" now is a FrTime behavior that holds the current value of the list (sin-x x) |# - -(define x (first x/sinx)) -(define sin-x (second x/sinx)) -#| the local variables x, sin-x hold their current values |# - - -(printf-b "x: ~a" x) -(printf-b "sin(x/20): ~a" sin-x) -#| Print the current values of x and sin-x |# - -(printf-b "largest x: ~a sin(x/20): ~a" - (largest-val-b (changes (first x/sinx))) - (largest-val-b (changes (second x/sinx)))) - -(printf-b "smallest x:~a sin(x/20):~a" - (smallest-val-b (changes (first x/sinx))) - (smallest-val-b (changes (second x/sinx)))) - - -(display-shapes - (list* (make-line (make-posn 0 200) (make-posn 400 200) "gray") - (make-line (make-posn 200 0) (make-posn 200 400) "gray") - #| draw horizontal and vertical gray lines |# - - (let ([x (+ 200 x)] - [sin-x (+ 200 (* 100 sin-x))]) - (history-b 50 (changes (make-circle - (make-posn x sin-x) - 5 - (if (< 200 sin-x) - (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# - (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# - -#| Make a circle at position x:(x + 200) and y:(100*sin(x/20) + 200) (scaled so we can draw it on screen) - with diameter of 5 pixels, and a color based on which quadrant the coordinate is in. - - Every time this value (the circle) changes (when the values of x and sin-x change): - * Keep a history (as a FIFO list) of (up to) the last 50 circles that were created. - * Pass this list to the display-shapes function, which will redraw every time this list changes. |# - - +#| The program being debugged (a module in "sine.ss") runs an infinite loop, + binding "x" to a moment in time [-200,200], and "sin-x" to the sin(x/20) each iteration. + + This MzTake script plots the value of x over time, in sync with the execution of "sine.ss". |# + +(require (lib "animation.ss" "frtime")) ;; needed for display-shapes + + +(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)])) +#| * Create a process to debug sine.ss + + * Add a tracepoint at line 5, column 8; in the program, + this is right after the let values are bound, ->(if (x ...) + + * At this tracepoint, define "x/sinx-trace" to be a FrTime eventstream that + recieves events containing a list of two elements -- the current values + of the variables `x' and `sin-x', respectively. |# + + +(define x/sinx (hold x/sinx-trace)) +#| the local variable "sin/x" now is a FrTime behavior that holds the current value of the list (sin-x x) |# + +(define x (first x/sinx)) +(define sin-x (second x/sinx)) +#| the local variables x, sin-x hold their current values |# + + +(printf-b "x: ~a" x) +(printf-b "sin(x/20): ~a" sin-x) +#| Print the current values of x and sin-x |# + +(printf-b "largest x: ~a sin(x/20): ~a" + (largest-val-b (changes (first x/sinx))) + (largest-val-b (changes (second x/sinx)))) + +(printf-b "smallest x:~a sin(x/20):~a" + (smallest-val-b (changes (first x/sinx))) + (smallest-val-b (changes (second x/sinx)))) + + +(display-shapes + (list* (make-line (make-posn 0 200) (make-posn 400 200) "gray") + (make-line (make-posn 200 0) (make-posn 200 400) "gray") + #| draw horizontal and vertical gray lines |# + + (let ([x (+ 200 x)] + [sin-x (+ 200 (* 100 sin-x))]) + (history-b 50 (changes (make-circle + (make-posn x sin-x) + 5 + (if (< 200 sin-x) + (if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |# + (if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |# + +#| Make a circle at position x:(x + 200) and y:(100*sin(x/20) + 200) (scaled so we can draw it on screen) + with diameter of 5 pixels, and a color based on which quadrant the coordinate is in. + + Every time this value (the circle) changes (when the values of x and sin-x change): + * Keep a history (as a FIFO list) of (up to) the last 50 circles that were created. + * Pass this list to the display-shapes function, which will redraw every time this list changes. |# + + (start/resume p) #| Start the process for sine.ss |# \ No newline at end of file diff --git a/collects/mztake/demos/sine/sine.ss b/collects/mztake/demos/sine/sine.ss index d152a4426c..93739c30b1 100644 --- a/collects/mztake/demos/sine/sine.ss +++ b/collects/mztake/demos/sine/sine.ss @@ -1,8 +1,8 @@ -(module sine mzscheme - (define (run) - (let loop ([x -200]) - (let ([sin-x (sin (/ x 20.0))]) - (if (x . < . 200) - (loop (add1 x)) - (loop -200))))) +(module sine mzscheme + (define (run) + (let loop ([x -200]) + (let ([sin-x (sin (/ x 20.0))]) + (if (x . < . 200) + (loop (add1 x)) + (loop -200))))) (run)) \ No newline at end of file diff --git a/collects/mztake/doc.txt b/collects/mztake/doc.txt index d871e29404..5faa9f0e22 100644 --- a/collects/mztake/doc.txt +++ b/collects/mztake/doc.txt @@ -1,731 +1,731 @@ - - -============================================================ - - About MzTake - -_MzTake_ is a _scripted debugger_ for PLT Scheme. It helps -programmers monitor the execution of a target program as it -unfolds (and optionally pause or resume its execution!). MzTake -gives you the power to easily write real programs that debug real -programs. You are no longer limited to a tool chest of buttons -like "add breakpoint", "step-next", "step-into", and "step-over". - -MzTake scripts are written in the FrTime programming -language, which is bundled with DrScheme. FrTime supports the -implementation of reactive systems in a functional style. -The key abstraction it adds is a type of value called a 'signal', -which can change over time. FrTime infers dataflow dependencies -between signals and automatically recomputes them when necessary. - -With signals (implemented as "event streams" and "behaviors"), -it is possible to respond to outside events concisely (without -using callbacks). Consider a MzTake script to monitor the -behavior of the program "highway.ss", in the demos directory -of the MzTake collection: - - (define-mztake-process radar-program - ("highway.ss" [values-of-speed 3 4 bind 'speed])) - (printf-b "current speed: ~a" (hold values-of-speed)) - (start/resume radar-program) - -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 fourth -column of the third line of "highway.ss". VALUES-OF-SPEED -is a FrTime event stream that always contains the *current* -value (and potentially every past value) of the variable named -SPEED, as it is bound to the values corresponding to that -syntactic location. - -PRINTF-B works like Scheme's PRINTF function, consuming a -format-string and fill-values, printing the result in -DrScheme's interaction pane. Whereas PRINTF accumulates -outdated text on the screen, PRINTF-B will replace old text -with updated text if any of the fill-values change. In this -invocation, it prints the current speed to screen, throughout -the execution of "highway.ss". - -MzTake scripts are also powerful tools for building external -test suites. Whereas typical test cases may only assert that -the result of a computation is correct, MzTake scripts -can dynamically break open an execution, record inner state, -and *compute* with it. This allows you to confirm that the -intermediate steps which lead to a correct answer were -also correct. In the example below, we use a version of map -that operates over events in an event stream, instead of -elements in a list. We assert that all recorded speeds are -less than 55, otherwise we raise an exception: - - (map-e (lambda (a-speed) - (when (>= a-speed 55) (raise 'too-fast!!))) - values-of-speed) - -Of course, like most test suites, this only tells you -something went wrong. Perhaps knowing the last ten speeds that -led to this would prove useful. You could PRINTF the value -onto a new line each time, but after ten updates the screen -is already starting to fill up with information -- we are -only interested in the last ten speeds, after all. -One possible solution: - - (printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) - (map-e (lambda (a-speed) - (when (>= a-speed 55) (raise 'too-fast!!))) - values-of-speed) - -HISTORY-B consumes a number and an event stream (VALUES-OF-SPEED), -returning a FrTime behavior containing a FIFO ordered list of -the last ten values emitted on that event stream. In this case, -HISTORY-B maintains a list of the ten most recent SPEEDS seen -on VALUES-OF-SPEED (up until the exception is raised). Though -this is is an improvement, we still can't *use* that list as -data to see what led to the exception. One possible solution: - - (define last-ten (history-b 10 values-of-speed)) - (printf-b "last ten speeds: ~a" last-ten) - (map-e (lambda (a-speed) - (when (>= a-speed 55) (pause radar-program))) - values-of-speed) - -MzTake allows you to "pause" a target program anytime during -execution. Once paused, it becomes trivial to interactively -explore and compute with script variables (such as LAST-TEN) -in the interaction pane. Once satisfied, you can easily resume -execution by typing "(start/resume radar-program)", or end it -with "(kill radar-program)", where RADAR-PROGRAM is any MzTake -process. - -Finally, FrTime provides a rich animation library. Combined -with the MzTake debugger, it takes only a few lines to animate -your algorithms and see them in action, easily letting you -confirm (or refute!) that they are working correctly. - - (display-shapes (make-speed-gauge (hold values-of-speed))) - - -============================================================ - - Installing MzTake - -MzTake is a DrScheme tool distributed as a self-installing -".PLT" file from the following web site: - - http://www.cs.brown.edu/research/plt/software/mztake/ - -MzTake requires PLT Scheme v208 and higher. - - -============================================================ - - Demos - -If you installed MzTake using the .PLT distribution, you can -find the demos in the following directories: - - On Linux: - ~/.plt-scheme/208/collects/mztake/demos - - On Windows (typically): - C:\Documents and Settings\Jono\Application Data\PLT Scheme\208\collects\mztake\demos - -where "Jono" is your username, and "208" is the version of -DrScheme you are running. - -The demos directory contains a sub-directory for each of the demos. -For instance, the highway directory contains "highway.ss" and -"highway-mztake.ss". To run this demo, switch to the "MzTake" language -level from the "Experimental Languages" section of DrScheme's language -dialog, load "highway-mztake.ss", and click "Run". What you see is -generated by the debugging script. Each demo directory contains -the following two files: one is the program being debugged -(named after the directory), and the other is a file ending -in "...-mztake.ss" (the MzTake script). - -The demos are in order of increasing complexity. When you open -them in DrScheme, don't let the amount of text overwhelm you -- -the scripts themselves are only a few lines of code. However, the -commenting is *extensive* to aid even a FrTime novice who has never -written a FrTime script before! - - ./highway/highway-mztake.ss - The program simulates a very simple - speedometer, and the MzTake script - monitors it. - - ./sine/sine-mztake.ss - Plots values extracted from a program - which generates coordinates for a - single sine wave. - - ./montecarlo/montecarlo-mztake.ss - Visualizes the Monte Carlo integration - ("throwing darts at a dartboard") used - to derive the value of pi. - - ./random/random-mztake.ss - Tests the quality of Scheme's random - number generator with a histogram. - - ./exception/exception-mztake.ss - Demonstrates how MzTake catches exceptions. - - ./first-class/first-class-mztake.ss - Demonstrates how you can add multiple traces - to the same variable in a file to `record' - its evolution, and how you can trace first-class - functions, such as those passed to map. - - ./djikstra/dijkstra-mztake.ss - Debugs a buggy implementation of - Dijkstra's algorithm - -If you have just downloaded MzTake and are coming directly -to the demos, know that once started, you can easily end -execution of a debugger scipt by typing "(kill p)" into the -Interactions window (freeing up resources). You can also pause -a script with "(pause p)", and resume it with with "(start/resume p)", -where P is any MzTake process. In the "highway" demo, P is -"radar-program", and P is "p" (meaning "process") for the others. - - -============================================================ - - Functions - -The demos demonstrate many ways to debug with MzTake using -FrTime, even if you are not very familiar with the language. -That said, in order to become more proficient in using MzTake, -you will want to learn more about the FrTime language. - -You can refer to FrTime's own documentation by searching for -"frtime" in DrScheme's Help window. It explains how to use -time-varying behaviors and event streams in greater depth, and -also describes the many useful functions FrTime provides to work -with them. - - - -============================================================ - -_Debugging with MzTake_ - -Conceptually, MzTake is an extension of FrTime, providing -functions that execute a target program (or many!), and -"connect" to points in its code. MzTake then provides the -running FrTime script with interesting information (such as -a variable's current value) which it derives from these -"connections". FrTime then handles the rest. - -FrTime takes that information and lets the script author -compute with it, verify it, print it, make visualizations -with it, anything you would like to do. - -Currently, other than the powerful monitoring facilities that -MzTake provides (see BIND and ENTRY in the next section), user -interaction is limited to pausing/resuming the running program, -and operating on a few properties and predicates over general -program state (see PROCESS:EXITED?, PROCESS:RUNTIME/SECONDS, -and PROCESS:EXCEPTIONS). In the future, MzTake will offer other -types of interaction and information, such as inspecting -(and stepping through!) the call stack. - -In more depth, the debugger works on a model roughly as follows: - - * A single debugging script file contains all the MzTake - processes, traces, bindings, animations, and other FrTime - code fragments that do the debugging and program monitoring. - - * This script file is loaded into the Definitions window in - DrScheme, and run using the MzTake language. User interaction - with the debugger is provided through the Interactions window. - - * A MzTake *process* is like an operating system that runs a group of - programs, installs hooks into them to monitor their execution, - and provides FrTime with these hooks to do computations. - - * Also like an operating system, each MzTake process runs - independently of all other MzTake processes; one will not affect - another. They can "interact" in the script by adding traces and - computing with those traces. - - * A MzTake process accepts a number of target-files as "clients" to - debug and monitor. Each client should contain a module program, - of the form: - - (module mod-name mzscheme - ... program-body ... ) - - MzTake does not support debugging anything other than modules. - - * The first client defined for each MzTake process is *always* the - main ("top level") module. That is, START/RESUME runs the main - client module, in much the same way that you would run it in - DrScheme (in the "module ..." language). It is assumed the module - has "side-effects" which start the target program. - - The rest of the files traced in a DEFINE-MZTAKE-PROCESS are modules - used *by* the main module, allowing you to see what is going - on deeper than in the main-module. For example: - - (define-mztake-process p1 - ("my-stack-tests.ss") - ((lib "my-stack.ss" "my-stack") [s-push-p1 3 29 bind 'insert-value] - [s-pop-p1 10 16 bind 'return-value])) - - "my-stack-tests.ss" is the main module. Suppose it is a test-suite - for "my-stack.ss"; the test suite asserts that the stacks are not - working as expected. You may want to use these traces to test how - "my-stack.ss" is operating "inside" during the test-suite. - Watch the pushes and pops and see how they correlate to what you expect. - - * The same module can be traced differently for each MzTake processe. - Lets say that in the same script you want to see why the stack is using - a lot more memory than expected. You can set traces to count how many times - spaces is allocated and cleared and see if they are equal. - - (define-mztake-process p2 - ("my-stack-tests.ss") - ((lib "my-stack.ss" "my-stack") [s-allocates-p2 22 2 entry] - [s-clears-p2 28 2 entry])) - - This installs an ENTRY trace at the function entry point for - ALLOCATE-STACK and CLEAR-STACK in "my-stack.ss". Every time - those functions get called, these traces will send a "#t" event, - and could be counted using COUNT-B. - - * Once a MzTake processe is defined, and all the script code operating - on traces is defined, START/RESUME can be called on the process - to begin its execution. - - * All of the variables defined by traces (BINDs and ENTRYs on the active - MzTake processes) are available simulatenously in the script. - - * Lastly, proceses can be started, paused, resumed, and terminated. - See START/RESUME, PAUSE, KILL, KILL-ALL. - - - -============================================================ - -MzTake itself defines the following functions: - -_Installing Trace Points_ - -Currently, MzTake offers two types of traces: ENTRY and BIND. -ENTRYs are event streams that get a "#t" event every time the -target program reaches the trace point. Binds are event streams that -ping the value of one or more variables when the trace point is reached. - -> (define-mztake-process process-name - [target-filename trace-clause ...] ...) - - Where trace-clause is one of the following: - - <1> [trace-name line-number column-number ENTRY] - <2> [trace-name line-number column-number bind 'variable-name] - <3> [trace-name line-number column-number bind '(variable-name ...)] - - DEFINE-MZTAKE-PROCESS defines the variable process-name, - whose value is a MzTake process object. That object - can be passed to functions such as START/RESUME, KILL, - and "process:runtime/milliseconds", documented in the next - section. - - DEFINE-MZTAKE-PROCESS installs trace points in one or many files, - as indicated by the trace-clauses. The target-filename can - be any file specification accepted by the standard REQUIRE - syntax for modules: - - * Absolute path: - (define-mztake-process p [(file "/home/me/test.ss") [brk 10 7 ENTRY]]) - - * Relative path: - (define-mztake-process p ["../test.ss" [brk 10 7 ENTRY]]) - - * Library path: - (define-mztake-process p [(lib "test.ss" "collect-dir") [brk 10 7 ENTRY]]) - - For each trace-clause in the call to DEFINE-MZTAKE-PROCESS, - the trace-name is a variable name bound at the - top-level, whose value is a FrTime event - stream. Each time the execution of the target - reaches the given line-number and column[*], the - debugger emits an event on that stream. The value of - that event depends on which of the three kinds of - trace-clause was used, as follows: - - <1> The value of the event is #t (an ENTRY trace). - - <2> The value of the event is the value of variable-name, - in the target program, at the location of the - trace point (a BIND trace). - - <3> The value of the event is a list containing one - element for each variable name given. The value - of each element is taken from the variable of - that name in the target (as in <2>). - - Trace points do not themselves pause the - program. Unless a MzTake process is suspended using - the PAUSE function (below), execution resumes after - the MzTake script processed the event. - - [*] Valid locations to add traces to are almost - always one character to the left of open-parentheses, "(", - open-square-braces, "[", or to the left of the first - character of a symbol/name (LET is a special exception, - see Known Problems for more information on tracing LET): - - (code [more-code ...] ...) - ^^ ^^ ^ - - [*] To obtain accurate line/column information when - setting up trace points, make sure you turn off - DrScheme's "Wrap Text" feature under the "Edit" - menu. Alternatively, you can position your cursor - at the location where you want to add a trace, - and click MzTake's "Syntax Location" button on the - main DrScheme toolbar. A message-box will tell - the correct line and column numbers to use. - - -_Operations on MzTake Processes_ - -The following functions operate on MzTake processes, -and can be used in the Interactions window. - -> (start/resume process-name) - - Start the execution and monitoring of the DEFINE-MZTAKE-PROCESS, - process-name. If the process given to START/RESUME is already - running, and was paused with the function PAUSE (below), - START/RESUME resumes its execution. - - Script statements are executed top-down, sequentially. - In general, you want to call start/resume at the end of - the script, or in the interactions pane after you - start running the script. Otherwise, a race condition may - develop, where your script may miss events from the - beginning of the execution. - -> (pause process) - - Suspends the execution of the given mztake - process. Use START/RESUME to resume execution. - -> (kill process) - - Kills the target process and releases all resources - it used -- you cannot START/RESUME after a KILL. - - Closing a FrTime animation/graphics window will *not* - kill a running MzTake process. If it does not terminate - on its own, you may kill it with "(kill p-name)" or - "(kill-all)" in the Interactions window. - -> (kill-all) - - kill-all kills all the processes currently running - under MzTake -- use this when it seems a process is - out of control and needs to be stopped immediately. - Has the same effect of calling KILL on each process - you defined and START/RESUME'd in the script. - -> (process:exceptions process) - - Returns an event stream. If the target process - throws an uncaught exception, the exception will - appear on this stream. - -> (process:runtime/seconds process) - - Returns a FrTime time-varying value which counts the - number of seconds elapsed in the execution of the - given process (not counting time spent suspended by - PAUSE). Includes garbage-collection time. - -> (process:runtime/milliseconds process) - - Returns a FrTime time-varying value which counts the - number of milliseconds elapsed in the execution of the - given process (not counting time spent suspended by - PAUSE). Includes garbage-collection time. - -> (process:exited? process) - - Return a time-varying Boolean value which becomes - true after the given MzTake process exited/killed. - - -_Useful Functions for Time-Varying Values_ - -Note: FrTime uses a naming convention where functions which - return behaviors have names that end in "-b", and - functions that return event streams end in "-e". - -Tips: When you have a behavior that you want to turn into - an event, use (changes behavior). - - When you have an event that you want to be a - behavior, use (hold event) - - -MzTake defines a few functions on time-varying values -that are particularly useful when debugging: - -> (history-e stream) -> (history-b stream) - - Keeps a complete history of all the values seen - on an event stream as a list, oldest events last. - - Use with BINDs: (history-b x-trace) - -> (history-e n stream) -> (history-b n stream) - - Keeps a list of the last n values of a behavior - Returns a list of at most n elements, where the - elements are the n last values seem on the stream, - in order, oldest first. - -> (count-b stream) - - Counts number of events seen on an eventstream. - - Often used directly on ENTRY traces, counting how many - times ENTRY occured: (count-b entry-trace) - - Also useful to count how many times a BIND changed - by calling: (count-b (changes bind-trace)) - -> (largest-val-b stream) -> (smallest-val-b stream) - - Keeps track of the largest/smallest values seen on a stream. - Use with BINDs: (largest-val-b (changes bind-trace)). - -> (sequence-match? seq stream) - - Matches a sequence of items in a list to the history - of event pings, on the event stream evs. Returns #t - when it matches, and #f otherwise. Use when you expect - a certain pattern to show up, and want to know when: - (sequence-match? '(0 1 2 1 0) (changes bind-trace)) - -> (printf-b format-string arg ...) - - Displays the value of the behaviors with the given format, - using "~a" just like in Scheme's FORMAT function. - - -============================================================ - -Known Problems - -* In general, you should not REQUIRE or use any methods - in your MzTake script that were defined in any of the files - you are putting bind-traces on: - - ORIGINAL FILE: - (define (my-fun some-struct) ...) - - MZTAKE SCRIPT: - (require "original-file.ss") - (define-mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct])) - (my-fun (hold val)) - - Sometimes this causes unusual errors. These problems usually only - show up if you are binding to structs (defined in the same file) and - passing those bindings to functions (defined in the same file). - - You have been warned. - -* The break button will *not* kill runaway client processes. - You must type (kill process-name) or (kill-all). - -* Some legal syntax locations (used in setting trace points) - are unreachable during program execution (they do not get - triggered and produce empty eventstreams). So far, this only - shows up in LETs (the trace point being one line above, - and one character to the left of the carrot): - - (define x 12) - (let ([x (add1 x)]) x) - ^ ^^^ - Recommended syntax locations to use for trace points: - (define x 12) - (let ([x (add1 x)]) x) - ^ ^^ ^ ^ - -* Don't rely entirely on MzTake to complain when you change - target code and your line/col locations in the script are out - of date. It can only raise an error if the locations are invalid. - -* MzTake has not been tested for stability if the target is using - multiple threads. This only applies to threaded modules - *with* traces on them -- other REQUIRE'd modules will work - as expected. - -* Error handling is not perfect -- e.g., the little "bug" - buttons on syntax errors don't reference the correct code. - However, the messages that are printed are as accurate as - possible. - -* process:running? tells you if the process is currently, - actively, running. It might be useful to you, and will - be in the next release. - -* On particularly fast computers, when running scripts with a - very high trace point density (traces are hit constantly, - potentially hundreds in a second, like in the Monte Carlo, - random-xs, and sine demos), the FrTime animation window may - appear unresponsive because of how fast it is redrawing. - -* Currently, if you are running traces on two modules with the - same name, IN the same process, though in different directories, - there will probably be some sort of name-clash and strange error. - This will be fixed. - -* If you find that sometimes it seems one of the breakpoints you - set in a file REQUIRE'd by the main client module, your problem - may be that the file-specification you used is different in the - script than it is in the main client module (occuring in REQUIREs - that use sub-directories): - - MAIN CLIENT: - (require (lib "my-lib.ss" "mycollect" "private")) - - MZTAKE SCRIPT: - (define-mztake-process p ("main.ss") - ((lib "my-lib.ss" "mycollect/private") [traces...]) - - This seems to be an issue with DrScheme rather than MzTake. - For instance, you get an error if you make a module like this - on Windows: - - (module m mzscheme - (require (lib "my-lib.ss" "mycollect" "private")) - (provide (lib "my-lib.ss" "mycollect/private"))) - - This will be looked into, but keep your eyes open for it. - - -============================================================ - -Tips and Tricks - -* If output seems difficult to read in the script, e.g. you ever - see "struct:signal" and a lot of garbage, try (print-struct #f) - before you do any printing, or use (value-now behavior-name) to - get a more usable/printable version of a FrTime behavior (the - caveat is that it is no longer 'reactive' and it may be out of - date after the moment it is processed). - -* You may want to bind more than one variable at a certain point - so that you only get one change event -- otherwise, you will - get multiple change events even if at the same trace point - (see Known Problems). - - For instance, if you trace 'x and 'y separately: - * First 'x and 'y are up-to-date. - * Then 'x updates and 'y is out-of-date. - * Then 'y updates, and both are up-to-date. - - But code that draws using a position derived from X and Y - will draw twice, in two locations, one for each update, - the second one being correct. - -* Order matters -- if you have more than one trace at an identical - syntax location (in the same file), the order that trace events - get updated is identical to the order they exist in the script. - For example: - - (define-mztake-process p ("file.ss" [a-bind 5 55 bind 'x] - [some-bind 2 22 bind 'irrelevent] - [a-entry 5 55 entry] - [another-bind 5 55 bind 'y])) - - When that trace gets evaluated, A-BIND will get the new value - of X, and relevant FrTime code will get re-evaluated. *Then* - A-ENTRY will be notified about the trace and a #t will be emitted, - (at this point in time, Y is out-of-date, but X is up-to-date). Lastly, - ANOTHER-BIND will get the new value of Y, and the trace is complete. - - Of course, you will typically want ENTRY as the first trace, - and all other BINDs to be in a list, so that you get two updates, - as explained in the previous tip: - - (define-mztake-process p ("file.ss" [a-entry 5 55 entry] - [x/y-bind 5 55 bind '(x y)] - [some-bind 2 22 bind 'irrelevent])) - -* You can trace the *same* file in different ways by using - multiple processes on the same file, under different - contexts, and compare results. For example, in - "demos/misc/first-class-mztake.ss": - - (define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] - [x-in-let 4 25 bind 'x] - [x-after-let 5 11 bind 'x])) - (... code omitted ...) - (start/resume p) - - is functionally equivalent to: - - (define-mztake-process p1 ("first-class.ss" [x-before-let 3 29 bind 'x])) - (define-mztake-process p2 ("first-class.ss" [x-in-let 4 25 bind 'x])) - (define-mztake-process p3 ("first-class.ss" [x-after-let 5 11 bind 'x])) - (... code omitted ...) - (start/resume p1) (start/resume p2) (start/resume p3) - - All the variable bindings can still be used as they were before. - -* Code such as (when (= num 100) (pause p)) pauses *after* - num reaches 100, the next time a trace point is hit. - However, the next point is not processed until you - START/RESUME. See the random-xs demo. - -* When you pause a MzTake process, you can play with - current bindings and explore script code interactively. - You *may* dynamically evaluate/add FrTime code to do - things like pause or kill a MzTake process based on runtime, - etc. You can even define new MzTake processes dynamically - and start/resume them, integrating and exploring the traces. - You cannot add or change existing traces dynamically. - -* You can add trace points to first-class functions, and they - will send trace update from anywhere they are passed to and - evaluated. - -* FrTime has two methods for drawing graphics. One runs in - constant time, and is fast, because it simply accumulates - pixels on the screen and doesn't redraw a list of objects. - See the "Monte Carlo" or "random-xs" demos for this in action. - - The other method is primarily for animations which need - redrawing because things move. It slows down pretty quickly - after you have more than 1000 objects to the shape list. - See the "sine" or "highway" demos for this in action. - - For more information, refer to the FrTime documentation. - - -============================================================ - -Authors and Thanks - -MzTake is an experimental debugger. It should enable new -debugging approaches that were not possible (easily) before. -Please send feedback to the PLT-Scheme mailing list: - http://www.plt-scheme.org/maillist/ - -We are eager to hear about how you are using MzTake! - - Jonathan Spiro - Guillaume Marceau - Gregory Cooper - John Clements - Shriram Krishnamurthi - - -Please send bug reports to: jspiro@cs.brown.edu - ---- -Icons for MzTake come from the Gnome Project: Nautilus Emblems. -These are provided under the GPL license. - http://jimmac.musichall.cz/ikony.php3 + + +============================================================ + + About MzTake + +_MzTake_ is a _scripted debugger_ for PLT Scheme. It helps +programmers monitor the execution of a target program as it +unfolds (and optionally pause or resume its execution!). MzTake +gives you the power to easily write real programs that debug real +programs. You are no longer limited to a tool chest of buttons +like "add breakpoint", "step-next", "step-into", and "step-over". + +MzTake scripts are written in the FrTime programming +language, which is bundled with DrScheme. FrTime supports the +implementation of reactive systems in a functional style. +The key abstraction it adds is a type of value called a 'signal', +which can change over time. FrTime infers dataflow dependencies +between signals and automatically recomputes them when necessary. + +With signals (implemented as "event streams" and "behaviors"), +it is possible to respond to outside events concisely (without +using callbacks). Consider a MzTake script to monitor the +behavior of the program "highway.ss", in the demos directory +of the MzTake collection: + + (define-mztake-process radar-program + ("highway.ss" [values-of-speed 3 4 bind 'speed])) + (printf-b "current speed: ~a" (hold values-of-speed)) + (start/resume radar-program) + +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 fourth +column of the third line of "highway.ss". VALUES-OF-SPEED +is a FrTime event stream that always contains the *current* +value (and potentially every past value) of the variable named +SPEED, as it is bound to the values corresponding to that +syntactic location. + +PRINTF-B works like Scheme's PRINTF function, consuming a +format-string and fill-values, printing the result in +DrScheme's interaction pane. Whereas PRINTF accumulates +outdated text on the screen, PRINTF-B will replace old text +with updated text if any of the fill-values change. In this +invocation, it prints the current speed to screen, throughout +the execution of "highway.ss". + +MzTake scripts are also powerful tools for building external +test suites. Whereas typical test cases may only assert that +the result of a computation is correct, MzTake scripts +can dynamically break open an execution, record inner state, +and *compute* with it. This allows you to confirm that the +intermediate steps which lead to a correct answer were +also correct. In the example below, we use a version of map +that operates over events in an event stream, instead of +elements in a list. We assert that all recorded speeds are +less than 55, otherwise we raise an exception: + + (map-e (lambda (a-speed) + (when (>= a-speed 55) (raise 'too-fast!!))) + values-of-speed) + +Of course, like most test suites, this only tells you +something went wrong. Perhaps knowing the last ten speeds that +led to this would prove useful. You could PRINTF the value +onto a new line each time, but after ten updates the screen +is already starting to fill up with information -- we are +only interested in the last ten speeds, after all. +One possible solution: + + (printf-b "last ten speeds: ~a" (history-b 10 values-of-speed)) + (map-e (lambda (a-speed) + (when (>= a-speed 55) (raise 'too-fast!!))) + values-of-speed) + +HISTORY-B consumes a number and an event stream (VALUES-OF-SPEED), +returning a FrTime behavior containing a FIFO ordered list of +the last ten values emitted on that event stream. In this case, +HISTORY-B maintains a list of the ten most recent SPEEDS seen +on VALUES-OF-SPEED (up until the exception is raised). Though +this is is an improvement, we still can't *use* that list as +data to see what led to the exception. One possible solution: + + (define last-ten (history-b 10 values-of-speed)) + (printf-b "last ten speeds: ~a" last-ten) + (map-e (lambda (a-speed) + (when (>= a-speed 55) (pause radar-program))) + values-of-speed) + +MzTake allows you to "pause" a target program anytime during +execution. Once paused, it becomes trivial to interactively +explore and compute with script variables (such as LAST-TEN) +in the interaction pane. Once satisfied, you can easily resume +execution by typing "(start/resume radar-program)", or end it +with "(kill radar-program)", where RADAR-PROGRAM is any MzTake +process. + +Finally, FrTime provides a rich animation library. Combined +with the MzTake debugger, it takes only a few lines to animate +your algorithms and see them in action, easily letting you +confirm (or refute!) that they are working correctly. + + (display-shapes (make-speed-gauge (hold values-of-speed))) + + +============================================================ + + Installing MzTake + +MzTake is a DrScheme tool distributed as a self-installing +".PLT" file from the following web site: + + http://www.cs.brown.edu/research/plt/software/mztake/ + +MzTake requires PLT Scheme v208 and higher. + + +============================================================ + + Demos + +If you installed MzTake using the .PLT distribution, you can +find the demos in the following directories: + + On Linux: + ~/.plt-scheme/208/collects/mztake/demos + + On Windows (typically): + C:\Documents and Settings\Jono\Application Data\PLT Scheme\208\collects\mztake\demos + +where "Jono" is your username, and "208" is the version of +DrScheme you are running. + +The demos directory contains a sub-directory for each of the demos. +For instance, the highway directory contains "highway.ss" and +"highway-mztake.ss". To run this demo, switch to the "MzTake" language +level from the "Experimental Languages" section of DrScheme's language +dialog, load "highway-mztake.ss", and click "Run". What you see is +generated by the debugging script. Each demo directory contains +the following two files: one is the program being debugged +(named after the directory), and the other is a file ending +in "...-mztake.ss" (the MzTake script). + +The demos are in order of increasing complexity. When you open +them in DrScheme, don't let the amount of text overwhelm you -- +the scripts themselves are only a few lines of code. However, the +commenting is *extensive* to aid even a FrTime novice who has never +written a FrTime script before! + + ./highway/highway-mztake.ss - The program simulates a very simple + speedometer, and the MzTake script + monitors it. + + ./sine/sine-mztake.ss - Plots values extracted from a program + which generates coordinates for a + single sine wave. + + ./montecarlo/montecarlo-mztake.ss - Visualizes the Monte Carlo integration + ("throwing darts at a dartboard") used + to derive the value of pi. + + ./random/random-mztake.ss - Tests the quality of Scheme's random + number generator with a histogram. + + ./exception/exception-mztake.ss - Demonstrates how MzTake catches exceptions. + + ./first-class/first-class-mztake.ss - Demonstrates how you can add multiple traces + to the same variable in a file to `record' + its evolution, and how you can trace first-class + functions, such as those passed to map. + + ./djikstra/dijkstra-mztake.ss - Debugs a buggy implementation of + Dijkstra's algorithm + +If you have just downloaded MzTake and are coming directly +to the demos, know that once started, you can easily end +execution of a debugger scipt by typing "(kill p)" into the +Interactions window (freeing up resources). You can also pause +a script with "(pause p)", and resume it with with "(start/resume p)", +where P is any MzTake process. In the "highway" demo, P is +"radar-program", and P is "p" (meaning "process") for the others. + + +============================================================ + + Functions + +The demos demonstrate many ways to debug with MzTake using +FrTime, even if you are not very familiar with the language. +That said, in order to become more proficient in using MzTake, +you will want to learn more about the FrTime language. + +You can refer to FrTime's own documentation by searching for +"frtime" in DrScheme's Help window. It explains how to use +time-varying behaviors and event streams in greater depth, and +also describes the many useful functions FrTime provides to work +with them. + + + +============================================================ + +_Debugging with MzTake_ + +Conceptually, MzTake is an extension of FrTime, providing +functions that execute a target program (or many!), and +"connect" to points in its code. MzTake then provides the +running FrTime script with interesting information (such as +a variable's current value) which it derives from these +"connections". FrTime then handles the rest. + +FrTime takes that information and lets the script author +compute with it, verify it, print it, make visualizations +with it, anything you would like to do. + +Currently, other than the powerful monitoring facilities that +MzTake provides (see BIND and ENTRY in the next section), user +interaction is limited to pausing/resuming the running program, +and operating on a few properties and predicates over general +program state (see PROCESS:EXITED?, PROCESS:RUNTIME/SECONDS, +and PROCESS:EXCEPTIONS). In the future, MzTake will offer other +types of interaction and information, such as inspecting +(and stepping through!) the call stack. + +In more depth, the debugger works on a model roughly as follows: + + * A single debugging script file contains all the MzTake + processes, traces, bindings, animations, and other FrTime + code fragments that do the debugging and program monitoring. + + * This script file is loaded into the Definitions window in + DrScheme, and run using the MzTake language. User interaction + with the debugger is provided through the Interactions window. + + * A MzTake *process* is like an operating system that runs a group of + programs, installs hooks into them to monitor their execution, + and provides FrTime with these hooks to do computations. + + * Also like an operating system, each MzTake process runs + independently of all other MzTake processes; one will not affect + another. They can "interact" in the script by adding traces and + computing with those traces. + + * A MzTake process accepts a number of target-files as "clients" to + debug and monitor. Each client should contain a module program, + of the form: + + (module mod-name mzscheme + ... program-body ... ) + + MzTake does not support debugging anything other than modules. + + * The first client defined for each MzTake process is *always* the + main ("top level") module. That is, START/RESUME runs the main + client module, in much the same way that you would run it in + DrScheme (in the "module ..." language). It is assumed the module + has "side-effects" which start the target program. + + The rest of the files traced in a DEFINE-MZTAKE-PROCESS are modules + used *by* the main module, allowing you to see what is going + on deeper than in the main-module. For example: + + (define-mztake-process p1 + ("my-stack-tests.ss") + ((lib "my-stack.ss" "my-stack") [s-push-p1 3 29 bind 'insert-value] + [s-pop-p1 10 16 bind 'return-value])) + + "my-stack-tests.ss" is the main module. Suppose it is a test-suite + for "my-stack.ss"; the test suite asserts that the stacks are not + working as expected. You may want to use these traces to test how + "my-stack.ss" is operating "inside" during the test-suite. + Watch the pushes and pops and see how they correlate to what you expect. + + * The same module can be traced differently for each MzTake processe. + Lets say that in the same script you want to see why the stack is using + a lot more memory than expected. You can set traces to count how many times + spaces is allocated and cleared and see if they are equal. + + (define-mztake-process p2 + ("my-stack-tests.ss") + ((lib "my-stack.ss" "my-stack") [s-allocates-p2 22 2 entry] + [s-clears-p2 28 2 entry])) + + This installs an ENTRY trace at the function entry point for + ALLOCATE-STACK and CLEAR-STACK in "my-stack.ss". Every time + those functions get called, these traces will send a "#t" event, + and could be counted using COUNT-B. + + * Once a MzTake processe is defined, and all the script code operating + on traces is defined, START/RESUME can be called on the process + to begin its execution. + + * All of the variables defined by traces (BINDs and ENTRYs on the active + MzTake processes) are available simulatenously in the script. + + * Lastly, proceses can be started, paused, resumed, and terminated. + See START/RESUME, PAUSE, KILL, KILL-ALL. + + + +============================================================ + +MzTake itself defines the following functions: + +_Installing Trace Points_ + +Currently, MzTake offers two types of traces: ENTRY and BIND. +ENTRYs are event streams that get a "#t" event every time the +target program reaches the trace point. Binds are event streams that +ping the value of one or more variables when the trace point is reached. + +> (define-mztake-process process-name + [target-filename trace-clause ...] ...) + + Where trace-clause is one of the following: + + <1> [trace-name line-number column-number ENTRY] + <2> [trace-name line-number column-number bind 'variable-name] + <3> [trace-name line-number column-number bind '(variable-name ...)] + + DEFINE-MZTAKE-PROCESS defines the variable process-name, + whose value is a MzTake process object. That object + can be passed to functions such as START/RESUME, KILL, + and "process:runtime/milliseconds", documented in the next + section. + + DEFINE-MZTAKE-PROCESS installs trace points in one or many files, + as indicated by the trace-clauses. The target-filename can + be any file specification accepted by the standard REQUIRE + syntax for modules: + + * Absolute path: + (define-mztake-process p [(file "/home/me/test.ss") [brk 10 7 ENTRY]]) + + * Relative path: + (define-mztake-process p ["../test.ss" [brk 10 7 ENTRY]]) + + * Library path: + (define-mztake-process p [(lib "test.ss" "collect-dir") [brk 10 7 ENTRY]]) + + For each trace-clause in the call to DEFINE-MZTAKE-PROCESS, + the trace-name is a variable name bound at the + top-level, whose value is a FrTime event + stream. Each time the execution of the target + reaches the given line-number and column[*], the + debugger emits an event on that stream. The value of + that event depends on which of the three kinds of + trace-clause was used, as follows: + + <1> The value of the event is #t (an ENTRY trace). + + <2> The value of the event is the value of variable-name, + in the target program, at the location of the + trace point (a BIND trace). + + <3> The value of the event is a list containing one + element for each variable name given. The value + of each element is taken from the variable of + that name in the target (as in <2>). + + Trace points do not themselves pause the + program. Unless a MzTake process is suspended using + the PAUSE function (below), execution resumes after + the MzTake script processed the event. + + [*] Valid locations to add traces to are almost + always one character to the left of open-parentheses, "(", + open-square-braces, "[", or to the left of the first + character of a symbol/name (LET is a special exception, + see Known Problems for more information on tracing LET): + + (code [more-code ...] ...) + ^^ ^^ ^ + + [*] To obtain accurate line/column information when + setting up trace points, make sure you turn off + DrScheme's "Wrap Text" feature under the "Edit" + menu. Alternatively, you can position your cursor + at the location where you want to add a trace, + and click MzTake's "Syntax Location" button on the + main DrScheme toolbar. A message-box will tell + the correct line and column numbers to use. + + +_Operations on MzTake Processes_ + +The following functions operate on MzTake processes, +and can be used in the Interactions window. + +> (start/resume process-name) + + Start the execution and monitoring of the DEFINE-MZTAKE-PROCESS, + process-name. If the process given to START/RESUME is already + running, and was paused with the function PAUSE (below), + START/RESUME resumes its execution. + + Script statements are executed top-down, sequentially. + In general, you want to call start/resume at the end of + the script, or in the interactions pane after you + start running the script. Otherwise, a race condition may + develop, where your script may miss events from the + beginning of the execution. + +> (pause process) + + Suspends the execution of the given mztake + process. Use START/RESUME to resume execution. + +> (kill process) + + Kills the target process and releases all resources + it used -- you cannot START/RESUME after a KILL. + + Closing a FrTime animation/graphics window will *not* + kill a running MzTake process. If it does not terminate + on its own, you may kill it with "(kill p-name)" or + "(kill-all)" in the Interactions window. + +> (kill-all) + + kill-all kills all the processes currently running + under MzTake -- use this when it seems a process is + out of control and needs to be stopped immediately. + Has the same effect of calling KILL on each process + you defined and START/RESUME'd in the script. + +> (process:exceptions process) + + Returns an event stream. If the target process + throws an uncaught exception, the exception will + appear on this stream. + +> (process:runtime/seconds process) + + Returns a FrTime time-varying value which counts the + number of seconds elapsed in the execution of the + given process (not counting time spent suspended by + PAUSE). Includes garbage-collection time. + +> (process:runtime/milliseconds process) + + Returns a FrTime time-varying value which counts the + number of milliseconds elapsed in the execution of the + given process (not counting time spent suspended by + PAUSE). Includes garbage-collection time. + +> (process:exited? process) + + Return a time-varying Boolean value which becomes + true after the given MzTake process exited/killed. + + +_Useful Functions for Time-Varying Values_ + +Note: FrTime uses a naming convention where functions which + return behaviors have names that end in "-b", and + functions that return event streams end in "-e". + +Tips: When you have a behavior that you want to turn into + an event, use (changes behavior). + + When you have an event that you want to be a + behavior, use (hold event) + + +MzTake defines a few functions on time-varying values +that are particularly useful when debugging: + +> (history-e stream) +> (history-b stream) + + Keeps a complete history of all the values seen + on an event stream as a list, oldest events last. + + Use with BINDs: (history-b x-trace) + +> (history-e n stream) +> (history-b n stream) + + Keeps a list of the last n values of a behavior + Returns a list of at most n elements, where the + elements are the n last values seem on the stream, + in order, oldest first. + +> (count-b stream) + + Counts number of events seen on an eventstream. + + Often used directly on ENTRY traces, counting how many + times ENTRY occured: (count-b entry-trace) + + Also useful to count how many times a BIND changed + by calling: (count-b (changes bind-trace)) + +> (largest-val-b stream) +> (smallest-val-b stream) + + Keeps track of the largest/smallest values seen on a stream. + Use with BINDs: (largest-val-b (changes bind-trace)). + +> (sequence-match? seq stream) + + Matches a sequence of items in a list to the history + of event pings, on the event stream evs. Returns #t + when it matches, and #f otherwise. Use when you expect + a certain pattern to show up, and want to know when: + (sequence-match? '(0 1 2 1 0) (changes bind-trace)) + +> (printf-b format-string arg ...) + + Displays the value of the behaviors with the given format, + using "~a" just like in Scheme's FORMAT function. + + +============================================================ + +Known Problems + +* In general, you should not REQUIRE or use any methods + in your MzTake script that were defined in any of the files + you are putting bind-traces on: + + ORIGINAL FILE: + (define (my-fun some-struct) ...) + + MZTAKE SCRIPT: + (require "original-file.ss") + (define-mztake-process p ("original-file.ss" [val 10 12 bind 'my-struct])) + (my-fun (hold val)) + + Sometimes this causes unusual errors. These problems usually only + show up if you are binding to structs (defined in the same file) and + passing those bindings to functions (defined in the same file). + + You have been warned. + +* The break button will *not* kill runaway client processes. + You must type (kill process-name) or (kill-all). + +* Some legal syntax locations (used in setting trace points) + are unreachable during program execution (they do not get + triggered and produce empty eventstreams). So far, this only + shows up in LETs (the trace point being one line above, + and one character to the left of the carrot): + + (define x 12) + (let ([x (add1 x)]) x) + ^ ^^^ + Recommended syntax locations to use for trace points: + (define x 12) + (let ([x (add1 x)]) x) + ^ ^^ ^ ^ + +* Don't rely entirely on MzTake to complain when you change + target code and your line/col locations in the script are out + of date. It can only raise an error if the locations are invalid. + +* MzTake has not been tested for stability if the target is using + multiple threads. This only applies to threaded modules + *with* traces on them -- other REQUIRE'd modules will work + as expected. + +* Error handling is not perfect -- e.g., the little "bug" + buttons on syntax errors don't reference the correct code. + However, the messages that are printed are as accurate as + possible. + +* process:running? tells you if the process is currently, + actively, running. It might be useful to you, and will + be in the next release. + +* On particularly fast computers, when running scripts with a + very high trace point density (traces are hit constantly, + potentially hundreds in a second, like in the Monte Carlo, + random-xs, and sine demos), the FrTime animation window may + appear unresponsive because of how fast it is redrawing. + +* Currently, if you are running traces on two modules with the + same name, IN the same process, though in different directories, + there will probably be some sort of name-clash and strange error. + This will be fixed. + +* If you find that sometimes it seems one of the breakpoints you + set in a file REQUIRE'd by the main client module, your problem + may be that the file-specification you used is different in the + script than it is in the main client module (occuring in REQUIREs + that use sub-directories): + + MAIN CLIENT: + (require (lib "my-lib.ss" "mycollect" "private")) + + MZTAKE SCRIPT: + (define-mztake-process p ("main.ss") + ((lib "my-lib.ss" "mycollect/private") [traces...]) + + This seems to be an issue with DrScheme rather than MzTake. + For instance, you get an error if you make a module like this + on Windows: + + (module m mzscheme + (require (lib "my-lib.ss" "mycollect" "private")) + (provide (lib "my-lib.ss" "mycollect/private"))) + + This will be looked into, but keep your eyes open for it. + + +============================================================ + +Tips and Tricks + +* If output seems difficult to read in the script, e.g. you ever + see "struct:signal" and a lot of garbage, try (print-struct #f) + before you do any printing, or use (value-now behavior-name) to + get a more usable/printable version of a FrTime behavior (the + caveat is that it is no longer 'reactive' and it may be out of + date after the moment it is processed). + +* You may want to bind more than one variable at a certain point + so that you only get one change event -- otherwise, you will + get multiple change events even if at the same trace point + (see Known Problems). + + For instance, if you trace 'x and 'y separately: + * First 'x and 'y are up-to-date. + * Then 'x updates and 'y is out-of-date. + * Then 'y updates, and both are up-to-date. + + But code that draws using a position derived from X and Y + will draw twice, in two locations, one for each update, + the second one being correct. + +* Order matters -- if you have more than one trace at an identical + syntax location (in the same file), the order that trace events + get updated is identical to the order they exist in the script. + For example: + + (define-mztake-process p ("file.ss" [a-bind 5 55 bind 'x] + [some-bind 2 22 bind 'irrelevent] + [a-entry 5 55 entry] + [another-bind 5 55 bind 'y])) + + When that trace gets evaluated, A-BIND will get the new value + of X, and relevant FrTime code will get re-evaluated. *Then* + A-ENTRY will be notified about the trace and a #t will be emitted, + (at this point in time, Y is out-of-date, but X is up-to-date). Lastly, + ANOTHER-BIND will get the new value of Y, and the trace is complete. + + Of course, you will typically want ENTRY as the first trace, + and all other BINDs to be in a list, so that you get two updates, + as explained in the previous tip: + + (define-mztake-process p ("file.ss" [a-entry 5 55 entry] + [x/y-bind 5 55 bind '(x y)] + [some-bind 2 22 bind 'irrelevent])) + +* You can trace the *same* file in different ways by using + multiple processes on the same file, under different + contexts, and compare results. For example, in + "demos/misc/first-class-mztake.ss": + + (define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x] + [x-in-let 4 25 bind 'x] + [x-after-let 5 11 bind 'x])) + (... code omitted ...) + (start/resume p) + + is functionally equivalent to: + + (define-mztake-process p1 ("first-class.ss" [x-before-let 3 29 bind 'x])) + (define-mztake-process p2 ("first-class.ss" [x-in-let 4 25 bind 'x])) + (define-mztake-process p3 ("first-class.ss" [x-after-let 5 11 bind 'x])) + (... code omitted ...) + (start/resume p1) (start/resume p2) (start/resume p3) + + All the variable bindings can still be used as they were before. + +* Code such as (when (= num 100) (pause p)) pauses *after* + num reaches 100, the next time a trace point is hit. + However, the next point is not processed until you + START/RESUME. See the random-xs demo. + +* When you pause a MzTake process, you can play with + current bindings and explore script code interactively. + You *may* dynamically evaluate/add FrTime code to do + things like pause or kill a MzTake process based on runtime, + etc. You can even define new MzTake processes dynamically + and start/resume them, integrating and exploring the traces. + You cannot add or change existing traces dynamically. + +* You can add trace points to first-class functions, and they + will send trace update from anywhere they are passed to and + evaluated. + +* FrTime has two methods for drawing graphics. One runs in + constant time, and is fast, because it simply accumulates + pixels on the screen and doesn't redraw a list of objects. + See the "Monte Carlo" or "random-xs" demos for this in action. + + The other method is primarily for animations which need + redrawing because things move. It slows down pretty quickly + after you have more than 1000 objects to the shape list. + See the "sine" or "highway" demos for this in action. + + For more information, refer to the FrTime documentation. + + +============================================================ + +Authors and Thanks + +MzTake is an experimental debugger. It should enable new +debugging approaches that were not possible (easily) before. +Please send feedback to the PLT-Scheme mailing list: + http://www.plt-scheme.org/maillist/ + +We are eager to hear about how you are using MzTake! + + Jonathan Spiro + Guillaume Marceau + Gregory Cooper + John Clements + Shriram Krishnamurthi + + +Please send bug reports to: jspiro@cs.brown.edu + +--- +Icons for MzTake come from the Gnome Project: Nautilus Emblems. +These are provided under the GPL license. + http://jimmac.musichall.cz/ikony.php3 diff --git a/collects/mztake/info.ss b/collects/mztake/info.ss index 5724c38864..0e3c385aa0 100644 --- a/collects/mztake/info.ss +++ b/collects/mztake/info.ss @@ -1,7 +1,7 @@ -(module info (lib "infotab.ss" "setup") - (define name "Debugger") - (define tools '(("mztake-lang.ss") ("debug-tool.ss"))) - (define blurb '("MzTake is a scripted debugger for PLT Scheme." "A debugging tool for DrScheme")) - (define tool-names '("MzTake Debugger" "Skipper")) - (define tool-icons '(("emblem-ohno.png" "mztake" "icons") ("icon-big.png" "mztake" "icons"))) -) +(module info (lib "infotab.ss" "setup") + (define name "Debugger") + (define tools '(("mztake-lang.ss") ("debug-tool.ss"))) + (define blurb '("MzTake is a scripted debugger for PLT Scheme." "A debugging tool for DrScheme")) + (define tool-names '("MzTake Debugger" "Skipper")) + (define tool-icons '(("emblem-ohno.png" "mztake" "icons") ("icon-big.png" "mztake" "icons"))) +) diff --git a/collects/mztake/make-clean.bat b/collects/mztake/make-clean.bat old mode 100644 new mode 100755 index 19304b22bd..64baa10e4d --- a/collects/mztake/make-clean.bat +++ b/collects/mztake/make-clean.bat @@ -1,2 +1,2 @@ del compiled -del private\compiled \ No newline at end of file +del private\compiled diff --git a/collects/mztake/make-plt.ss b/collects/mztake/make-plt.ss index c789712a35..36d0fb059b 100644 --- a/collects/mztake/make-plt.ss +++ b/collects/mztake/make-plt.ss @@ -1,20 +1,20 @@ -(module make-plt mzscheme - - (require (lib "pack.ss" "setup") - #;(lib "util.ss" "planet")) - - (define (my-filter path) - (and (std-filter path) - (not (or (regexp-match #rx".svn$" path) - (regexp-match #rx".bak$" path) - (regexp-match #rx".1$" path) - (regexp-match #rx"-uncommented.ss$" path) - (regexp-match #rx"make" path))))) - - - ;without frtime bundled: - (pack-collections "mztake-208.plt" "MzTake Debugger" - '(("mztake")) #t '(("frtime")("stepper")) my-filter #f) - - (pack-collections "mztake-frtime-pre-208.plt" "MzTake Debugger" - '(("mztake")("frtime")) #t '(("stepper")) my-filter #f)) +(module make-plt mzscheme + + (require (lib "pack.ss" "setup") + #;(lib "util.ss" "planet")) + + (define (my-filter path) + (and (std-filter path) + (not (or (regexp-match #rx".svn$" path) + (regexp-match #rx".bak$" path) + (regexp-match #rx".1$" path) + (regexp-match #rx"-uncommented.ss$" path) + (regexp-match #rx"make" path))))) + + + ;without frtime bundled: + (pack-collections "mztake-208.plt" "MzTake Debugger" + '(("mztake")) #t '(("frtime")("stepper")) my-filter #f) + + (pack-collections "mztake-frtime-pre-208.plt" "MzTake Debugger" + '(("mztake")("frtime")) #t '(("stepper")) my-filter #f)) diff --git a/collects/mztake/make.bat b/collects/mztake/make.bat old mode 100644 new mode 100755 diff --git a/collects/mztake/mztake-lang.ss b/collects/mztake/mztake-lang.ss index 1be95b167a..1e45368333 100644 --- a/collects/mztake/mztake-lang.ss +++ b/collects/mztake/mztake-lang.ss @@ -1,142 +1,142 @@ -; ; -; ;; ;; ;;;;;;;;; ; ; -; ;; ;; ; ; ; -; ; ; ; ; ; ; ; -; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;; ; ;;;; ; ;;;; ;;;;;; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; -; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; -; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;; -; ; ; ;;;;;; ; ;;;; ; ; ; ;;;; ;;;;;;; ;;;; ; ; ; ;;;; ; -; ; -; ; ; -; ;;;; - -(module mztake-lang mzscheme - (require "mztake.ss" - (lib "etc.ss") - (lib "list.ss") - (lib "class.ss") - (lib "unitsig.ss") - (lib "bitmap-label.ss" "mrlib") - (lib "contract.ss") - (lib "mred.ss" "mred") - (lib "tool.ss" "drscheme") - (lib "framework.ss" "framework") - (lib "string-constant.ss" "string-constants")) - - (provide tool@) - - (define tool@ - (unit/sig drscheme:tool-exports^ - (import drscheme:tool^) - - ;############################MZTAKE LANGUAGE RELATED FUNCTIONS############################################## - (define (phase1) (void)) - (define (phase2) - (drscheme:language-configuration:add-language - (make-object ((drscheme:language:get-default-mixin) (make-mztake-language mztake-language%))))) - - (define (make-mztake-language base) - (class (drscheme:language:module-based-language->language-mixin - (drscheme:language:simple-module-based-language->module-based-language-mixin - base)) - (field (watch-list empty)) - (inherit get-language-position) - (define/override (on-execute settings run-in-user-thread) - (let ([drs-eventspace (current-eventspace)]) - (super on-execute settings run-in-user-thread) - (run-in-user-thread - (lambda () - (let ([new-watch (namespace-variable-value 'render)] - [set-evspc (namespace-variable-value 'set-eventspace)]) - (set-evspc drs-eventspace) - (set! watch-list - ((if (weak-member new-watch watch-list) - identity - (lambda (r) (cons (make-weak-box new-watch) r))) - (filter weak-box-value watch-list)))))))) - - (define/override (render-value/format value settings port width) - (super render-value/format (watch watch-list value) - settings port width)) - (define/override (render-value value settings port) - (super render-value (watch watch-list value) - settings port)) - (define/override (use-namespace-require/copy?) #t) - (super-instantiate ()))) - - - (define mztake-language% - (class* object% (drscheme:language:simple-module-based-language<%>) - (define/public (get-language-numbers) - '(1000 -400)) - (define/public (get-language-position) - (list (string-constant experimental-languages) "MzTake")) - (define/public (get-module) - '(lib "mztake-syntax.ss" "mztake")) - (define/public (get-one-line-summary) - (format "MzTake Debugger (~a)" mztake-version)) - (define/public (get-language-url) #f) - (define/public (get-reader) - (lambda (name port offsets) - (let ([v (read-syntax name port offsets)]) - (if (eof-object? v) - v - (namespace-syntax-introduce v))))) - (super-instantiate ()))) - - ;;;;;;;;;;;;;FRTIME REPL STUFF;;;;;;;;;;;;;;;;;;;;;; - (define (weak-member obj lis) - (let ([cmp (lambda (v) (eq? v obj))]) - (let loop ([lis lis]) - (and (cons? lis) - (or - (cond - [(weak-box-value (first lis)) => cmp] - [else false]) - (loop (rest lis))))))) - - (define (watch watch-list value) - (foldl - (lambda (wb acc) - (cond - [(weak-box-value wb) - => (lambda (f) (f acc))] - [else acc])) - value - watch-list)) - ;########################################################################################################### - - - (define debugger-bitmap - (bitmap-label-maker - "Syntax Location" - (build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png"))) - - (define (debugger-unit-frame-mixin super%) - (class super% - - (inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar) - - (super-instantiate ()) - - (define debugger-button - (make-object button% - (debugger-bitmap this) - (get-button-panel) - (lambda (button evt) - (let* ([pos (send (get-definitions-text) get-start-position)] - [line (send (get-definitions-text) position-paragraph pos)] - [column (- pos (send (get-definitions-text) line-start-position - (send (get-definitions-text) position-line pos)))]) - - (message-box "Syntax Location" - (format "Line: ~a~nColumn: ~a" (add1 line) column)))))) - (send (get-button-panel) change-children - (lambda (_) (cons debugger-button (remq debugger-button _)))))) - +; ; +; ;; ;; ;;;;;;;;; ; ; +; ;; ;; ; ; ; +; ; ; ; ; ; ; ; +; ; ; ; ; ;;;;;; ; ;;;; ; ; ;;; ; ;;;; ; ;;;; ;;;;;; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ;;;;; ; ; ; ; ; ;;;;; ; ; ; ; +; ; ; ; ; ; ; ; ; ;;; ;;;;;;; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ;; +; ; ; ;;;;;; ; ;;;; ; ; ; ;;;; ;;;;;;; ;;;; ; ; ; ;;;; ; +; ; +; ; ; +; ;;;; + +(module mztake-lang mzscheme + (require "mztake.ss" + (lib "etc.ss") + (lib "list.ss") + (lib "class.ss") + (lib "unitsig.ss") + (lib "bitmap-label.ss" "mrlib") + (lib "contract.ss") + (lib "mred.ss" "mred") + (lib "tool.ss" "drscheme") + (lib "framework.ss" "framework") + (lib "string-constant.ss" "string-constants")) + + (provide tool@) + + (define tool@ + (unit/sig drscheme:tool-exports^ + (import drscheme:tool^) + + ;############################MZTAKE LANGUAGE RELATED FUNCTIONS############################################## + (define (phase1) (void)) + (define (phase2) + (drscheme:language-configuration:add-language + (make-object ((drscheme:language:get-default-mixin) (make-mztake-language mztake-language%))))) + + (define (make-mztake-language base) + (class (drscheme:language:module-based-language->language-mixin + (drscheme:language:simple-module-based-language->module-based-language-mixin + base)) + (field (watch-list empty)) + (inherit get-language-position) + (define/override (on-execute settings run-in-user-thread) + (let ([drs-eventspace (current-eventspace)]) + (super on-execute settings run-in-user-thread) + (run-in-user-thread + (lambda () + (let ([new-watch (namespace-variable-value 'render)] + [set-evspc (namespace-variable-value 'set-eventspace)]) + (set-evspc drs-eventspace) + (set! watch-list + ((if (weak-member new-watch watch-list) + identity + (lambda (r) (cons (make-weak-box new-watch) r))) + (filter weak-box-value watch-list)))))))) + + (define/override (render-value/format value settings port width) + (super render-value/format (watch watch-list value) + settings port width)) + (define/override (render-value value settings port) + (super render-value (watch watch-list value) + settings port)) + (define/override (use-namespace-require/copy?) #t) + (super-instantiate ()))) + + + (define mztake-language% + (class* object% (drscheme:language:simple-module-based-language<%>) + (define/public (get-language-numbers) + '(1000 -400)) + (define/public (get-language-position) + (list (string-constant experimental-languages) "MzTake")) + (define/public (get-module) + '(lib "mztake-syntax.ss" "mztake")) + (define/public (get-one-line-summary) + (format "MzTake Debugger (~a)" mztake-version)) + (define/public (get-language-url) #f) + (define/public (get-reader) + (lambda (name port offsets) + (let ([v (read-syntax name port offsets)]) + (if (eof-object? v) + v + (namespace-syntax-introduce v))))) + (super-instantiate ()))) + + ;;;;;;;;;;;;;FRTIME REPL STUFF;;;;;;;;;;;;;;;;;;;;;; + (define (weak-member obj lis) + (let ([cmp (lambda (v) (eq? v obj))]) + (let loop ([lis lis]) + (and (cons? lis) + (or + (cond + [(weak-box-value (first lis)) => cmp] + [else false]) + (loop (rest lis))))))) + + (define (watch watch-list value) + (foldl + (lambda (wb acc) + (cond + [(weak-box-value wb) + => (lambda (f) (f acc))] + [else acc])) + value + watch-list)) + ;########################################################################################################### + + + (define debugger-bitmap + (bitmap-label-maker + "Syntax Location" + (build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png"))) + + (define (debugger-unit-frame-mixin super%) + (class super% + + (inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar) + + (super-instantiate ()) + + (define debugger-button + (make-object button% + (debugger-bitmap this) + (get-button-panel) + (lambda (button evt) + (let* ([pos (send (get-definitions-text) get-start-position)] + [line (send (get-definitions-text) position-paragraph pos)] + [column (- pos (send (get-definitions-text) line-start-position + (send (get-definitions-text) position-line pos)))]) + + (message-box "Syntax Location" + (format "Line: ~a~nColumn: ~a" (add1 line) column)))))) + (send (get-button-panel) change-children + (lambda (_) (cons debugger-button (remq debugger-button _)))))) + (drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin)))) \ No newline at end of file diff --git a/collects/mztake/mztake-structs.ss b/collects/mztake/mztake-structs.ss index da3af20f7f..9ab412a550 100644 --- a/collects/mztake/mztake-structs.ss +++ b/collects/mztake/mztake-structs.ss @@ -1,71 +1,71 @@ -(module mztake-structs mzscheme - (require (prefix frp: (lib "frp.ss" "frtime")) - (lib "more-useful-code.ss" "mztake" "private")) - - (provide (all-defined-except loc make-loc) - (rename loc loc$) - (rename make-loc loc)) - - ; ;;;;; ; ; - ; ; ; ; ; - ; ; ; ; - ; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;; - ; ; ; ;; ; ; ; ; ; ; ; - ; ;;; ; ; ; ; ; ; ; - ; ;;; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ;; ; ; ; ; ; - ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;; - - (define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver - - (define-struct debug-client (modpath ; complete-path of the module - tracepoints ; hash-table of traces - line-col->pos ; memoized O(n) function to map line/col -> byte offset - process)) ; parent debug-process - - (define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process - run-semaphore ; When you post to this the debuggee will continue executing - running-e ; Is the program (supposed-to-be) currently running - run-manager ; saves behavior that actually pauses/resumes from GC - pause-requested? - resume-requested? - - exited? ; FrTime cell receives #t when the target exits - exceptions ; (an event stream) Exceptions thrown during the evaluation of the target - main-client ; the main client module that will be run - clients ; list of all the clients attached to this process - - where ; a behavior signaling each position where we pause - marks)) ; while paused, the marks at the point of the pause (else false) - - (define-struct loc (modpath line col)) - - ;########################################################################################################### - - - - - ; ;;;;; ; ; ;;;;; ; - ; ; ; ; ; ;; ; ; - ; ; ; ; ; ; - ; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;; - ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; - ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; - ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;; - - (define (create-empty-debug-client) - (make-debug-client null ; modpath - (make-hash) ; tracepoints - null ; line-col->pos function - null)) ; process - - ;########################################################################################################### +(module mztake-structs mzscheme + (require (prefix frp: (lib "frp.ss" "frtime")) + (lib "more-useful-code.ss" "mztake" "private")) + + (provide (all-defined-except loc make-loc) + (rename loc loc$) + (rename make-loc loc)) + + ; ;;;;; ; ; + ; ; ; ; ; + ; ; ; ; + ; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;; + ; ; ; ;; ; ; ; ; ; ; ; + ; ;;; ; ; ; ; ; ; ; + ; ;;; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ;;;; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ;; ; ; ; ; ; + ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;; + + (define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver + + (define-struct debug-client (modpath ; complete-path of the module + tracepoints ; hash-table of traces + line-col->pos ; memoized O(n) function to map line/col -> byte offset + process)) ; parent debug-process + + (define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger process + run-semaphore ; When you post to this the debuggee will continue executing + running-e ; Is the program (supposed-to-be) currently running + run-manager ; saves behavior that actually pauses/resumes from GC + pause-requested? + resume-requested? + + exited? ; FrTime cell receives #t when the target exits + exceptions ; (an event stream) Exceptions thrown during the evaluation of the target + main-client ; the main client module that will be run + clients ; list of all the clients attached to this process + + where ; a behavior signaling each position where we pause + marks)) ; while paused, the marks at the point of the pause (else false) + + (define-struct loc (modpath line col)) + + ;########################################################################################################### + + + + + ; ;;;;; ; ; ;;;;; ; + ; ; ; ; ; ;; ; ; + ; ; ; ; ; ; + ; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;; + ; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; + ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; + ; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; + ; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;; + + (define (create-empty-debug-client) + (make-debug-client null ; modpath + (make-hash) ; tracepoints + null ; line-col->pos function + null)) ; process + + ;########################################################################################################### ) \ No newline at end of file diff --git a/collects/mztake/private/load-annotator.ss b/collects/mztake/private/load-annotator.ss index b44ea1b915..94aa5a77ac 100644 --- a/collects/mztake/private/load-annotator.ss +++ b/collects/mztake/private/load-annotator.ss @@ -1,108 +1,108 @@ -(module load-annotator mzscheme - - (require (lib "moddep.ss" "syntax") - (lib "class.ss" "mzlib") - (lib "mred.ss" "mred")) - - (provide eval/annotations - require/annotations - require/sandbox+annotations - load-module/annotate) - - #|load-with-annotations : - - >initial-module : (union (listof symbol?) string?) - Takes in a require spec -- "../file.ss", (file "complete-path.ss"), (lib ...), etc - In other words - - pass it a relative filename or a quoted lib to require - "mztake.ss" or '(lib "mztake.ss" "mztake") - - >annotate-module? : (string? symbol? . -> . boolean) - (filename module-name) - If true, loads source file and annotates. - Else, tries to load compiled or source, no annotation. - - >annotator : (string? symbol? syntax? . -> . syntax?) -|# - - (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) - (parameterize ([current-custodian custodian] - [current-namespace (make-namespace-with-mred)] - [error-display-handler err-display-handler]) - (require/annotations initial-module annotate-module? annotator))) - - - (define (require/annotations initial-module annotate-module? annotator) - (eval/annotations #`(require #,initial-module) annotate-module? annotator)) - - (define (eval/annotations stx annotate-module? annotator) - (parameterize - ([current-load/use-compiled - (let ([ocload/use-compiled (current-load/use-compiled)]) - (lambda (fn m) - (cond [(annotate-module? fn m) - (load-module/annotate annotator fn m)] - [else - (ocload/use-compiled fn m)])))]) - (eval-syntax (annotator stx)))) - - (define (load-module/annotate annotator fn m) - (let-values ([(base _ __) (split-path fn)] - [(in-port src) (build-input-port fn)]) - (dynamic-wind - (lambda () (void)) - - (lambda () - (parameterize ([read-accept-compiled #f] - [current-load-relative-directory base]) - (unless m (raise 'module-name-not-passed-to-load-module/annotate)) - (with-module-reading-parameterization - (lambda () - (let* ([first (expand (read-syntax src in-port))] - [module-ized-exp (annotator (check-module-form first m fn))] - [second (read in-port)]) - (unless (eof-object? second) - (raise-syntax-error - 'load-module/annotate - (format "expected only a `module' declaration for `~s', but found an extra expression" m) - second)) - (eval module-ized-exp)))))) - - (lambda () (close-input-port in-port))))) - - - - ; taken directly from mred.ss -- it's not exported... - (define (build-input-port filename) - (let ([p (open-input-file filename)]) - (port-count-lines! p) - (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p) - (let ([t (make-object text%)]) - (send t insert-file p 'standard) - (close-input-port p) - (open-input-text-editor t))] - [else p])]) - (port-count-lines! p) - (let loop () - (when (with-handlers ([exn:fail? (lambda (x) #f)]) - (regexp-match-peek "^#!" p)) - (let lloop ([prev #f]) - (let ([c (read-char-or-special p)]) - (if (or (eof-object? c) - (eq? c #\return) - (eq? c #\newline)) - (when (eq? prev #\\) - (loop)) - (lloop c)))))) - (values p filename)))) - - - (define (test annotate-all?) - (require/annotations '(lib "mztake.ss" "mztake") - (lambda (fn m) - (printf "~a ~a~n" fn m) - annotate-all?) - (lambda (fn m stx) stx))) - ;(test #t) ; slow - ;(test #f) ; fast +(module load-annotator mzscheme + + (require (lib "moddep.ss" "syntax") + (lib "class.ss" "mzlib") + (lib "mred.ss" "mred")) + + (provide eval/annotations + require/annotations + require/sandbox+annotations + load-module/annotate) + + #|load-with-annotations : + + >initial-module : (union (listof symbol?) string?) + Takes in a require spec -- "../file.ss", (file "complete-path.ss"), (lib ...), etc + In other words - + pass it a relative filename or a quoted lib to require + "mztake.ss" or '(lib "mztake.ss" "mztake") + + >annotate-module? : (string? symbol? . -> . boolean) + (filename module-name) + If true, loads source file and annotates. + Else, tries to load compiled or source, no annotation. + + >annotator : (string? symbol? syntax? . -> . syntax?) +|# + + (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator) + (parameterize ([current-custodian custodian] + [current-namespace (make-namespace-with-mred)] + [error-display-handler err-display-handler]) + (require/annotations initial-module annotate-module? annotator))) + + + (define (require/annotations initial-module annotate-module? annotator) + (eval/annotations #`(require #,initial-module) annotate-module? annotator)) + + (define (eval/annotations stx annotate-module? annotator) + (parameterize + ([current-load/use-compiled + (let ([ocload/use-compiled (current-load/use-compiled)]) + (lambda (fn m) + (cond [(annotate-module? fn m) + (load-module/annotate annotator fn m)] + [else + (ocload/use-compiled fn m)])))]) + (eval-syntax (annotator stx)))) + + (define (load-module/annotate annotator fn m) + (let-values ([(base _ __) (split-path fn)] + [(in-port src) (build-input-port fn)]) + (dynamic-wind + (lambda () (void)) + + (lambda () + (parameterize ([read-accept-compiled #f] + [current-load-relative-directory base]) + (unless m (raise 'module-name-not-passed-to-load-module/annotate)) + (with-module-reading-parameterization + (lambda () + (let* ([first (expand (read-syntax src in-port))] + [module-ized-exp (annotator (check-module-form first m fn))] + [second (read in-port)]) + (unless (eof-object? second) + (raise-syntax-error + 'load-module/annotate + (format "expected only a `module' declaration for `~s', but found an extra expression" m) + second)) + (eval module-ized-exp)))))) + + (lambda () (close-input-port in-port))))) + + + + ; taken directly from mred.ss -- it's not exported... + (define (build-input-port filename) + (let ([p (open-input-file filename)]) + (port-count-lines! p) + (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p) + (let ([t (make-object text%)]) + (send t insert-file p 'standard) + (close-input-port p) + (open-input-text-editor t))] + [else p])]) + (port-count-lines! p) + (let loop () + (when (with-handlers ([exn:fail? (lambda (x) #f)]) + (regexp-match-peek "^#!" p)) + (let lloop ([prev #f]) + (let ([c (read-char-or-special p)]) + (if (or (eof-object? c) + (eq? c #\return) + (eq? c #\newline)) + (when (eq? prev #\\) + (loop)) + (lloop c)))))) + (values p filename)))) + + + (define (test annotate-all?) + (require/annotations '(lib "mztake.ss" "mztake") + (lambda (fn m) + (printf "~a ~a~n" fn m) + annotate-all?) + (lambda (fn m stx) stx))) + ;(test #t) ; slow + ;(test #f) ; fast ) \ No newline at end of file diff --git a/collects/mztake/private/more-useful-code.ss b/collects/mztake/private/more-useful-code.ss index df90ad45aa..dbf9bb6f14 100644 --- a/collects/mztake/private/more-useful-code.ss +++ b/collects/mztake/private/more-useful-code.ss @@ -1,292 +1,292 @@ -(module more-useful-code mzscheme - (require (lib "list.ss") - (lib "pretty.ss") - (lib "etc.ss")) - - (provide assert - cons-to-end - assoc-get - debug - make-to-string - make-debug - to-string - member-eq? - string->char - last - member-str? - quicksort-vector! - struct->list/deep - make-for-each - begin0/rtn - with-handlers/finally - pretty-print-syntax - with-semaphore - - 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! - - (all-from (lib "list.ss")) - (all-from (lib "etc.ss"))) - - (define-struct (exn:assert exn) ()) - - (define-syntax (assert stx) - (syntax-case stx () - [(src-assert bool) #'(src-assert bool "")] - [(src-assert bool msg ...) - (with-syntax ([src-text (datum->syntax-object - (syntax src-assert) - (format "~a:~a:~a: assertion failed: " - (syntax-source (syntax bool)) - (syntax-line (syntax bool)) - (syntax-column (syntax bool))))]) - #'(unless bool - (raise (make-exn:assert (apply string-append - (cons src-text - (map (lambda (item) - (string-append (to-string item) " ")) - (list msg ...)))) - (current-continuation-marks)))))])) - - (define-syntax (begin0/rtn stx) - (syntax-case stx () - [(begin0/rtn body bodies ...) - (with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)]) - (syntax (let ([rtn body]) bodies ... rtn)))])) - - (define-syntax with-handlers/finally - (syntax-rules () - [(_ (handler ...) body finally) - (let ([finally-fn (lambda () finally)]) - (begin0 - (with-handlers - (handler ... - [(lambda (exn) #t) - (lambda (exn) (finally-fn) (raise exn))]) - body) - (finally-fn)))])) - - (define (make-for-each . iterator-fns) - (lambda (obj fn) - (cond ((list? obj) (for-each fn obj)) - ((vector? obj) (let loop ((x 0)) - (if (< x (vector-length obj)) - (begin (fn (vector-ref obj x)) (loop (+ x 1)))))) - ((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key)))) - (true (let loop ((cur iterator-fns)) - (if (empty? cur) - (if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj) - (error "for-each: no iterator for value:" obj)) - (or ((first cur) obj fn) - (loop (rest cur))))))))) - - - (define (quicksort-vector! v less-than) - (let ([count (vector-length v)]) - (let loop ([min 0][max count]) - (if (< min (sub1 max)) - (let ([pval (vector-ref v min)]) - (let pivot-loop ([pivot min] - [pos (add1 min)]) - (if (< pos max) - (let ([cval (vector-ref v pos)]) - (if (less-than cval pval) - (begin - (vector-set! v pos (vector-ref v pivot)) - (vector-set! v pivot cval) - (pivot-loop (add1 pivot) (add1 pos))) - (pivot-loop pivot (add1 pos)))) - (if (= min pivot) - (loop (add1 pivot) max) - (begin - (loop min pivot) - (loop pivot max))))))))) - v) - - - - (define (member-str? s ls) - (cond - ((empty? ls) false) - ((string=? s (first ls)) true) - (else (member-str? s (rest ls))))) - - (define (last ls) - (cond - ((empty? ls) (error "took a last but it was emptry")) - ((empty? (rest ls)) (first ls)) - (else (last (rest ls))))) - - (define (string->char s) - (first (string->list s))) - - (define (member-eq? x ls) - (not (empty? (filter (lambda (y) (eq? x y)) ls)))) - - (define (to-string arg . extra-printers) - (let ([on-stack-ids (make-hash)] - [used-ids (make-hash)] - [free-id 0]) - (let loop ((arg arg)) - (if (hash-mem? on-stack-ids arg) - (begin - (hash-put! used-ids arg true) - (format "#~a#" (hash-get on-stack-ids arg))) - (let ([my-id free-id]) - (hash-put! on-stack-ids arg my-id) - (set! free-id (add1 free-id)) - (let ([result - (or - (let printer-loop ([printers extra-printers]) - (if (empty? printers) - false - (or (if (procedure-arity-includes? (car printers) 2) - ((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers)))) - ((car printers) arg)) - (printer-loop (cdr printers))))) - (cond - [(not arg) "#f"] - [(void? arg) "#"] - [(eq? arg #t) "#t"] - [(char? arg) (list->string (list arg))] - [(string? arg) (format "\"~a\"" arg)] - [(symbol? arg) (symbol->string arg)] - [(number? arg) (number->string arg)] - [(vector? arg) (string-append "#" (loop (vector->list arg)))] - [(box? arg) (string-append "#&" (loop (unbox arg)))] - [(empty? arg) "empty"] - [(list? arg) - (apply - string-append - `("(" ,@(cons (loop (first arg)) - (map (lambda (item) (string-append " " (loop item))) (rest arg))) - ")"))] - [(cons? arg) (format "(~a . ~a)" - (loop (first arg)) - (loop (rest arg)))] - - [(hash-table? arg) - (apply - string-append - `("[hash:" - ,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg)) - "]"))] - - [(syntax? arg) - (format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))] - - [(struct? arg) - (let ([as-list (vector->list (struct->vector arg))]) - (apply - string-append - `("[" ,@(cons (loop (first as-list)) - (map (lambda (item) (string-append " " (loop item))) - (rest as-list))) "]")))] - - [else - (format "~a" arg)]))]) - (hash-remove! on-stack-ids arg) - (if (hash-mem? used-ids arg) - (format "#~a=~a" my-id result) - result))))))) - - ;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string])))) - ;; The printers have to take two arguments: the item to converts and the to-string function for subitems - (define (make-debug to-string-fn) - (lambda args - (for-each (lambda (x) - (display (if (string? x) x (to-string-fn x))) - (display " ")) - args) - (newline))) - - (define debug (make-debug to-string)) - - (define (make-to-string predicate-printer-pairs) - (let ([printers (map (lambda (pair) (lambda (arg printer) - (cond [(not ((first pair) arg)) false] - [(procedure-arity-includes? (second pair) 2) - ((second pair) arg printer)] - [else ((second pair) arg)]))) - predicate-printer-pairs)]) - (case-lambda - [(arg) (apply to-string arg printers)] - [(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))]))) - - (define (assoc-get label ls) - (cond - ((empty? ls) (error (string-append "failed to find " (to-string label)))) - ((eq? label (first (first ls))) - (first ls)) - (else (assoc-get label (rest ls))))) - - (define (cons-to-end a ls) - (cond - ((empty? ls) (cons a ls)) - (else (cons (first ls) - (cons-to-end a (rest ls)))))) - - (define (struct->list/deep item) - (cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))] - [(list? item) (map struct->list/deep item)] - [(vector? item) (list->vector (map struct->list/deep (vector->list item)))] - [else item])) - - (define (struct-name s) (vector-ref (struct->vector s) 0)) - - (define (pretty-print-syntax width stx) - (pretty-print-columns width) - (pretty-print (syntax-object->datum stx))) - - (define (with-semaphore sem proc) - (semaphore-wait sem) - (let ([result (proc)]) - (semaphore-post sem) - result)) - - (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)))) +(module more-useful-code mzscheme + (require (lib "list.ss") + (lib "pretty.ss") + (lib "etc.ss")) + + (provide assert + cons-to-end + assoc-get + debug + make-to-string + make-debug + to-string + member-eq? + string->char + last + member-str? + quicksort-vector! + struct->list/deep + make-for-each + begin0/rtn + with-handlers/finally + pretty-print-syntax + with-semaphore + + 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! + + (all-from (lib "list.ss")) + (all-from (lib "etc.ss"))) + + (define-struct (exn:assert exn) ()) + + (define-syntax (assert stx) + (syntax-case stx () + [(src-assert bool) #'(src-assert bool "")] + [(src-assert bool msg ...) + (with-syntax ([src-text (datum->syntax-object + (syntax src-assert) + (format "~a:~a:~a: assertion failed: " + (syntax-source (syntax bool)) + (syntax-line (syntax bool)) + (syntax-column (syntax bool))))]) + #'(unless bool + (raise (make-exn:assert (apply string-append + (cons src-text + (map (lambda (item) + (string-append (to-string item) " ")) + (list msg ...)))) + (current-continuation-marks)))))])) + + (define-syntax (begin0/rtn stx) + (syntax-case stx () + [(begin0/rtn body bodies ...) + (with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)]) + (syntax (let ([rtn body]) bodies ... rtn)))])) + + (define-syntax with-handlers/finally + (syntax-rules () + [(_ (handler ...) body finally) + (let ([finally-fn (lambda () finally)]) + (begin0 + (with-handlers + (handler ... + [(lambda (exn) #t) + (lambda (exn) (finally-fn) (raise exn))]) + body) + (finally-fn)))])) + + (define (make-for-each . iterator-fns) + (lambda (obj fn) + (cond ((list? obj) (for-each fn obj)) + ((vector? obj) (let loop ((x 0)) + (if (< x (vector-length obj)) + (begin (fn (vector-ref obj x)) (loop (+ x 1)))))) + ((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key)))) + (true (let loop ((cur iterator-fns)) + (if (empty? cur) + (if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj) + (error "for-each: no iterator for value:" obj)) + (or ((first cur) obj fn) + (loop (rest cur))))))))) + + + (define (quicksort-vector! v less-than) + (let ([count (vector-length v)]) + (let loop ([min 0][max count]) + (if (< min (sub1 max)) + (let ([pval (vector-ref v min)]) + (let pivot-loop ([pivot min] + [pos (add1 min)]) + (if (< pos max) + (let ([cval (vector-ref v pos)]) + (if (less-than cval pval) + (begin + (vector-set! v pos (vector-ref v pivot)) + (vector-set! v pivot cval) + (pivot-loop (add1 pivot) (add1 pos))) + (pivot-loop pivot (add1 pos)))) + (if (= min pivot) + (loop (add1 pivot) max) + (begin + (loop min pivot) + (loop pivot max))))))))) + v) + + + + (define (member-str? s ls) + (cond + ((empty? ls) false) + ((string=? s (first ls)) true) + (else (member-str? s (rest ls))))) + + (define (last ls) + (cond + ((empty? ls) (error "took a last but it was emptry")) + ((empty? (rest ls)) (first ls)) + (else (last (rest ls))))) + + (define (string->char s) + (first (string->list s))) + + (define (member-eq? x ls) + (not (empty? (filter (lambda (y) (eq? x y)) ls)))) + + (define (to-string arg . extra-printers) + (let ([on-stack-ids (make-hash)] + [used-ids (make-hash)] + [free-id 0]) + (let loop ((arg arg)) + (if (hash-mem? on-stack-ids arg) + (begin + (hash-put! used-ids arg true) + (format "#~a#" (hash-get on-stack-ids arg))) + (let ([my-id free-id]) + (hash-put! on-stack-ids arg my-id) + (set! free-id (add1 free-id)) + (let ([result + (or + (let printer-loop ([printers extra-printers]) + (if (empty? printers) + false + (or (if (procedure-arity-includes? (car printers) 2) + ((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers)))) + ((car printers) arg)) + (printer-loop (cdr printers))))) + (cond + [(not arg) "#f"] + [(void? arg) "#"] + [(eq? arg #t) "#t"] + [(char? arg) (list->string (list arg))] + [(string? arg) (format "\"~a\"" arg)] + [(symbol? arg) (symbol->string arg)] + [(number? arg) (number->string arg)] + [(vector? arg) (string-append "#" (loop (vector->list arg)))] + [(box? arg) (string-append "#&" (loop (unbox arg)))] + [(empty? arg) "empty"] + [(list? arg) + (apply + string-append + `("(" ,@(cons (loop (first arg)) + (map (lambda (item) (string-append " " (loop item))) (rest arg))) + ")"))] + [(cons? arg) (format "(~a . ~a)" + (loop (first arg)) + (loop (rest arg)))] + + [(hash-table? arg) + (apply + string-append + `("[hash:" + ,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg)) + "]"))] + + [(syntax? arg) + (format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))] + + [(struct? arg) + (let ([as-list (vector->list (struct->vector arg))]) + (apply + string-append + `("[" ,@(cons (loop (first as-list)) + (map (lambda (item) (string-append " " (loop item))) + (rest as-list))) "]")))] + + [else + (format "~a" arg)]))]) + (hash-remove! on-stack-ids arg) + (if (hash-mem? used-ids arg) + (format "#~a=~a" my-id result) + result))))))) + + ;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string])))) + ;; The printers have to take two arguments: the item to converts and the to-string function for subitems + (define (make-debug to-string-fn) + (lambda args + (for-each (lambda (x) + (display (if (string? x) x (to-string-fn x))) + (display " ")) + args) + (newline))) + + (define debug (make-debug to-string)) + + (define (make-to-string predicate-printer-pairs) + (let ([printers (map (lambda (pair) (lambda (arg printer) + (cond [(not ((first pair) arg)) false] + [(procedure-arity-includes? (second pair) 2) + ((second pair) arg printer)] + [else ((second pair) arg)]))) + predicate-printer-pairs)]) + (case-lambda + [(arg) (apply to-string arg printers)] + [(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))]))) + + (define (assoc-get label ls) + (cond + ((empty? ls) (error (string-append "failed to find " (to-string label)))) + ((eq? label (first (first ls))) + (first ls)) + (else (assoc-get label (rest ls))))) + + (define (cons-to-end a ls) + (cond + ((empty? ls) (cons a ls)) + (else (cons (first ls) + (cons-to-end a (rest ls)))))) + + (define (struct->list/deep item) + (cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))] + [(list? item) (map struct->list/deep item)] + [(vector? item) (list->vector (map struct->list/deep (vector->list item)))] + [else item])) + + (define (struct-name s) (vector-ref (struct->vector s) 0)) + + (define (pretty-print-syntax width stx) + (pretty-print-columns width) + (pretty-print (syntax-object->datum stx))) + + (define (with-semaphore sem proc) + (semaphore-wait sem) + (let ([result (proc)]) + (semaphore-post sem) + result)) + + (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/private/useful-code.ss b/collects/mztake/private/useful-code.ss index a4e40cabbb..169f86154b 100644 --- a/collects/mztake/private/useful-code.ss +++ b/collects/mztake/private/useful-code.ss @@ -1,66 +1,66 @@ -(module useful-code (lib "frtime.ss" "frtime") - - (require (lib "string.ss") - (lib "contract.ss") - (lib "list.ss")) - - (provide (all-defined)) - - ; Everything is contracted to 'any' for speed benefits, though there is already a big performance hit - - ; Keeps a list of the last n values of a behavior - (define/contract history-e (case-> (number? event? . -> . any) - (event? . -> . any)) - (case-lambda [(stream) - (define ((add-to-complete-hist x) hist) (append hist (list x))) - (accum-e (stream . ==> . add-to-complete-hist) empty)] - - [(n stream) - (define ((add-to-short-hist x) hist) (append (if (< (length hist) n) hist (rest hist)) (list x))) - (accum-e (stream . ==> . add-to-short-hist) empty)])) - - (define/contract history-b (case-> (number? event? . -> . any) - (event? . -> . any)) - (case-lambda [(stream) (hold (history-e stream) empty)] - [(n stream) (hold (history-e n stream) empty)])) - - ; Counts number of events on an event stream - (define/contract count-b (event? . -> . any) - (lambda (stream) - (hold (accum-e (stream . -=> . add1) 0) 0))) - - ; Keeps track of the largest value seen on a stream - (define/contract largest-val-b (event? . -> . any) - (lambda (stream) - (hold (accum-e (stream - . ==> . - (lambda (last) - (lambda (x) - (if (> x last) x last)))) - -inf.0)))) - - ; Keeps track of the smallest value seen on a stream - (define/contract smallest-val-b (event? . -> . any) - (lambda (stream) - (hold (accum-e (stream - . ==> . - (lambda (last) - (lambda (x) - (if (< x last) x last)))) - +inf.0)))) - - ; Matches a sequence of items in a list to event pings - (define/contract sequence-match? ((listof any/c) . -> . any) - (lambda (seq evs) - (equal? seq (history-b (length seq) evs)))) - - ; Cheap printf for behaviors - (define printf-b format) - - ; Flattens a list - (define (flatten x) - (cond ((empty? x) '()) - ((and (list? x) - (list? (first x))) - (append (flatten (car x)) (flatten (cdr x)))) +(module useful-code (lib "frtime.ss" "frtime") + + (require (lib "string.ss") + (lib "contract.ss") + (lib "list.ss")) + + (provide (all-defined)) + + ; Everything is contracted to 'any' for speed benefits, though there is already a big performance hit + + ; Keeps a list of the last n values of a behavior + (define/contract history-e (case-> (number? event? . -> . any) + (event? . -> . any)) + (case-lambda [(stream) + (define ((add-to-complete-hist x) hist) (append hist (list x))) + (accum-e (stream . ==> . add-to-complete-hist) empty)] + + [(n stream) + (define ((add-to-short-hist x) hist) (append (if (< (length hist) n) hist (rest hist)) (list x))) + (accum-e (stream . ==> . add-to-short-hist) empty)])) + + (define/contract history-b (case-> (number? event? . -> . any) + (event? . -> . any)) + (case-lambda [(stream) (hold (history-e stream) empty)] + [(n stream) (hold (history-e n stream) empty)])) + + ; Counts number of events on an event stream + (define/contract count-b (event? . -> . any) + (lambda (stream) + (hold (accum-e (stream . -=> . add1) 0) 0))) + + ; Keeps track of the largest value seen on a stream + (define/contract largest-val-b (event? . -> . any) + (lambda (stream) + (hold (accum-e (stream + . ==> . + (lambda (last) + (lambda (x) + (if (> x last) x last)))) + -inf.0)))) + + ; Keeps track of the smallest value seen on a stream + (define/contract smallest-val-b (event? . -> . any) + (lambda (stream) + (hold (accum-e (stream + . ==> . + (lambda (last) + (lambda (x) + (if (< x last) x last)))) + +inf.0)))) + + ; Matches a sequence of items in a list to event pings + (define/contract sequence-match? ((listof any/c) . -> . any) + (lambda (seq evs) + (equal? seq (history-b (length seq) evs)))) + + ; Cheap printf for behaviors + (define printf-b format) + + ; Flattens a list + (define (flatten x) + (cond ((empty? x) '()) + ((and (list? x) + (list? (first x))) + (append (flatten (car x)) (flatten (cdr x)))) (else (list x))))) \ No newline at end of file