From 94cc1c3b7247d8cbf70bb2bd89687ad0cf1f01f4 Mon Sep 17 00:00:00 2001 From: Jono Spiro Date: Wed, 4 Aug 2004 10:20:23 +0000 Subject: [PATCH] fixed a subtle bug in annotator? in the debugger-model -- it was using eq? instead of equal? added (though it is broken) the dijkstra demo updated the heap.ss file for frtime -- greg needs a copy of this. added history-e svn: r137 --- collects/mztake/debugger-model.ss | 2 +- .../mztake/demos/dijkstra/dijkstra-solver.ss | 49 ++ .../mztake/demos/dijkstra/dijkstra-test.ss | 40 ++ collects/mztake/demos/dijkstra/dijkstra.ss | 40 ++ collects/mztake/demos/dijkstra/graph.ss | 543 ++++++++++++++++++ collects/mztake/doc.txt | 6 +- collects/mztake/mztake.ss | 2 +- collects/mztake/private/useful-code.ss | 5 +- 8 files changed, 683 insertions(+), 4 deletions(-) create mode 100644 collects/mztake/demos/dijkstra/dijkstra-solver.ss create mode 100644 collects/mztake/demos/dijkstra/dijkstra-test.ss create mode 100644 collects/mztake/demos/dijkstra/dijkstra.ss create mode 100644 collects/mztake/demos/dijkstra/graph.ss diff --git a/collects/mztake/debugger-model.ss b/collects/mztake/debugger-model.ss index 2c3160ed49..02174145d2 100644 --- a/collects/mztake/debugger-model.ss +++ b/collects/mztake/debugger-model.ss @@ -52,7 +52,7 @@ clients)))] [annotate-module? (lambda (fn m) - (memf (lambda (sym) (eq? sym fn)) + (memf (lambda (sym) (equal? sym fn)) all-used-module-paths))] [annotator (lambda (fn m stx) diff --git a/collects/mztake/demos/dijkstra/dijkstra-solver.ss b/collects/mztake/demos/dijkstra/dijkstra-solver.ss new file mode 100644 index 0000000000..5725373fb5 --- /dev/null +++ b/collects/mztake/demos/dijkstra/dijkstra-solver.ss @@ -0,0 +1,49 @@ +(module dijkstra-solver mzscheme + (require (lib "heap.ss" "frtime") + (lib "list.ss") + "graph.ss") + + (provide (all-defined)) + + (define (make-node label x y weight) (vector label x y weight)) + (define (node-label n) (vector-ref n 0)) + (define (node-x n) (vector-ref n 1)) + (define (node-y n) (vector-ref n 2)) + (define (node-weight n) (vector-ref n 3)) + (define (set-node-weight! n v) (vector-set! n 3 v)) + + (define (node< a b) (< (node-weight a) (node-weight b))) + (define (sqr x) (* x x)) + (define (distance-to a b) + (sqrt (+ (sqr (- (node-x a) (node-x b))) + (sqr (- (node-y a) (node-y b)))))) + + (define (hash-table-pairs hash) + (hash-table-map hash (lambda (key val) (list key val)))) + + (define (relax backtrace heap origin dest) + (let ([candidate-weight + (+ (node-weight origin) + (distance-to origin dest))]) + (when (candidate-weight . < . (node-weight dest)) + (set-node-weight! dest candidate-weight) + ;;(heap-resort heap dest) + (hash-table-put! backtrace dest origin)))) + + (define (solve graph nodes source) + (let ([backtrace (make-hash-table)] + [heap (make-heap node< eq?)]) + (set-node-weight! source 0) + (for-each (lambda (node) (heap-insert heap node)) + nodes) + + (let loop () + (unless (heap-empty? heap) + (let* ([node (heap-pop heap)] + [successors (graph-succs graph node)]) + (for-each + (lambda (succ) (relax backtrace heap node succ)) + successors)) + (loop))) + + (hash-table-pairs backtrace)))) diff --git a/collects/mztake/demos/dijkstra/dijkstra-test.ss b/collects/mztake/demos/dijkstra/dijkstra-test.ss new file mode 100644 index 0000000000..156a79569c --- /dev/null +++ b/collects/mztake/demos/dijkstra/dijkstra-test.ss @@ -0,0 +1,40 @@ + +(require "dijkstra-solver.ss" + (lib "match.ss")) + +(mztake-process p + ("dijkstra.ss") + ((lib "heap.ss" "frtime") + [inserts 49 6 bind 'item] + [removes 67 10 bind 'result])) + +(define (not-in-order e) + (filter-e + (match-lambda + [('reset _) false] + [(_ 'reset) false] + [(previous current) (> previous current)]) + (history-e 2 e))) + +(history-e 5 (history-e 2 (merge-e (removes . ==> . node-weight) + (inserts . -=> . 'reset)))) + +(define violations + (not-in-order (merge-e (removes . ==> . node-weight) + (inserts . -=> . 'reset)))) + +(define latest-violation (hold violations)) + +(define ((insert-in-model item) model) (cons item model)) +(define ((remove-from-model item) model) (filter (lambda (i) (eq? i item)) model)) + +(define inserters (inserts . ==> . insert-in-model)) +(define removers (removes . ==> . remove-from-model)) + +(define model (accum-b (merge-e inserters removers) empty)) + +(printf-b "latest-violation: ~a" latest-violation) +(printf-b "model: ~a" model) + +(start/resume p) + \ No newline at end of file diff --git a/collects/mztake/demos/dijkstra/dijkstra.ss b/collects/mztake/demos/dijkstra/dijkstra.ss new file mode 100644 index 0000000000..30873322d1 --- /dev/null +++ b/collects/mztake/demos/dijkstra/dijkstra.ss @@ -0,0 +1,40 @@ +(module dijkstra mzscheme + (require "dijkstra-solver.ss" + "graph.ss" + (lib "list.ss")) + (print-struct #t) + (define g (make-graph 'directed)) + (define (m-node label x y) (make-node label x y +inf.0)) + (define nodes + (list + (m-node 'J 200 100) + (m-node 's 100 125) + (m-node '1 150 100) + (m-node '2 150 150) + (m-node '4 250 100) + (m-node '5 300 100) + (m-node '6 300 150))) + (for-each (lambda (n) (graph-node-add! g n)) nodes) + (define (n-ref label) + (first (filter (lambda (n) (eq? label (node-label n))) nodes))) + + (define edges + (list (list (n-ref 's) (n-ref '1)) + (list (n-ref 's) (n-ref '2)) + (list (n-ref '1) (n-ref 'J)) + (list (n-ref '4) (n-ref '5)) + (list (n-ref 'J) (n-ref '4)) + (list (n-ref 'J) (n-ref '6)))) + (for-each (lambda (e) (graph-edge-add! g (first e) (second e))) + edges) + + (require (lib "pretty.ss")) + ;(printf "input:~n") + ;(pretty-print (graph-to-list g)) + (printf "output:~n") + (print-struct #t) + (pretty-print (solve g (reverse nodes) (n-ref 's))) + + + + ) \ No newline at end of file diff --git a/collects/mztake/demos/dijkstra/graph.ss b/collects/mztake/demos/dijkstra/graph.ss new file mode 100644 index 0000000000..da86dbf4c5 --- /dev/null +++ b/collects/mztake/demos/dijkstra/graph.ss @@ -0,0 +1,543 @@ +;; -*- compile-command: "mzscheme -M errortrace -u graph.ss" -*- +(module graph mzscheme + (require (lib "more-useful-code.ss" "mztake" "private")) + + (provide make-graph + ;; --- Constructors : + graph? + graph-directed? + graph-make-similar + graph-copy + graph-add-all! + ;; --- Functions on nodes: + graph-nodes + graph-nodes-size + graph-make-node! + graph-node-add! + graph-node-mem? + graph-node-set! + graph-node-remove! + graph-node-collapse! + graph-node-has-label? + graph-node-label + graph-for-each-node + graph-fold-nodes + ;; --- Functions on neighbors: + graph-succs + graph-preds + graph-adjs + graph-for-each-adjs + ;; --- Functions on edges: + graph-edges + graph-edges-size + graph-edge-add! + graph-edge-mem? + graph-edge-set! + graph-edge-remove! + graph-edge-has-label? + graph-edge-label + graph-for-each-edge + graph-fold-edges + ;; --- Simple graph algorithms: + graph-dfs-from-node + graph-dfs-all + graph-components + graph-strongly-connected-components + graph-topological-sort + ;; --- Debugging: + graph-to-list + graph-to-string + graph-test + ) + + (define-struct t (flags nNodes nEdges nodes successors predessessors)) + + ;; Flags can be: 'equal 'directed 'unique-node 'unique-edge 'nodes-must-exists 'safe + ;; 'safe is a short for '(unique-node unique-edge nodes-must-exists) + (define (make-graph . flags) + (let ((flag-hash (make-hash))) + (set! flags (expands-safe-flag flags)) + (for-each-f flags (lambda (flag) (hash-put! flag-hash flag true))) + (if (member 'equal flags) + (make-t flag-hash 0 0 (make-hash 'equal) (make-hash 'equal) (make-hash 'equal)) + (make-t flag-hash 0 0 (make-hash) (make-hash) (make-hash))))) + + (define (graph? graph) (t? graph)) + + (define no-value (box empty)) + + ;; Makes a hash with the same 'equal as the graph + (define (graph-make-hash graph) + (if (graph-has-flag? graph 'equal) + (make-hash 'equal) + (make-hash))) + + + (define (expands-safe-flag flags) + (let loop ((cur flags) (acc empty)) + (cond [(empty? cur) acc] + [(eq? (first cur) 'safe) (loop (rest cur) (append '(unique-node unique-edge nodes-must-exists) flags))] + [true (loop (rest cur) (cons (first cur) acc))]))) + + ;; Make a graph with mostly the same flags as another graph + (define (graph-make-similar graph plus-flags minus-flags) + (set! plus-flags (expands-safe-flag plus-flags)) + (set! minus-flags (expands-safe-flag minus-flags)) + (apply make-graph + (append plus-flags + (filter (lambda (i) (not (member i minus-flags))) + (hash-keys (t-flags graph)))))) + + (define (graph-copy graph) + (let* ((rtn-nodes (graph-make-hash graph)) + (rtn-successors (graph-make-hash graph)) + (rtn-predessessors (graph-make-hash graph)) + (rtn (make-t (t-flags graph) (t-nNodes graph) (t-nEdges graph) rtn-nodes rtn-successors rtn-predessessors))) + + (hash-add-all! rtn-nodes (t-nodes graph)) + (hash-add-all! rtn-successors (t-successors graph)) + (hash-add-all! rtn-predessessors (t-predessessors graph)) + rtn)) + + (define (graph-add-all! dest-graph src-graph) + (graph-for-each-node + src-graph + (lambda (node) + (if (graph-node-has-label? src-graph node) + (graph-node-add! dest-graph node (graph-node-label src-graph node)) + (graph-node-add! dest-graph node)))) + (graph-for-each-edge + src-graph + (lambda (from to) + (if (graph-edge-has-label? src-graph from to) + (graph-edge-add! dest-graph from to (graph-edge-label src-graph from to)) + (graph-edge-add! dest-graph from to))))) + + (define (graph-has-flag? graph flag) + (hash-mem? (t-flags graph) flag)) + + (define (graph-directed? graph) + (hash-mem? (t-flags graph) 'directed)) + +;;; ===================================================================== +;;; Nodes + + (define (graph-nodes graph) (hash-keys (t-nodes graph))) + + (define (graph-nodes-size graph) (t-nNodes graph)) + + (define graph-make-node! + (case-lambda + [(graph) (graph-make-node! graph no-value)] + [(graph val) + (let ((sym (string->symbol (string-append "node" (number->string (t-nNodes graph)))))) + (graph-node-add! graph sym val) + sym)])) + + ;; Add a node to the graph. If the node already exists, + ;; sets its label, unless the graph has the 'unique-node property, + ;; in which case this will assert. + (define graph-node-add! + (case-lambda + [(graph node) (graph-node-add! graph node no-value)] + [(graph node val) + (if (hash-mem? (t-nodes graph) node) + (assert (not (graph-has-flag? graph 'unique-node))) + (begin + (set-t-nNodes! graph (+ 1 (t-nNodes graph))) + (hash-put! (t-successors graph) node (graph-make-hash graph)) + (if (graph-directed? graph) + (hash-put! (t-predessessors graph) node (graph-make-hash graph))))) + (hash-put! (t-nodes graph) node val)])) + + (define (graph-node-mem? graph node) + (hash-mem? (t-nodes graph) node)) + + (define (graph-node-set! graph node val) + (assert (hash-mem? (t-nodes graph) node)) + (hash-put! (t-nodes graph) node val)) + + (define (graph-node-remove! graph node) + (assert (graph-node-mem? graph node)) + (for-each-f (hash-get (t-successors graph) node) + (lambda (i) (graph-edge-remove! graph node i))) + + (if (graph-directed? graph) + (for-each-f (hash-get (t-predessessors graph) node) + (lambda (i) (graph-edge-remove! graph i node)))) + + (hash-remove! (t-nodes graph) node) + (hash-remove! (t-successors graph) node) + (if (graph-directed? graph) + (hash-remove! (t-predessessors graph) node)) + (set-t-nNodes! graph (- (t-nNodes graph) 1))) + + (define graph-node-collapse! + (case-lambda + [(graph node with-self-loop) (graph-node-collapse! graph node with-self-loop (lambda (pred-label succ-label) no-value))] + [(graph node with-self-loop label-fn) + (let ((is-directed (graph-directed? graph))) + (for-each-f + + (if is-directed + (hash-get (t-predessessors graph) node) + (hash-get (t-successors graph) node)) + + (lambda (pred) + (for-each-f + (hash-get (t-successors graph) node) + (lambda (succ) + (unless (or (and (not is-directed) (eq? pred succ)) + (graph-edge-mem? graph pred succ)) + (let* ((label-pred (hash-get (hash-get (t-successors graph) pred) node)) + (label-succ (hash-get (hash-get (t-successors graph) node) succ)) + (new-label (label-fn (if (eq? label-pred no-value) false label-pred) + (if (eq? label-succ no-value) false label-succ)))) + (when (or with-self-loop (not (eq? pred succ))) + (hash-put! (hash-get (t-successors graph) pred) succ new-label) + (if is-directed + (hash-put! (hash-get (t-predessessors graph) succ) pred new-label) + (hash-put! (hash-get (t-successors graph) succ) pred new-label)))))))))) + (graph-node-remove! graph node)])) + + (define (graph-node-has-label? graph node) + (not (eq? (hash-get (t-nodes graph) node) no-value))) + + (define (graph-node-label graph node) + (let ((r (hash-get (t-nodes graph) node))) + (if (eq? r no-value) (error "graph-node-label: no value for node" node) + r))) + + (define (graph-succs graph node) + (assert (graph-directed? graph)) + (hash-keys (hash-get (t-successors graph) node))) + + (define (graph-preds graph node) + (assert (graph-directed? graph)) + (hash-keys (hash-get (t-predessessors graph) node))) + + (define (graph-adjs graph node) + (if (graph-directed? graph) + (append (hash-keys (hash-get (t-successors graph) node)) + (hash-keys (hash-get (t-predessessors graph) node))) + (hash-keys (hash-get (t-successors graph) node)))) + + (define (graph-for-each-adjs graph node fn) + (for-each (lambda (succ) (fn node succ)) + (hash-get (t-successors graph) node)) + (when (graph-directed? graph) + (for-each (lambda (pred) (fn pred node)) + (hash-get (t-predessessors graph) node)))) + + (define (graph-for-each-node graph fn) + (for-each-f (t-nodes graph) fn)) + + (define (graph-fold-nodes graph init fn) + (let ((acc init)) + (graph-for-each-node + graph + (lambda (node) (set! acc (fn node acc)))) + acc)) + +;;; ===================================================================== +;;; Edges + + (define (graph-edges graph) + (let ((rtn empty)) + (graph-for-each-edge graph (lambda (from to) (set! rtn (cons from to)))) + rtn)) + + (define (graph-edges-size graph) (t-nEdges graph)) + + ;; Add an edge to the graph. If the edge already exists, + ;; sets its label, unless the graph has the 'unique-edge property, + ;; in which case this will assert. + (define graph-edge-add! + (case-lambda + [(graph from to) (graph-edge-add! graph from to no-value)] + [(graph from to val) + + (if (graph-edge-mem? graph from to) + (assert (not (graph-has-flag? graph 'unique-edge))) + (set-t-nEdges! graph (+ (t-nEdges graph) 1))) + + (if (graph-has-flag? graph 'nodes-must-exists) + (assert (and (graph-node-mem? graph from) (graph-node-mem? graph to))) + (begin (if (not (graph-node-mem? graph from)) (graph-node-add! graph from)) + (if (not (graph-node-mem? graph to)) (graph-node-add! graph to)))) + + (hash-put! (hash-get (t-successors graph) from) to val) + + (if (graph-directed? graph) + (hash-put! (hash-get (t-predessessors graph) to) from val) + (hash-put! (hash-get (t-successors graph) to) from val))])) + + (define (graph-edge-mem? graph from to) + (if (graph-has-flag? graph 'nodes-must-exists) + (assert (and (graph-node-mem? graph from) + (graph-node-mem? graph to)))) + + (and (hash-mem? (t-successors graph) from) + (hash-mem? (hash-get (t-successors graph) from) to))) + + (define (graph-edge-set! graph from to val) + (assert (graph-edge-mem? graph from to)) + (hash-put! (hash-get (t-successors graph) from) to val) + + (if (graph-directed? graph) + (hash-put! (hash-get (t-predessessors graph) to) from val) + (hash-put! (hash-get (t-successors graph) to) from val))) + + (define (graph-edge-remove! graph from to) + (assert (graph-edge-mem? graph from to)) + (hash-remove! (hash-get (t-successors graph) from) to) + + (if (graph-directed? graph) + (hash-remove! (hash-get (t-predessessors graph) to) from) + (hash-remove! (hash-get (t-successors graph) to) from))) + + (define (graph-edge-has-label? graph from to) + (not (eq? (hash-get (hash-get (t-successors graph) from) to) no-value))) + + (define (graph-edge-label graph from to) + (let ((r (hash-get (hash-get (t-successors graph) from) to))) + (if (eq? r no-value) (error "graph-edge-label: no value for edge" (cons from to))) + r)) + + (define (graph-for-each-edge graph fn) + (graph-for-each-node + graph + (lambda (from) + (for-each-f (hash-get (t-successors graph) from) + (lambda (to) (fn from to)))))) + + (define (graph-fold-edges graph init fn) + (let ((acc init)) + (graph-for-each-edge + graph + (lambda (from to) (set! acc (fn from to acc)))) + acc)) + +;;; ===================================================================== +;;; Algos + + (define (graph-dfs-from-node-with-log graph node dealt-with pre-fn post-fn backward) + (assert (or (not backward) (graph-directed? graph))) + (if (not (hash-mem? dealt-with node)) + (begin (hash-put! dealt-with node true) + (pre-fn node) + (for-each-f (if backward + (hash-get (t-predessessors graph) node) + (hash-get (t-successors graph) node)) + (lambda (n) (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn backward))) + (post-fn node)))) + + + (define graph-dfs-from-node + (case-lambda + [(graph node pre-fn) (graph-dfs-from-node graph node pre-fn (lambda (i) i))] + [(graph node pre-fn post-fn) + (graph-dfs-from-node-with-log graph node (graph-make-hash graph) pre-fn post-fn false)])) + + (define graph-dfs-all + (case-lambda + [(graph pre-fn) (graph-dfs-all graph pre-fn (lambda (i) i))] + [(graph pre-fn post-fn) + (let ((dealt-with (graph-make-hash graph))) + (graph-for-each-node graph (lambda (n) (if (not (hash-mem? dealt-with n)) + (graph-dfs-from-node-with-log graph n dealt-with pre-fn post-fn false)))))])) + + + (define (graph-components graph) + (let ((dealt-with (graph-make-hash graph))) + (graph-fold-nodes + graph + empty + (lambda (node acc) + (if (hash-mem? dealt-with node) acc + (let ((cur-component + (let loop ((cur node) (acc empty)) + (if (hash-mem? dealt-with cur) acc + (begin (hash-put! dealt-with cur true) + (foldl (lambda (adj acc) (loop adj acc)) (cons cur acc) + (graph-adjs graph cur))))))) + (cons cur-component acc))))))) + + (define (graph-strongly-connected-components graph) + (assert (graph-directed? graph)) + (let ((finish-times empty) + (dealt-with (graph-make-hash graph))) + + (graph-for-each-node + graph + (lambda (n) (graph-dfs-from-node-with-log + graph n dealt-with + (lambda (i) i) + (lambda (i) (set! finish-times (cons i finish-times))) + false))) + + (set! dealt-with (graph-make-hash graph)) + + (let ((component-graph (graph-make-similar graph empty '(safe equal))) + (node2supernode (make-hash))) + + (for-each-f + finish-times + (lambda (n) + (if (not (hash-mem? dealt-with n)) + (let ((super-node (graph-make-node! component-graph empty))) + (graph-dfs-from-node-with-log + graph n dealt-with + (lambda (i) + (graph-node-set! component-graph super-node (cons i (graph-node-label component-graph super-node))) + (hash-put! node2supernode i super-node)) + (lambda (i) i) + true))))) + (graph-for-each-edge graph + (lambda (from to) + (graph-edge-add! component-graph + (hash-get node2supernode from) + (hash-get node2supernode to)))) + (cons component-graph node2supernode)))) + + (define (graph-topological-sort graph) + (assert (graph-directed? graph)) + (let ((rtn empty)) + (graph-dfs-all graph (lambda (i) i) (lambda (node) (set! rtn (cons node rtn)))) + rtn)) + + +;;; ===================================================================== +;;; Utils + + (define graph-to-list + (case-lambda + [(graph) (graph-to-list graph false)] + [(graph with-labels) + (hash-map (t-nodes graph) + (lambda (node node-val) + (let ((node-rep (if (and with-labels (graph-node-has-label? graph node)) + (cons node (graph-node-label graph node)) + node))) + (cons node-rep + (hash-fold (hash-get (t-successors graph) node) empty + (lambda (succ edge-val acc) + (if (and with-labels (graph-edge-has-label? graph node succ)) + (cons (cons succ (graph-edge-label graph node succ)) acc) + (cons succ acc))))))))])) + + (define (graph-to-string-prv graph with-labels to-string) + (let ([the-to-string (or to-string + (lambda (item) (format "~a" item)))]) + (string-append (if (graph-directed? graph) "[di-graph: " "[undirected-graph:") + (the-to-string (map (lambda (n) + (cons (first n) (cons '--> (rest n)))) + (graph-to-list graph with-labels))) + "]"))) + + (define (graph-to-string graph . to-string) + (graph-to-string-prv graph false (if (empty? to-string) false (first to-string)))) + + (define (graph-to-string-with-labels graph . to-string) + (graph-to-string-prv graph true (if (empty? to-string) true (first to-string)))) + + (define to-string-f (make-to-string `((,t? ,graph-to-string)))) + (define debug-f (make-debug to-string-f)) + (define for-each-f (make-for-each)) + +;;; ===================================================================== +;;; Tests + + (define (graph-test) + (define graph (make-graph 'safe 'directed)) + + (graph-node-add! graph 'a) + (graph-node-add! graph 'b 2) + (graph-node-add! graph 'c 3) + (graph-node-add! graph 'd) + + (graph-edge-add! graph 'a 'c) + (graph-edge-add! graph 'a 'd "asd") + (graph-edge-add! graph 'b 'c "dfg") + (graph-edge-add! graph 'b 'd) + (graph-edge-add! graph 'd 'a) + + (display (graph-node-mem? graph 'a)) + (display (graph-edge-mem? graph 'a 'c)) + (newline) + (display (graph-node-mem? graph 'v)) + (display (graph-edge-mem? graph 'c 'a)) + (display (graph-edge-mem? graph 'a 'b)) + (newline) + + (debug-f (graph-to-list graph true)) + (graph-for-each-edge graph (lambda (a b) (debug-f "A " a b))) + + (graph-dfs-from-node graph 'a (lambda (i) (display i))) + (newline) + (graph-dfs-from-node graph 'b (lambda (i) (display i))) + (newline) + (graph-dfs-from-node graph 'c (lambda (i) (display i))) + (newline) + (graph-dfs-from-node graph 'd (lambda (i) (display i))) + (newline) + + (let ((star (make-graph 'directed))) + (graph-edge-add! star 1 'x) + (graph-edge-add! star 'x 1) + (graph-edge-add! star 2 'x) + (graph-edge-add! star 'x 3) + (graph-edge-add! star 'x 4) + (graph-edge-add! star 'x 5) + (graph-node-collapse! star 'x false) + (debug-f "collapsed:" (graph-to-list star))) + + (let ((strong-graph (make-graph 'directed))) + + (graph-edge-add! strong-graph 'e 'a) + (graph-edge-add! strong-graph 'a 'b) + (graph-edge-add! strong-graph 'b 'e) + (graph-edge-add! strong-graph 'e 'f) + (graph-edge-add! strong-graph 'b 'f) + (graph-edge-add! strong-graph 'b 'c) + (graph-edge-add! strong-graph 'f 'g) + (graph-edge-add! strong-graph 'g 'f) + (graph-edge-add! strong-graph 'c 'g) + (graph-edge-add! strong-graph 'c 'd) + (graph-edge-add! strong-graph 'd 'c) + (graph-edge-add! strong-graph 'g 'h) + (graph-edge-add! strong-graph 'd 'h) + (graph-edge-add! strong-graph 'h 'h) + + (graph-edge-add! strong-graph 'xa 'xb) + (graph-edge-add! strong-graph 'xb 'xc) + (graph-edge-add! strong-graph 'xc 'xa) + + (debug-f "strong-graph" strong-graph) + (debug-f "component" (graph-components strong-graph)) + (let ((components (graph-strongly-connected-components strong-graph))) + (debug-f "strong-components" components) + (debug-f "toposort" (graph-topological-sort (first components))))) + + (let ((u-graph (make-graph))) + (graph-edge-add! u-graph 'a 'b) + (graph-edge-add! u-graph 'b 'c) + (graph-edge-add! u-graph 'c 'd) + (graph-edge-add! u-graph 'd 'a) + (graph-edge-add! u-graph 'd 'e) + (graph-edge-add! u-graph 'e 'c) + + (graph-edge-add! u-graph 'xa 'xb) + (graph-edge-add! u-graph 'xa 'xc) + (graph-edge-add! u-graph 'xb 'xd) + (newline) + (debug-f "u-graph" u-graph) + (graph-edge-remove! u-graph 'b 'a) + (graph-node-remove! u-graph 'd) + (debug-f "u-graph" u-graph) + (debug-f "component" (graph-components u-graph))) + + ) + ;(graph-test) + ) + diff --git a/collects/mztake/doc.txt b/collects/mztake/doc.txt index fefd8dbd6e..043065b803 100644 --- a/collects/mztake/doc.txt +++ b/collects/mztake/doc.txt @@ -77,11 +77,15 @@ different uses of MzTake. You should be able to run them in DrScheme by switching to the MzTake language and clicking the "Run" button. - demos/highway/highway-test.ss - small MzTake example used above + demos/highway/highway-test.ss - a small MzTake example, used above + demos/sine/sine-test.ss - plots values extracted from the running program + demos/djikstra/dijkstra-test.ss - debugs a buggy implementation of + Dijkstra's algorithm + demos/montecarlo/montecarlo-test.ss - visualizes Monte Carlo integration used to derive the value of pi diff --git a/collects/mztake/mztake.ss b/collects/mztake/mztake.ss index 89104bc388..92b2c7e676 100644 --- a/collects/mztake/mztake.ss +++ b/collects/mztake/mztake.ss @@ -337,7 +337,7 @@ TESTING/CAPABILITIES------------------------------------------------------------ (thread-wait (thread (lambda () (run)))) ; program terminates (stop process) - (print-info (format "process terminated: ~a" (main-client-name process)))))) + (print-info (format "process exited normally: ~a" (main-client-name process)))))) ; predicate - is the debugee supposed to be running now? diff --git a/collects/mztake/private/useful-code.ss b/collects/mztake/private/useful-code.ss index ad704c54c5..889f56f83c 100644 --- a/collects/mztake/private/useful-code.ss +++ b/collects/mztake/private/useful-code.ss @@ -8,8 +8,11 @@ ; Keeps a list of the last n values of a behavior (define (history-b n stream) + (hold (history-e n stream) empty)) + + (define (history-e n stream) (define ((add-to-hist thing) hist) (append (if ((length hist) . < . n) hist (rest hist)) (list thing))) - (accum-b (stream . ==> . add-to-hist) empty)) + (accum-e (stream . ==> . add-to-hist) empty)) ; Counts number of event pings on an eventstream (define (count-e evs)