props etc
svn: r187
This commit is contained in:
Eli Barzilay
parent
d4d279ec7a
commit
cfce6631b3
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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))
|
||||
)
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -1,2 +1,2 @@
|
|||
(module exception mzscheme
|
||||
(module exception mzscheme
|
||||
(thread (lambda () (raise 'exn:oops-made-a-mztake!))))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 |#
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 |#
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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))
|
||||
|
|
@ -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 |#
|
||||
|
|
@ -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))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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")))
|
||||
)
|
||||
|
|
|
|||
2
collects/mztake/make-clean.bat
Normal file → Executable file
2
collects/mztake/make-clean.bat
Normal file → Executable file
|
|
@ -1,2 +1,2 @@
|
|||
del compiled
|
||||
del private\compiled
|
||||
del private\compiled
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
0
collects/mztake/make.bat
Normal file → Executable file
0
collects/mztake/make.bat
Normal file → Executable file
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
||||
;###########################################################################################################
|
||||
)
|
||||
|
|
@ -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
|
||||
)
|
||||
|
|
@ -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) "#<void>"]
|
||||
[(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) "#<void>"]
|
||||
[(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))))
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
Loading…
Reference in New Issue
Block a user