props etc
svn: r187
This commit is contained in:
Eli Barzilay
parent
d4d279ec7a
commit
cfce6631b3
|
|
@ -1,40 +1,40 @@
|
||||||
(require (lib "mztake.ss" "mztake")
|
(require (lib "mztake.ss" "mztake")
|
||||||
"dijkstra-solver.ss"
|
"dijkstra-solver.ss"
|
||||||
(lib "match.ss"))
|
(lib "match.ss"))
|
||||||
|
|
||||||
(define/bind (loc "heap.ss" 49 6) item)
|
(define/bind (loc "heap.ss" 49 6) item)
|
||||||
(define/bind (loc "heap.ss" 67 10) result)
|
(define/bind (loc "heap.ss" 67 10) result)
|
||||||
|
|
||||||
(define (not-in-order e)
|
(define (not-in-order e)
|
||||||
(filter-e
|
(filter-e
|
||||||
(match-lambda
|
(match-lambda
|
||||||
[('reset _) false]
|
[('reset _) false]
|
||||||
[(_ 'reset) false]
|
[(_ 'reset) false]
|
||||||
[(previous current) (> previous current)]
|
[(previous current) (> previous current)]
|
||||||
[else false])
|
[else false])
|
||||||
(history-e 2 e)))
|
(history-e 2 e)))
|
||||||
|
|
||||||
|
|
||||||
(define inserts-and-removes-e (merge-e (removes . ==> . node-weight)
|
(define inserts-and-removes-e (merge-e (removes . ==> . node-weight)
|
||||||
(inserts . -=> . 'reset)))
|
(inserts . -=> . 'reset)))
|
||||||
(define violations (not-in-order inserts-and-removes-e))
|
(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 inserts and removes: ~a" (history-b inserts-and-removes-e))
|
||||||
(printf-b "all violations: ~a" (history-b violations))
|
(printf-b "all violations: ~a" (history-b violations))
|
||||||
(printf-b "latest-violation: ~a" (hold violations))
|
(printf-b "latest-violation: ~a" (hold violations))
|
||||||
|
|
||||||
|
|
||||||
#| Implementation of the local model follows... |#
|
#| Implementation of the local model follows... |#
|
||||||
(define ((insert-in-model item) model)
|
(define ((insert-in-model item) model)
|
||||||
(printf "~nInserting ~a into model containing:~n~a~n" item (value-now model))
|
(printf "~nInserting ~a into model containing:~n~a~n" item (value-now model))
|
||||||
(cons item model))
|
(cons item model))
|
||||||
|
|
||||||
(define ((remove-from-model item) model)
|
(define ((remove-from-model item) model)
|
||||||
(printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model))
|
(printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model))
|
||||||
(filter (lambda (i) (not (equal? i item))) model))
|
(filter (lambda (i) (not (equal? i item))) model))
|
||||||
|
|
||||||
(define inserters (accum-b (inserts . ==> . insert-in-model) empty))
|
(define inserters (accum-b (inserts . ==> . insert-in-model) empty))
|
||||||
(define removers (accum-b (removes . ==> . remove-from-model) inserters))
|
(define removers (accum-b (removes . ==> . remove-from-model) inserters))
|
||||||
|
|
||||||
(set-running-e! (violations . -=> . false))
|
(set-running-e! (violations . -=> . false))
|
||||||
|
|
@ -1,84 +1,84 @@
|
||||||
#| This script tests a priority queue (heap) that is correctly implemented, but incorrectly used.
|
#| 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
|
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
|
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),
|
"A Dataflow Language for Scriptable Debugging" (Marceau, Cooper, Krishnamurthi, Reiss),
|
||||||
available at:
|
available at:
|
||||||
|
|
||||||
http://www.cs.brown.edu/~sk/Publications/Papers/Published/mckr-dataflow-lang-script-debug/
|
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,
|
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,
|
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
|
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
|
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
|
"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,
|
it is working correctly or not. Our model shows the values we should be getting from the program,
|
||||||
but clearly are not.
|
but clearly are not.
|
||||||
|
|
||||||
To provide some context for this demo, and what debugging problem MzTake helps us explore, I offer
|
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:
|
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
|
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.
|
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:
|
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
|
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
|
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
|
the queue is not sensitive to these updates, what it returns is no longer the
|
||||||
smallest element in the queue.
|
smallest element in the queue.
|
||||||
|
|
||||||
On further reading, we trace the error to a subtle detail in the description of
|
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
|
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
|
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
|
sparse graphs, but subsequently amends the pseudocode to say that the assignment
|
||||||
to dest.weight must explicitly invoke a key-decrement operation. Our error,
|
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)
|
therefore, was not in the implementation of the heap, but in using the (faster)
|
||||||
binary heap implementation without satisfying its (stronger) contract. |#
|
binary heap implementation without satisfying its (stronger) contract. |#
|
||||||
|
|
||||||
(require "dijkstra-solver.ss"
|
(require "dijkstra-solver.ss"
|
||||||
(lib "match.ss"))
|
(lib "match.ss"))
|
||||||
|
|
||||||
(define-mztake-process p
|
(define-mztake-process p
|
||||||
("dijkstra.ss")
|
("dijkstra.ss")
|
||||||
("heap.ss" [inserts 49 6 bind 'item]
|
("heap.ss" [inserts 49 6 bind 'item]
|
||||||
[removes 67 10 bind 'result]))
|
[removes 67 10 bind 'result]))
|
||||||
|
|
||||||
#| The following code merely observes the insertions and removals
|
#| The following code merely observes the insertions and removals
|
||||||
from the heap. We notice whether any of the removals are out
|
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
|
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
|
no insertions between the two events. We can keep track of the
|
||||||
last 2 using history-e. |#
|
last 2 using history-e. |#
|
||||||
|
|
||||||
(define (not-in-order e)
|
(define (not-in-order e)
|
||||||
(filter-e
|
(filter-e
|
||||||
(match-lambda
|
(match-lambda
|
||||||
[('reset _) false]
|
[('reset _) false]
|
||||||
[(_ 'reset) false]
|
[(_ 'reset) false]
|
||||||
[(previous current) (> previous current)]
|
[(previous current) (> previous current)]
|
||||||
[else false])
|
[else false])
|
||||||
(history-e 2 e)))
|
(history-e 2 e)))
|
||||||
|
|
||||||
|
|
||||||
(define inserts-and-removes-e (merge-e (removes . ==> . node-weight)
|
(define inserts-and-removes-e (merge-e (removes . ==> . node-weight)
|
||||||
(inserts . -=> . 'reset)))
|
(inserts . -=> . 'reset)))
|
||||||
(define violations (not-in-order inserts-and-removes-e))
|
(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 inserts and removes: ~a" (history-b inserts-and-removes-e))
|
||||||
(printf-b "all violations: ~a" (history-b violations))
|
(printf-b "all violations: ~a" (history-b violations))
|
||||||
(printf-b "latest-violation: ~a" (hold violations))
|
(printf-b "latest-violation: ~a" (hold violations))
|
||||||
#| This output indicates that the queue has yielded nodes whose weights are out of order.
|
#| 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. |#
|
This confirms our suspicion that the problem somehow involves the priority queue. |#
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#| Implementation of the local model follows... |#
|
#| Implementation of the local model follows... |#
|
||||||
(define ((insert-in-model item) model)
|
(define ((insert-in-model item) model)
|
||||||
(printf "~nInserting ~a into model containing:~n~a~n" item (value-now model))
|
(printf "~nInserting ~a into model containing:~n~a~n" item (value-now model))
|
||||||
(cons item model))
|
(cons item model))
|
||||||
|
|
||||||
(define ((remove-from-model item) model)
|
(define ((remove-from-model item) model)
|
||||||
(printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model))
|
(printf "~nRemoving ~a from model containing:~n~a~n" item (value-now model))
|
||||||
(filter (lambda (i) (not (equal? i item))) model))
|
(filter (lambda (i) (not (equal? i item))) model))
|
||||||
|
|
||||||
(define inserters (accum-b (inserts . ==> . insert-in-model) empty))
|
(define inserters (accum-b (inserts . ==> . insert-in-model) empty))
|
||||||
(define removers (accum-b (removes . ==> . remove-from-model) inserters))
|
(define removers (accum-b (removes . ==> . remove-from-model) inserters))
|
||||||
|
|
||||||
(start/resume p)
|
(start/resume p)
|
||||||
|
|
|
||||||
|
|
@ -1,49 +1,49 @@
|
||||||
(module dijkstra-solver mzscheme
|
(module dijkstra-solver mzscheme
|
||||||
(require "heap.ss"
|
(require "heap.ss"
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
"graph.ss")
|
"graph.ss")
|
||||||
|
|
||||||
(provide (all-defined))
|
(provide (all-defined))
|
||||||
|
|
||||||
(define (make-node label x y weight) (vector label x y weight))
|
(define (make-node label x y weight) (vector label x y weight))
|
||||||
(define (node-label n) (vector-ref n 0))
|
(define (node-label n) (vector-ref n 0))
|
||||||
(define (node-x n) (vector-ref n 1))
|
(define (node-x n) (vector-ref n 1))
|
||||||
(define (node-y n) (vector-ref n 2))
|
(define (node-y n) (vector-ref n 2))
|
||||||
(define (node-weight n) (vector-ref n 3))
|
(define (node-weight n) (vector-ref n 3))
|
||||||
(define (set-node-weight! n v) (vector-set! n 3 v))
|
(define (set-node-weight! n v) (vector-set! n 3 v))
|
||||||
|
|
||||||
(define (node< a b) (< (node-weight a) (node-weight b)))
|
(define (node< a b) (< (node-weight a) (node-weight b)))
|
||||||
(define (sqr x) (* x x))
|
(define (sqr x) (* x x))
|
||||||
(define (distance-to a b)
|
(define (distance-to a b)
|
||||||
(sqrt (+ (sqr (- (node-x a) (node-x b)))
|
(sqrt (+ (sqr (- (node-x a) (node-x b)))
|
||||||
(sqr (- (node-y a) (node-y b))))))
|
(sqr (- (node-y a) (node-y b))))))
|
||||||
|
|
||||||
(define (hash-table-pairs hash)
|
(define (hash-table-pairs hash)
|
||||||
(hash-table-map hash (lambda (key val) (list key val))))
|
(hash-table-map hash (lambda (key val) (list key val))))
|
||||||
|
|
||||||
(define (relax backtrace heap origin dest)
|
(define (relax backtrace heap origin dest)
|
||||||
(let ([candidate-weight
|
(let ([candidate-weight
|
||||||
(+ (node-weight origin)
|
(+ (node-weight origin)
|
||||||
(distance-to origin dest))])
|
(distance-to origin dest))])
|
||||||
(when (candidate-weight . < . (node-weight dest))
|
(when (candidate-weight . < . (node-weight dest))
|
||||||
(set-node-weight! dest candidate-weight)
|
(set-node-weight! dest candidate-weight)
|
||||||
;;(heap-resort heap dest)
|
;;(heap-resort heap dest)
|
||||||
(hash-table-put! backtrace dest origin))))
|
(hash-table-put! backtrace dest origin))))
|
||||||
|
|
||||||
(define (solve graph nodes source)
|
(define (solve graph nodes source)
|
||||||
(let ([backtrace (make-hash-table)]
|
(let ([backtrace (make-hash-table)]
|
||||||
[heap (make-heap node< eq?)])
|
[heap (make-heap node< eq?)])
|
||||||
(set-node-weight! source 0)
|
(set-node-weight! source 0)
|
||||||
(for-each (lambda (node) (heap-insert heap node))
|
(for-each (lambda (node) (heap-insert heap node))
|
||||||
nodes)
|
nodes)
|
||||||
|
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(unless (heap-empty? heap)
|
(unless (heap-empty? heap)
|
||||||
(let* ([node (heap-pop heap)]
|
(let* ([node (heap-pop heap)]
|
||||||
[successors (graph-succs graph node)])
|
[successors (graph-succs graph node)])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (succ) (relax backtrace heap node succ))
|
(lambda (succ) (relax backtrace heap node succ))
|
||||||
successors))
|
successors))
|
||||||
(loop)))
|
(loop)))
|
||||||
|
|
||||||
(hash-table-pairs backtrace))))
|
(hash-table-pairs backtrace))))
|
||||||
|
|
|
||||||
|
|
@ -1,32 +1,32 @@
|
||||||
(module dijkstra mzscheme
|
(module dijkstra mzscheme
|
||||||
(require "dijkstra-solver.ss"
|
(require "dijkstra-solver.ss"
|
||||||
"graph.ss"
|
"graph.ss"
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
(print-struct #t)
|
(print-struct #t)
|
||||||
(define g (make-graph 'directed))
|
(define g (make-graph 'directed))
|
||||||
(define (m-node label x y) (make-node label x y +inf.0))
|
(define (m-node label x y) (make-node label x y +inf.0))
|
||||||
(define nodes
|
(define nodes
|
||||||
(list
|
(list
|
||||||
(m-node 'J 200 100)
|
(m-node 'J 200 100)
|
||||||
(m-node 's 100 125)
|
(m-node 's 100 125)
|
||||||
(m-node '1 150 100)
|
(m-node '1 150 100)
|
||||||
(m-node '2 150 150)
|
(m-node '2 150 150)
|
||||||
(m-node '4 250 100)
|
(m-node '4 250 100)
|
||||||
(m-node '5 300 100)
|
(m-node '5 300 100)
|
||||||
(m-node '6 300 150)))
|
(m-node '6 300 150)))
|
||||||
(for-each (lambda (n) (graph-node-add! g n)) nodes)
|
(for-each (lambda (n) (graph-node-add! g n)) nodes)
|
||||||
(define (n-ref label)
|
(define (n-ref label)
|
||||||
(first (filter (lambda (n) (eq? label (node-label n))) nodes)))
|
(first (filter (lambda (n) (eq? label (node-label n))) nodes)))
|
||||||
|
|
||||||
(define edges
|
(define edges
|
||||||
(list (list (n-ref 's) (n-ref '1))
|
(list (list (n-ref 's) (n-ref '1))
|
||||||
(list (n-ref 's) (n-ref '2))
|
(list (n-ref 's) (n-ref '2))
|
||||||
(list (n-ref '1) (n-ref 'J))
|
(list (n-ref '1) (n-ref 'J))
|
||||||
(list (n-ref '4) (n-ref '5))
|
(list (n-ref '4) (n-ref '5))
|
||||||
(list (n-ref 'J) (n-ref '4))
|
(list (n-ref 'J) (n-ref '4))
|
||||||
(list (n-ref 'J) (n-ref '6))))
|
(list (n-ref 'J) (n-ref '6))))
|
||||||
(for-each (lambda (e) (graph-edge-add! g (first e) (second e)))
|
(for-each (lambda (e) (graph-edge-add! g (first e) (second e)))
|
||||||
edges)
|
edges)
|
||||||
|
|
||||||
(printf "~n~n---output from dijkstra.ss:~n~a~n---~n"
|
(printf "~n~n---output from dijkstra.ss:~n~a~n---~n"
|
||||||
(solve g (reverse nodes) (n-ref 's))))
|
(solve g (reverse nodes) (n-ref 's))))
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,162 +1,162 @@
|
||||||
(module heap mzscheme
|
(module heap mzscheme
|
||||||
|
|
||||||
(require (lib "etc.ss")
|
(require (lib "etc.ss")
|
||||||
"base-gm.ss"
|
"base-gm.ss"
|
||||||
"dv.ss")
|
"dv.ss")
|
||||||
|
|
||||||
|
|
||||||
(provide make-heap heap-empty? heap-size heap-insert heap-pop
|
(provide make-heap heap-empty? heap-size heap-insert heap-pop
|
||||||
heap-peak heap-remove heap-find
|
heap-peak heap-remove heap-find
|
||||||
heap-contains heap-resort heap-tostring)
|
heap-contains heap-resort heap-tostring)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-struct t (sorter equality data))
|
(define-struct t (sorter equality data))
|
||||||
|
|
||||||
;; sorter: elements which have the most trueness according to
|
;; sorter: elements which have the most trueness according to
|
||||||
;; the sorter pop out first
|
;; the sorter pop out first
|
||||||
(define (make-heap sorter equality)
|
(define (make-heap sorter equality)
|
||||||
(let ((data (dv:make 5)))
|
(let ((data (dv:make 5)))
|
||||||
(dv:append data 0)
|
(dv:append data 0)
|
||||||
(make-t sorter equality data)))
|
(make-t sorter equality data)))
|
||||||
|
|
||||||
(define (heap-size heap)
|
(define (heap-size heap)
|
||||||
(- (dv:length (t-data heap)) 1))
|
(- (dv:length (t-data heap)) 1))
|
||||||
|
|
||||||
(define (heap-empty? heap)
|
(define (heap-empty? heap)
|
||||||
(= (heap-size heap) 0))
|
(= (heap-size heap) 0))
|
||||||
|
|
||||||
(define (heap-last heap)
|
(define (heap-last heap)
|
||||||
(- (dv:length (t-data heap)) 1))
|
(- (dv:length (t-data heap)) 1))
|
||||||
|
|
||||||
(define (heap-parent i)
|
(define (heap-parent i)
|
||||||
(floor (/ i 2)))
|
(floor (/ i 2)))
|
||||||
|
|
||||||
(define (heap-left i) (* i 2))
|
(define (heap-left i) (* i 2))
|
||||||
|
|
||||||
(define (heap-right i) (+ 1 (* i 2)))
|
(define (heap-right i) (+ 1 (* i 2)))
|
||||||
|
|
||||||
(define (heap-has-right heap i)
|
(define (heap-has-right heap i)
|
||||||
(<= (heap-right i) (heap-last heap)))
|
(<= (heap-right i) (heap-last heap)))
|
||||||
|
|
||||||
(define (heap-has-left heap i)
|
(define (heap-has-left heap i)
|
||||||
(<= (heap-left i) (heap-last heap)))
|
(<= (heap-left i) (heap-last heap)))
|
||||||
|
|
||||||
(define (heap-insert heap item)
|
(define (heap-insert heap item)
|
||||||
(let* ((sorter (t-sorter heap))
|
(let* ((sorter (t-sorter heap))
|
||||||
(data (t-data heap)))
|
(data (t-data heap)))
|
||||||
(dv:append data item)
|
(dv:append data item)
|
||||||
(let ((d (let loop ((prev (heap-last heap))
|
(let ((d (let loop ((prev (heap-last heap))
|
||||||
(current (heap-parent (heap-last heap))))
|
(current (heap-parent (heap-last heap))))
|
||||||
|
|
||||||
(cond ((= current 0) prev)
|
(cond ((= current 0) prev)
|
||||||
((sorter item (dv:ref data current))
|
((sorter item (dv:ref data current))
|
||||||
(dv:set! data prev (dv:ref data current))
|
(dv:set! data prev (dv:ref data current))
|
||||||
(loop current (heap-parent current)))
|
(loop current (heap-parent current)))
|
||||||
(#t prev)))))
|
(#t prev)))))
|
||||||
(dv:set! data d item))))
|
(dv:set! data d item))))
|
||||||
|
|
||||||
(define (heap-peak heap)
|
(define (heap-peak heap)
|
||||||
(if (= (heap-size heap) 0) (error "heap-peak: empty")
|
(if (= (heap-size heap) 0) (error "heap-peak: empty")
|
||||||
(dv:ref (t-data heap) 1)))
|
(dv:ref (t-data heap) 1)))
|
||||||
|
|
||||||
(define (heap-pop heap)
|
(define (heap-pop heap)
|
||||||
(if (= (heap-size heap) 0) (error "heap-pop: empty")
|
(if (= (heap-size heap) 0) (error "heap-pop: empty")
|
||||||
(let ([result (dv:ref (t-data heap) 1)])
|
(let ([result (dv:ref (t-data heap) 1)])
|
||||||
(heap-remove-pos heap 1)
|
(heap-remove-pos heap 1)
|
||||||
result)))
|
result)))
|
||||||
|
|
||||||
(define (heap-remove-pos heap pos)
|
(define (heap-remove-pos heap pos)
|
||||||
(let* ((data (t-data heap))
|
(let* ((data (t-data heap))
|
||||||
(sorter (t-sorter heap)))
|
(sorter (t-sorter heap)))
|
||||||
|
|
||||||
(cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
|
(cond ((= 0 (heap-size heap)) (error "heap: removing from empty"))
|
||||||
((= pos (heap-last heap)) (dv:remove-last data))
|
((= pos (heap-last heap)) (dv:remove-last data))
|
||||||
(#t (let ((item (dv:ref data (heap-last heap))))
|
(#t (let ((item (dv:ref data (heap-last heap))))
|
||||||
(dv:remove-last data)
|
(dv:remove-last data)
|
||||||
(let loop ((current pos))
|
(let loop ((current pos))
|
||||||
|
|
||||||
(dv:set! data current item)
|
(dv:set! data current item)
|
||||||
(let* ((left (heap-left current))
|
(let* ((left (heap-left current))
|
||||||
(right (heap-right current))
|
(right (heap-right current))
|
||||||
(best-1 (if (and (heap-has-left heap current)
|
(best-1 (if (and (heap-has-left heap current)
|
||||||
(sorter (dv:ref data left) item))
|
(sorter (dv:ref data left) item))
|
||||||
left current))
|
left current))
|
||||||
|
|
||||||
(best-2 (if (and (heap-has-right heap current)
|
(best-2 (if (and (heap-has-right heap current)
|
||||||
(sorter (dv:ref data right)
|
(sorter (dv:ref data right)
|
||||||
(dv:ref data best-1)))
|
(dv:ref data best-1)))
|
||||||
right best-1)))
|
right best-1)))
|
||||||
|
|
||||||
(if (not (= best-2 current))
|
(if (not (= best-2 current))
|
||||||
(begin (dv:set! data current (dv:ref data best-2))
|
(begin (dv:set! data current (dv:ref data best-2))
|
||||||
(loop best-2))))))))))
|
(loop best-2))))))))))
|
||||||
|
|
||||||
;; return false if the object is not found
|
;; return false if the object is not found
|
||||||
(define (heap-remove heap item)
|
(define (heap-remove heap item)
|
||||||
(let ((pos (heap-find heap item)))
|
(let ((pos (heap-find heap item)))
|
||||||
(if (not pos) false
|
(if (not pos) false
|
||||||
(begin (heap-remove-pos heap pos) true))))
|
(begin (heap-remove-pos heap pos) true))))
|
||||||
|
|
||||||
(define (heap-contains heap item)
|
(define (heap-contains heap item)
|
||||||
(if (heap-find heap item) true false))
|
(if (heap-find heap item) true false))
|
||||||
|
|
||||||
(define (heap-find heap item)
|
(define (heap-find heap item)
|
||||||
(let ((data (t-data heap))
|
(let ((data (t-data heap))
|
||||||
(equality (t-equality heap))
|
(equality (t-equality heap))
|
||||||
(sorter (t-sorter heap)))
|
(sorter (t-sorter heap)))
|
||||||
(let loop ((current 1))
|
(let loop ((current 1))
|
||||||
(let ((current-item (dv:ref data current)))
|
(let ((current-item (dv:ref data current)))
|
||||||
(cond ((equality item current-item) current)
|
(cond ((equality item current-item) current)
|
||||||
((sorter item current-item) #f)
|
((sorter item current-item) #f)
|
||||||
(#t (or (and (heap-has-left heap current)
|
(#t (or (and (heap-has-left heap current)
|
||||||
(not (sorter item (dv:ref data (heap-left current))))
|
(not (sorter item (dv:ref data (heap-left current))))
|
||||||
(loop (heap-left current)))
|
(loop (heap-left current)))
|
||||||
(and (heap-has-right heap current)
|
(and (heap-has-right heap current)
|
||||||
(not (sorter item (dv:ref data (heap-right current))))
|
(not (sorter item (dv:ref data (heap-right current))))
|
||||||
(loop (heap-right current))))))))))
|
(loop (heap-right current))))))))))
|
||||||
|
|
||||||
(define (heap-resort heap item)
|
(define (heap-resort heap item)
|
||||||
(heap-remove heap item)
|
(heap-remove heap item)
|
||||||
(heap-insert heap item))
|
(heap-insert heap item))
|
||||||
|
|
||||||
(define (heap-tostring heap . fns)
|
(define (heap-tostring heap . fns)
|
||||||
(let* ((data (t-data heap))
|
(let* ((data (t-data heap))
|
||||||
(data-list (let loop ((i 1))
|
(data-list (let loop ((i 1))
|
||||||
(if (> i (heap-last heap)) empty
|
(if (> i (heap-last heap)) empty
|
||||||
(cons (dv:ref data i) (loop (+ i 1)))))))
|
(cons (dv:ref data i) (loop (+ i 1)))))))
|
||||||
|
|
||||||
(string-append "heap: sz " (number->string (heap-size heap)) ", "
|
(string-append "heap: sz " (number->string (heap-size heap)) ", "
|
||||||
(apply to-string (cons data-list fns)))))
|
(apply to-string (cons data-list fns)))))
|
||||||
|
|
||||||
(define (test)
|
(define (test)
|
||||||
(define f (make-heap > eq?))
|
(define f (make-heap > eq?))
|
||||||
(define d (t-data f))
|
(define d (t-data f))
|
||||||
(heap-insert f 99)
|
(heap-insert f 99)
|
||||||
(debug "A " d)
|
(debug "A " d)
|
||||||
(heap-remove-pos f 1)
|
(heap-remove-pos f 1)
|
||||||
(debug "B " d)
|
(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))
|
(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)
|
(debug "C " d)
|
||||||
(heap-remove f 10) (debug " " d)
|
(heap-remove f 10) (debug " " d)
|
||||||
(heap-remove f 5) (debug " " d)
|
(heap-remove f 5) (debug " " d)
|
||||||
(heap-remove f 8) (debug " " d)
|
(heap-remove f 8) (debug " " d)
|
||||||
(heap-remove f 13) (debug " " d)
|
(heap-remove f 13) (debug " " d)
|
||||||
(debug (heap-contains f 11))
|
(debug (heap-contains f 11))
|
||||||
(debug (heap-contains f 123))
|
(debug (heap-contains f 123))
|
||||||
(heap-pop f)
|
(heap-pop f)
|
||||||
(heap-pop f)
|
(heap-pop f)
|
||||||
(heap-pop f)
|
(heap-pop f)
|
||||||
(heap-pop f) (debug " " d)
|
(heap-pop f) (debug " " d)
|
||||||
(debug (heap-contains f 11))
|
(debug (heap-contains f 11))
|
||||||
(debug (heap-contains f 4))
|
(debug (heap-contains f 4))
|
||||||
(debug (heap-tostring f))
|
(debug (heap-tostring f))
|
||||||
(heap-remove f 2)
|
(heap-remove f 2)
|
||||||
(debug (heap-tostring f))
|
(debug (heap-tostring f))
|
||||||
(heap-remove f 3)
|
(heap-remove f 3)
|
||||||
(debug (heap-tostring f))
|
(debug (heap-tostring f))
|
||||||
)
|
)
|
||||||
|
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
(set-main! "exception.ss")
|
(set-main! "exception.ss")
|
||||||
|
|
||||||
(printf-b "exception.ss exited? ~a" (process:exited?))
|
(printf-b "exception.ss exited? ~a" (process:exited?))
|
||||||
|
|
||||||
(printf-b "last exception seen: ~a" (hold (process:exceptions)))
|
(printf-b "last exception seen: ~a" (hold (process:exceptions)))
|
||||||
|
|
||||||
(set-running! true)
|
(set-running! true)
|
||||||
|
|
@ -1,16 +1,16 @@
|
||||||
#| This program starts a thread, the thread raises an exception,
|
#| This program starts a thread, the thread raises an exception,
|
||||||
this tests how MzTake catches exceptions, even if they come from
|
this tests how MzTake catches exceptions, even if they come from
|
||||||
anonymous locations.
|
anonymous locations.
|
||||||
|
|
||||||
We don't even need to bind any variables or add any breaks, we just
|
We don't even need to bind any variables or add any breaks, we just
|
||||||
run the program and catch the exception it throws. |#
|
run the program and catch the exception it throws. |#
|
||||||
|
|
||||||
(define-mztake-process p ("exception.ss"))
|
(define-mztake-process p ("exception.ss"))
|
||||||
|
|
||||||
(printf-b "exception.ss exited? ~a" (process:exited? p))
|
(printf-b "exception.ss exited? ~a" (process:exited? p))
|
||||||
#| Prints out a behavior that tells you whether the debug-process is still running... |#
|
#| Prints out a behavior that tells you whether the debug-process is still running... |#
|
||||||
|
|
||||||
(printf-b "last exception seen: ~a" (hold (process:exceptions p)))
|
(printf-b "last exception seen: ~a" (hold (process:exceptions p)))
|
||||||
#| Prints out the last exception that the program threw |#
|
#| Prints out the last exception that the program threw |#
|
||||||
|
|
||||||
(start/resume p)
|
(start/resume p)
|
||||||
|
|
@ -1,2 +1,2 @@
|
||||||
(module exception mzscheme
|
(module exception mzscheme
|
||||||
(thread (lambda () (raise 'exn:oops-made-a-mztake!))))
|
(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-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-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)))
|
(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"
|
(printf-b "Number of times x updates, should be 12: ~a"
|
||||||
(count-b (merge-e x-before-let
|
(count-b (merge-e x-before-let
|
||||||
x-in-let
|
x-in-let
|
||||||
x-after-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 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 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))
|
(printf-b "x after let, should be (5 9 13 15): ~a" (history-b 4 x-after-let))
|
||||||
|
|
||||||
(set-running! true)
|
(set-running! true)
|
||||||
|
|
@ -1,28 +1,28 @@
|
||||||
#| This program demonstrates how you can add traces to first class, anonymous functions,
|
#| 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
|
such as those passed to map, and the traces will still respond from anywhere
|
||||||
the code is executed.
|
the code is executed.
|
||||||
|
|
||||||
This test also shows how you can bind to the same variable at different locations,
|
This test also shows how you can bind to the same variable at different locations,
|
||||||
and recieve different values, watching how an algorithm unfolds.
|
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
|
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". |#
|
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]
|
(define-mztake-process p ("first-class.ss" [x-before-let 3 29 bind 'x]
|
||||||
[x-in-let 4 25 bind 'x]
|
[x-in-let 4 25 bind 'x]
|
||||||
[x-after-let 5 11 bind 'x]))
|
[x-after-let 5 11 bind 'x]))
|
||||||
|
|
||||||
(printf-b "Number of times x updates, should be 12: ~a"
|
(printf-b "Number of times x updates, should be 12: ~a"
|
||||||
(count-b (merge-e x-before-let
|
(count-b (merge-e x-before-let
|
||||||
x-in-let
|
x-in-let
|
||||||
x-after-let)))
|
x-after-let)))
|
||||||
#| merge-e takes multiple event streams and turns them into one event stream.
|
#| 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,
|
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. |#
|
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 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 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))
|
(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. |#
|
#| Prints out a FIFO list containing the last 4 values seen by each trace. |#
|
||||||
|
|
||||||
(start/resume p)
|
(start/resume p)
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
(module first-class mzscheme
|
(module first-class mzscheme
|
||||||
(map (lambda (x)
|
(map (lambda (x)
|
||||||
(let* ([x (* 2 (+ 1 x))]
|
(let* ([x (* 2 (+ 1 x))]
|
||||||
[x (sub1 x)])
|
[x (sub1 x)])
|
||||||
x))
|
x))
|
||||||
'(2 4 6 7)))
|
'(2 4 6 7)))
|
||||||
|
|
@ -1,28 +1,28 @@
|
||||||
(require (lib "mztake.ss" "mztake")
|
(require (lib "mztake.ss" "mztake")
|
||||||
(lib "animation.ss" "frtime"))
|
(lib "animation.ss" "frtime"))
|
||||||
|
|
||||||
(define/bind (loc "highway.ss" 3 4) speed)
|
(define/bind (loc "highway.ss" 3 4) speed)
|
||||||
|
|
||||||
(printf-b "current speed: ~a" (hold values-of-speed))
|
(printf-b "current speed: ~a" (hold values-of-speed))
|
||||||
(printf-b "last ten speeds: ~a" (history-b 10 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)))
|
(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program)))
|
||||||
values-of-speed)
|
values-of-speed)
|
||||||
|
|
||||||
|
|
||||||
(define (make-speed-gauge speed)
|
(define (make-speed-gauge speed)
|
||||||
(let ([center (make-posn 200 200)])
|
(let ([center (make-posn 200 200)])
|
||||||
(list (make-circle center 170 "black")
|
(list (make-circle center 170 "black")
|
||||||
(make-circle center 160 "white")
|
(make-circle center 160 "white")
|
||||||
(make-rect (make-posn 0 202) 1000 1000 "white")
|
(make-rect (make-posn 0 202) 1000 1000 "white")
|
||||||
(make-line (make-posn 30 201) (make-posn 370 201) "black")
|
(make-line (make-posn 30 201) (make-posn 370 201) "black")
|
||||||
(make-line center
|
(make-line center
|
||||||
(posn+ center (make-posn (- (* 150 (cos (/ speed 30))))
|
(posn+ center (make-posn (- (* 150 (cos (/ speed 30))))
|
||||||
(- (* 150 (sin (/ speed 30))))))
|
(- (* 150 (sin (/ speed 30))))))
|
||||||
"red"))))
|
"red"))))
|
||||||
|
|
||||||
|
|
||||||
(display-shapes (make-speed-gauge (hold values-of-speed)))
|
(display-shapes (make-speed-gauge (hold values-of-speed)))
|
||||||
|
|
||||||
(set-runnning! true)
|
(set-runnning! true)
|
||||||
|
|
|
||||||
|
|
@ -1,55 +1,55 @@
|
||||||
#| The program being debugged (a module in "highway.ss") generates fake speed readings over and over. |#
|
#| 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 |#
|
(require (lib "animation.ss" "frtime")) #| needed for display-shapes |#
|
||||||
|
|
||||||
|
|
||||||
(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed]))
|
(define-mztake-process radar-program ("highway.ss" [values-of-speed 3 4 bind 'speed]))
|
||||||
#| * Create a process to debug highway.ss
|
#| * Create a process to debug highway.ss
|
||||||
|
|
||||||
* Add a tracepoint at line 3, column 4; in the program,
|
* Add a tracepoint at line 3, column 4; in the program,
|
||||||
this is right before the program sleeps for 1 second.
|
this is right before the program sleeps for 1 second.
|
||||||
|
|
||||||
* At this tracepoint, define "values-of-speed" to a FrTime eventstream that
|
* At this tracepoint, define "values-of-speed" to a FrTime eventstream that
|
||||||
recieves events containing the current value of the variable `speed',
|
recieves events containing the current value of the variable `speed',
|
||||||
which are sent every time the code at line 3, column 4, is reached. |#
|
which are sent every time the code at line 3, column 4, is reached. |#
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(printf-b "current speed: ~a" (hold values-of-speed))
|
(printf-b "current speed: ~a" (hold values-of-speed))
|
||||||
#| Prints the current speed being recorded |#
|
#| Prints the current speed being recorded |#
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed))
|
(printf-b "last ten speeds: ~a" (history-b 10 values-of-speed))
|
||||||
#| prints a FIFO list of the last 10 speeds seen |#
|
#| prints a FIFO list of the last 10 speeds seen |#
|
||||||
|
|
||||||
(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program)))
|
(map-e (lambda (a-speed) (when (>= a-speed 55) (pause radar-program)))
|
||||||
values-of-speed)
|
values-of-speed)
|
||||||
#| pauses the program for inspection when a speed is too fast |#
|
#| 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 |#
|
#| produces a list of shapes to draw/animate, taking in a number for speed |#
|
||||||
(define (make-speed-gauge speed)
|
(define (make-speed-gauge speed)
|
||||||
(let ([center (make-posn 200 200)])
|
(let ([center (make-posn 200 200)])
|
||||||
(list (make-circle center 170 "black")
|
(list (make-circle center 170 "black")
|
||||||
(make-circle center 160 "white")
|
(make-circle center 160 "white")
|
||||||
(make-rect (make-posn 0 202) 1000 1000 "white")
|
(make-rect (make-posn 0 202) 1000 1000 "white")
|
||||||
(make-line (make-posn 30 201) (make-posn 370 201) "black")
|
(make-line (make-posn 30 201) (make-posn 370 201) "black")
|
||||||
#| draws the the half-circle guage |#
|
#| draws the the half-circle guage |#
|
||||||
|
|
||||||
#| draws the red line for the current speed |#
|
#| draws the red line for the current speed |#
|
||||||
(make-line center
|
(make-line center
|
||||||
(posn+ center (make-posn (- (* 150 (cos (/ speed 30))))
|
(posn+ center (make-posn (- (* 150 (cos (/ speed 30))))
|
||||||
(- (* 150 (sin (/ speed 30))))))
|
(- (* 150 (sin (/ speed 30))))))
|
||||||
"red"))))
|
"red"))))
|
||||||
|
|
||||||
|
|
||||||
(display-shapes (make-speed-gauge (hold values-of-speed)))
|
(display-shapes (make-speed-gauge (hold values-of-speed)))
|
||||||
#| display-shapes takes a list of objects to draw.
|
#| display-shapes takes a list of objects to draw.
|
||||||
(hold values-of-speed) keeps track of the current value of speed,
|
(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,
|
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. |#
|
which gets called every time values-of-speed gets a new speed. |#
|
||||||
|
|
||||||
|
|
||||||
(start/resume radar-program) #| Start the process for highway.ss |#
|
(start/resume radar-program) #| Start the process for highway.ss |#
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
(module highway mzscheme
|
(module highway mzscheme
|
||||||
(let loop ([speed 0])
|
(let loop ([speed 0])
|
||||||
(sleep 1)
|
(sleep 1)
|
||||||
;; Generate some fake speeds readings:
|
;; Generate some fake speeds readings:
|
||||||
(loop (+ speed 4))))
|
(loop (+ speed 4))))
|
||||||
|
|
@ -1,25 +1,25 @@
|
||||||
(require (lib "graphics.ss" "graphics")
|
(require (lib "graphics.ss" "graphics")
|
||||||
(lib "match.ss"))
|
(lib "match.ss"))
|
||||||
|
|
||||||
|
|
||||||
(open-graphics)
|
(open-graphics)
|
||||||
(define window (open-viewport "Debugger" 400 400))
|
(define window (open-viewport "Debugger" 400 400))
|
||||||
|
|
||||||
(define/bind (loc "montecarlo.ss" 13 13) x y pi)
|
(define/bind (loc "montecarlo.ss" 13 13) x y pi)
|
||||||
|
|
||||||
|
|
||||||
(printf-b "total points chosen: ~a" (count-b (changes x)))
|
(printf-b "total points chosen: ~a" (count-b (changes x)))
|
||||||
(printf-b "current computed value of pi: ~a" current-pi)
|
(printf-b "current computed value of pi: ~a" current-pi)
|
||||||
(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653))))
|
(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653))))
|
||||||
|
|
||||||
|
|
||||||
((draw-viewport window) "wheat")
|
((draw-viewport window) "wheat")
|
||||||
((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black")
|
((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black")
|
||||||
((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna")
|
((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)
|
(map-e (match-lambda [(x y) ((draw-solid-ellipse window) (make-posn x y)
|
||||||
3 3 "black")])
|
3 3 "black")])
|
||||||
(changes (list x y)))
|
(changes (list x y)))
|
||||||
|
|
||||||
(set-running! true)
|
(set-running! true)
|
||||||
|
|
|
||||||
|
|
@ -1,71 +1,71 @@
|
||||||
#| The program being debugged (a module in the file "montecarlo.ss") runs
|
#| The program being debugged (a module in the file "montecarlo.ss") runs
|
||||||
an infinite loop, binding "x" and "y" to a random number between
|
an infinite loop, binding "x" and "y" to a random number between
|
||||||
[-199,199], each iteration.
|
[-199,199], each iteration.
|
||||||
|
|
||||||
This is supposed to represent throwing darts at a circular dartboard.
|
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
|
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
|
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,
|
hits to total tries, multiplied by 4, approaches "pi" with some error,
|
||||||
usually closing in around 3.13. The target program does this computation
|
usually closing in around 3.13. The target program does this computation
|
||||||
and binds it to the variable "pi".
|
and binds it to the variable "pi".
|
||||||
|
|
||||||
This MzTake script visualizes the process, drawing points (darts)
|
This MzTake script visualizes the process, drawing points (darts)
|
||||||
that "hit" the circle, a radius of 200 pixels from the center of
|
that "hit" the circle, a radius of 200 pixels from the center of
|
||||||
the window. |#
|
the window. |#
|
||||||
|
|
||||||
|
|
||||||
(require (lib "graphics.ss" "graphics"))
|
(require (lib "graphics.ss" "graphics"))
|
||||||
#| Needed for open-graphics, open-viewport, and draw-solid-ellipse |#
|
#| Needed for open-graphics, open-viewport, and draw-solid-ellipse |#
|
||||||
|
|
||||||
|
|
||||||
(open-graphics)
|
(open-graphics)
|
||||||
(define window (open-viewport "Debugger" 400 400))
|
(define window (open-viewport "Debugger" 400 400))
|
||||||
#| This file doesn't animate a list of objects since the number of
|
#| This file doesn't animate a list of objects since the number of
|
||||||
objects quickly reaches the thousands (slowing drawing time severly),
|
objects quickly reaches the thousands (slowing drawing time severly),
|
||||||
and the dots are stationary -- so we just keep drawing the circles at
|
and the dots are stationary -- so we just keep drawing the circles at
|
||||||
the random coordinates that we get from the target program.
|
the random coordinates that we get from the target program.
|
||||||
|
|
||||||
See the doc for more information on this kind of drawing. |#
|
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)]))
|
(define-mztake-process p ("montecarlo.ss" [x/y/pi-trace 13 13 bind '(x y pi)]))
|
||||||
#| * Create a process to debug montecarlo.ss
|
#| * Create a process to debug montecarlo.ss
|
||||||
|
|
||||||
* Add a tracepoint at line 13, column 13; in the program,
|
* Add a tracepoint at line 13, column 13; in the program,
|
||||||
this is right after the cond determined that the point *is* within
|
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.
|
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
|
* 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"
|
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. |#
|
in a list, every time the code at line 13, column 18, is reached. |#
|
||||||
|
|
||||||
|
|
||||||
(define x/y/pi (hold x/y/pi-trace))
|
(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
|
#| 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. |#
|
holds the current (latest) list of values from x/y/pi-trace. |#
|
||||||
|
|
||||||
|
|
||||||
(define x (+ 200 (first x/y/pi)))
|
(define x (+ 200 (first x/y/pi)))
|
||||||
(define y (+ 200 (second x/y/pi)))
|
(define y (+ 200 (second x/y/pi)))
|
||||||
(define current-pi (third x/y/pi))
|
(define current-pi (third x/y/pi))
|
||||||
#| The local, time-varying variables "x" "y" and "current-pi" are bound to
|
#| The local, time-varying variables "x" "y" and "current-pi" are bound to
|
||||||
their respective values in the list from x/y/pi. |#
|
their respective values in the list from x/y/pi. |#
|
||||||
|
|
||||||
|
|
||||||
(printf-b "total points chosen: ~a" (count-b (changes x)))
|
(printf-b "total points chosen: ~a" (count-b (changes x)))
|
||||||
(printf-b "current computed value of pi: ~a" current-pi)
|
(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...
|
(printf-b "log error: ~a" (log (abs (- current-pi 3.141592653)))) ;; the more negative, the better...
|
||||||
|
|
||||||
((draw-viewport window) "wheat")
|
((draw-viewport window) "wheat")
|
||||||
((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black")
|
((draw-solid-ellipse window) (make-posn -4 -4) 408 408 "black")
|
||||||
((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna")
|
((draw-solid-ellipse window) (make-posn 0 0) 400 400 "sienna")
|
||||||
#| Draw the dartboard |#
|
#| Draw the dartboard |#
|
||||||
|
|
||||||
(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y))
|
(map-e (lambda (x/y) ((draw-solid-ellipse window) (make-posn (first x/y) (second x/y))
|
||||||
3 3 "black"))
|
3 3 "black"))
|
||||||
(changes (list x y)))
|
(changes (list x y)))
|
||||||
#| Every time the list (x y) changes (x and y get a new value), take this latest list value ("==>")
|
#| 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. |#
|
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 |#
|
(start/resume p) #| Start the process for montecarlo.ss |#
|
||||||
|
|
|
||||||
|
|
@ -1,15 +1,15 @@
|
||||||
(module montecarlo mzscheme
|
(module montecarlo mzscheme
|
||||||
;; a seed specially chosen because it isn't terribly erratic when converging on pi
|
;; a seed specially chosen because it isn't terribly erratic when converging on pi
|
||||||
(random-seed 846259386)
|
(random-seed 846259386)
|
||||||
|
|
||||||
(define (run)
|
(define (run)
|
||||||
(let loop ([hits 1]
|
(let loop ([hits 1]
|
||||||
[total 1])
|
[total 1])
|
||||||
(let* ([x (- (random 401) 200)]
|
(let* ([x (- (random 401) 200)]
|
||||||
[y (- (random 401) 200)]
|
[y (- (random 401) 200)]
|
||||||
[length (sqrt (+ (* x x) (* y y)))]
|
[length (sqrt (+ (* x x) (* y y)))]
|
||||||
[pi (* 4. (/ hits total))])
|
[pi (* 4. (/ hits total))])
|
||||||
(cond [(length . < . 200)
|
(cond [(length . < . 200)
|
||||||
(loop (add1 hits) (add1 total))]
|
(loop (add1 hits) (add1 total))]
|
||||||
[else (loop hits (add1 total))]))))
|
[else (loop hits (add1 total))]))))
|
||||||
(run))
|
(run))
|
||||||
|
|
@ -1,44 +1,44 @@
|
||||||
(require (lib "graphics.ss" "graphics")
|
(require (lib "graphics.ss" "graphics")
|
||||||
(lib "mztake.ss" "mztake")
|
(lib "mztake.ss" "mztake")
|
||||||
(lifted mzscheme
|
(lifted mzscheme
|
||||||
make-hash-table
|
make-hash-table
|
||||||
hash-table-put!
|
hash-table-put!
|
||||||
hash-table-get))
|
hash-table-get))
|
||||||
|
|
||||||
|
|
||||||
(open-graphics)
|
(open-graphics)
|
||||||
(define window (open-viewport "Debugger" 600 500))
|
(define window (open-viewport "Debugger" 600 500))
|
||||||
((draw-viewport window) (make-rgb 0.95 0.95 0.95))
|
((draw-viewport window) (make-rgb 0.95 0.95 0.95))
|
||||||
|
|
||||||
|
|
||||||
(define/bind (loc "random.ss" 4 6) x)
|
(define/bind (loc "random.ss" 4 6) x)
|
||||||
|
|
||||||
|
|
||||||
(define largest-bin 0)
|
(define largest-bin 0)
|
||||||
(define valcount (make-hash-table))
|
(define valcount (make-hash-table))
|
||||||
|
|
||||||
|
|
||||||
(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin)))
|
(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin)))
|
||||||
|
|
||||||
|
|
||||||
(map-e (lambda (x)
|
(map-e (lambda (x)
|
||||||
(let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))]
|
(let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))]
|
||||||
[color (/ new-cnt (add1 largest-bin))])
|
[color (/ new-cnt (add1 largest-bin))])
|
||||||
|
|
||||||
(when (= largest-bin 250)
|
(when (= largest-bin 250)
|
||||||
(kill p))
|
(kill p))
|
||||||
|
|
||||||
(when (> new-cnt largest-bin) (set! largest-bin new-cnt))
|
(when (> new-cnt largest-bin) (set! largest-bin new-cnt))
|
||||||
|
|
||||||
(hash-table-put! valcount x new-cnt)
|
(hash-table-put! valcount x new-cnt)
|
||||||
|
|
||||||
((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt)))
|
((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt)))
|
||||||
6 10 ;; width height
|
6 10 ;; width height
|
||||||
(make-rgb 0 (* 0.75 color) color))))
|
(make-rgb 0 (* 0.75 color) color))))
|
||||||
x-trace)
|
x-trace)
|
||||||
|
|
||||||
|
|
||||||
(printf-b "count: ~a" (count-b x-trace))
|
(printf-b "count: ~a" (count-b x-trace))
|
||||||
|
|
||||||
|
|
||||||
(set-running! true)
|
(set-running! true)
|
||||||
|
|
@ -1,107 +1,107 @@
|
||||||
#| The program being debugged (a module in the file "random.ss") runs an infinite loop,
|
#| 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.
|
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,
|
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
|
in sync with the execution of "random.ss". This will run until one
|
||||||
bar reaches the top of the screen.
|
bar reaches the top of the screen.
|
||||||
|
|
||||||
This histogram provides three pieces of information:
|
This histogram provides three pieces of information:
|
||||||
* Each bar represents a bin, the height represents how many times
|
* Each bar represents a bin, the height represents how many times
|
||||||
that "random" number was generated.
|
that "random" number was generated.
|
||||||
|
|
||||||
* The brighter the blue, the faster that bin is growing compared
|
* The brighter the blue, the faster that bin is growing compared
|
||||||
to the others. The darker, the slower.
|
to the others. The darker, the slower.
|
||||||
|
|
||||||
* You can see a history of speeds over time based on how the colors
|
* You can see a history of speeds over time based on how the colors
|
||||||
change in each bin.
|
change in each bin.
|
||||||
|
|
||||||
Try looking for small groupings of bins where all are light, or all
|
Try looking for small groupings of bins where all are light, or all
|
||||||
are dark -- these represent small trends in the numbers.
|
are dark -- these represent small trends in the numbers.
|
||||||
|
|
||||||
Look for tortoises that stay low and black, and hares which are very
|
Look for tortoises that stay low and black, and hares which are very
|
||||||
active and bright.
|
active and bright.
|
||||||
|
|
||||||
The bars drag a bit when moving upwards (the height goes up by 2, but
|
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
|
the redrawing of the latest color goes down 10 pixels) so that you can
|
||||||
spot vertical trends more easily. |#
|
spot vertical trends more easily. |#
|
||||||
|
|
||||||
|
|
||||||
(require (lib "graphics.ss" "graphics")
|
(require (lib "graphics.ss" "graphics")
|
||||||
#| Needed for open-graphics, open-viewport, and draw-solid-ellipse |#
|
#| Needed for open-graphics, open-viewport, and draw-solid-ellipse |#
|
||||||
|
|
||||||
(lifted mzscheme
|
(lifted mzscheme
|
||||||
make-hash-table
|
make-hash-table
|
||||||
hash-table-put!
|
hash-table-put!
|
||||||
hash-table-get))
|
hash-table-get))
|
||||||
#| "Lifted" is explained in FrTime's own documentation (plt/collects/frtime/doc.txt)
|
#| "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
|
Quickly put, lifting extends the functions listed above so they can take FrTime time-varying
|
||||||
values (such as MzTake traces) as arguments. |#
|
values (such as MzTake traces) as arguments. |#
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(open-graphics)
|
(open-graphics)
|
||||||
(define window (open-viewport "Debugger" 600 500))
|
(define window (open-viewport "Debugger" 600 500))
|
||||||
((draw-viewport window) (make-rgb 0.95 0.95 0.95))
|
((draw-viewport window) (make-rgb 0.95 0.95 0.95))
|
||||||
#| This file doesn't animate a list of objects since the number of
|
#| This file doesn't animate a list of objects since the number of
|
||||||
objects quickly reaches the thousands (slowing drawing time severly),
|
objects quickly reaches the thousands (slowing drawing time severly),
|
||||||
and they are stationary -- so we just keep drawing the circles at
|
and they are stationary -- so we just keep drawing the circles at
|
||||||
their new heights based on the value in the hashtable.
|
their new heights based on the value in the hashtable.
|
||||||
|
|
||||||
See the doc for more information on this kind of drawing. |#
|
See the doc for more information on this kind of drawing. |#
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define-mztake-process p ("random.ss" [x-trace 4 6 bind 'x]))
|
(define-mztake-process p ("random.ss" [x-trace 4 6 bind 'x]))
|
||||||
#| * Create a process to debug random.ss
|
#| * Create a process to debug random.ss
|
||||||
|
|
||||||
* Add a tracepoint at line 4, column 6; in the program,
|
* Add a tracepoint at line 4, column 6; in the program,
|
||||||
this is right before the next iteration of the loop is called,
|
this is right before the next iteration of the loop is called,
|
||||||
->(loop (random 200))
|
->(loop (random 200))
|
||||||
|
|
||||||
* At this tracepoint, define "x-trace" to a FrTime eventstream that
|
* At this tracepoint, define "x-trace" to a FrTime eventstream that
|
||||||
recieves events containing the latest value of "x" seen,
|
recieves events containing the latest value of "x" seen,
|
||||||
every time the code at line 4, column 6, is reached. |#
|
every time the code at line 4, column 6, is reached. |#
|
||||||
|
|
||||||
(define largest-bin 0)
|
(define largest-bin 0)
|
||||||
(define valcount (make-hash-table))
|
(define valcount (make-hash-table))
|
||||||
#| this will hold the counts for the histogram
|
#| this will hold the counts for the histogram
|
||||||
x is the key, and the number of times x shows up is the value |#
|
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)))
|
(hold (x-trace . -=> .(printf-b "largest count: ~a" largest-bin)))
|
||||||
#| Prints out the largest count every time we get a new x-trace event |#
|
#| Prints out the largest count every time we get a new x-trace event |#
|
||||||
|
|
||||||
|
|
||||||
(map-e (lambda (x)
|
(map-e (lambda (x)
|
||||||
(let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))]
|
(let* ([new-cnt (add1 (hash-table-get valcount x (lambda () 0)))]
|
||||||
[color (/ new-cnt (add1 largest-bin))])
|
[color (/ new-cnt (add1 largest-bin))])
|
||||||
|
|
||||||
(when (= largest-bin 250)
|
(when (= largest-bin 250)
|
||||||
(kill p))
|
(kill p))
|
||||||
; when one of the bars reaches the top of the screen, kill the program.
|
; when one of the bars reaches the top of the screen, kill the program.
|
||||||
|
|
||||||
(when (> new-cnt largest-bin) (set! largest-bin new-cnt))
|
(when (> new-cnt largest-bin) (set! largest-bin new-cnt))
|
||||||
; keep track of the largest count
|
; keep track of the largest count
|
||||||
|
|
||||||
(hash-table-put! valcount x new-cnt)
|
(hash-table-put! valcount x new-cnt)
|
||||||
;; increment the value in the hashtable, starting from 0 if none exists.
|
;; increment the value in the hashtable, starting from 0 if none exists.
|
||||||
|
|
||||||
((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt)))
|
((draw-solid-rectangle window) (make-posn (* x 6) (- 500 (* 2 new-cnt)))
|
||||||
6 10 ;; width height
|
6 10 ;; width height
|
||||||
(make-rgb 0 (* 0.75 color) color))))
|
(make-rgb 0 (* 0.75 color) color))))
|
||||||
x-trace)
|
x-trace)
|
||||||
#| Every time x-trace gets a new value, take this latest value and pass it to a function
|
#| 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
|
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),
|
(* 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.
|
making a color (MAKE-RGB) that is lighter based on how fast it is growing.
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
(printf-b "count: ~a" (count-b x-trace))
|
(printf-b "count: ~a" (count-b x-trace))
|
||||||
#| prints the count of how many events x-trace got,
|
#| prints the count of how many events x-trace got,
|
||||||
aka how many values are in the histogram and on the screen.
|
aka how many values are in the histogram and on the screen.
|
||||||
|#
|
|#
|
||||||
|
|
||||||
|
|
||||||
(start/resume p)
|
(start/resume p)
|
||||||
;; Start the process for random.ss
|
;; Start the process for random.ss
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
(module random mzscheme
|
(module random mzscheme
|
||||||
(define (run)
|
(define (run)
|
||||||
(let loop ([x (random 100)])
|
(let loop ([x (random 100)])
|
||||||
(loop (random 100))))
|
(loop (random 100))))
|
||||||
(run))
|
(run))
|
||||||
|
|
@ -1,63 +1,63 @@
|
||||||
#| The program being debugged (a module in "sine.ss") runs an infinite loop,
|
#| 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.
|
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". |#
|
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
|
(require (lib "animation.ss" "frtime")) ;; needed for display-shapes
|
||||||
|
|
||||||
|
|
||||||
(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)]))
|
(define-mztake-process p ("sine.ss" [x/sinx-trace 5 8 bind '(x sin-x)]))
|
||||||
#| * Create a process to debug sine.ss
|
#| * Create a process to debug sine.ss
|
||||||
|
|
||||||
* Add a tracepoint at line 5, column 8; in the program,
|
* Add a tracepoint at line 5, column 8; in the program,
|
||||||
this is right after the let values are bound, ->(if (x ...)
|
this is right after the let values are bound, ->(if (x ...)
|
||||||
|
|
||||||
* At this tracepoint, define "x/sinx-trace" to be a FrTime eventstream that
|
* At this tracepoint, define "x/sinx-trace" to be a FrTime eventstream that
|
||||||
recieves events containing a list of two elements -- the current values
|
recieves events containing a list of two elements -- the current values
|
||||||
of the variables `x' and `sin-x', respectively. |#
|
of the variables `x' and `sin-x', respectively. |#
|
||||||
|
|
||||||
|
|
||||||
(define x/sinx (hold x/sinx-trace))
|
(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) |#
|
#| 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 x (first x/sinx))
|
||||||
(define sin-x (second x/sinx))
|
(define sin-x (second x/sinx))
|
||||||
#| the local variables x, sin-x hold their current values |#
|
#| the local variables x, sin-x hold their current values |#
|
||||||
|
|
||||||
|
|
||||||
(printf-b "x: ~a" x)
|
(printf-b "x: ~a" x)
|
||||||
(printf-b "sin(x/20): ~a" sin-x)
|
(printf-b "sin(x/20): ~a" sin-x)
|
||||||
#| Print the current values of x and sin-x |#
|
#| Print the current values of x and sin-x |#
|
||||||
|
|
||||||
(printf-b "largest x: ~a sin(x/20): ~a"
|
(printf-b "largest x: ~a sin(x/20): ~a"
|
||||||
(largest-val-b (changes (first x/sinx)))
|
(largest-val-b (changes (first x/sinx)))
|
||||||
(largest-val-b (changes (second x/sinx))))
|
(largest-val-b (changes (second x/sinx))))
|
||||||
|
|
||||||
(printf-b "smallest x:~a sin(x/20):~a"
|
(printf-b "smallest x:~a sin(x/20):~a"
|
||||||
(smallest-val-b (changes (first x/sinx)))
|
(smallest-val-b (changes (first x/sinx)))
|
||||||
(smallest-val-b (changes (second x/sinx))))
|
(smallest-val-b (changes (second x/sinx))))
|
||||||
|
|
||||||
|
|
||||||
(display-shapes
|
(display-shapes
|
||||||
(list* (make-line (make-posn 0 200) (make-posn 400 200) "gray")
|
(list* (make-line (make-posn 0 200) (make-posn 400 200) "gray")
|
||||||
(make-line (make-posn 200 0) (make-posn 200 400) "gray")
|
(make-line (make-posn 200 0) (make-posn 200 400) "gray")
|
||||||
#| draw horizontal and vertical gray lines |#
|
#| draw horizontal and vertical gray lines |#
|
||||||
|
|
||||||
(let ([x (+ 200 x)]
|
(let ([x (+ 200 x)]
|
||||||
[sin-x (+ 200 (* 100 sin-x))])
|
[sin-x (+ 200 (* 100 sin-x))])
|
||||||
(history-b 50 (changes (make-circle
|
(history-b 50 (changes (make-circle
|
||||||
(make-posn x sin-x)
|
(make-posn x sin-x)
|
||||||
5
|
5
|
||||||
(if (< 200 sin-x)
|
(if (< 200 sin-x)
|
||||||
(if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |#
|
(if (< 200 x) "blue" "darkblue") #| Quadrants 3 and 4 |#
|
||||||
(if (< 200 x) "red" "darkred")))))))) #| 1 and 2 |#
|
(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)
|
#| 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.
|
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):
|
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.
|
* 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. |#
|
* 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 |#
|
(start/resume p) #| Start the process for sine.ss |#
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
(module sine mzscheme
|
(module sine mzscheme
|
||||||
(define (run)
|
(define (run)
|
||||||
(let loop ([x -200])
|
(let loop ([x -200])
|
||||||
(let ([sin-x (sin (/ x 20.0))])
|
(let ([sin-x (sin (/ x 20.0))])
|
||||||
(if (x . < . 200)
|
(if (x . < . 200)
|
||||||
(loop (add1 x))
|
(loop (add1 x))
|
||||||
(loop -200)))))
|
(loop -200)))))
|
||||||
(run))
|
(run))
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,7 +1,7 @@
|
||||||
(module info (lib "infotab.ss" "setup")
|
(module info (lib "infotab.ss" "setup")
|
||||||
(define name "Debugger")
|
(define name "Debugger")
|
||||||
(define tools '(("mztake-lang.ss") ("debug-tool.ss")))
|
(define tools '(("mztake-lang.ss") ("debug-tool.ss")))
|
||||||
(define blurb '("MzTake is a scripted debugger for PLT Scheme." "A debugging tool for DrScheme"))
|
(define blurb '("MzTake is a scripted debugger for PLT Scheme." "A debugging tool for DrScheme"))
|
||||||
(define tool-names '("MzTake Debugger" "Skipper"))
|
(define tool-names '("MzTake Debugger" "Skipper"))
|
||||||
(define tool-icons '(("emblem-ohno.png" "mztake" "icons") ("icon-big.png" "mztake" "icons")))
|
(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 compiled
|
||||||
del private\compiled
|
del private\compiled
|
||||||
|
|
|
||||||
|
|
@ -1,20 +1,20 @@
|
||||||
(module make-plt mzscheme
|
(module make-plt mzscheme
|
||||||
|
|
||||||
(require (lib "pack.ss" "setup")
|
(require (lib "pack.ss" "setup")
|
||||||
#;(lib "util.ss" "planet"))
|
#;(lib "util.ss" "planet"))
|
||||||
|
|
||||||
(define (my-filter path)
|
(define (my-filter path)
|
||||||
(and (std-filter path)
|
(and (std-filter path)
|
||||||
(not (or (regexp-match #rx".svn$" path)
|
(not (or (regexp-match #rx".svn$" path)
|
||||||
(regexp-match #rx".bak$" path)
|
(regexp-match #rx".bak$" path)
|
||||||
(regexp-match #rx".1$" path)
|
(regexp-match #rx".1$" path)
|
||||||
(regexp-match #rx"-uncommented.ss$" path)
|
(regexp-match #rx"-uncommented.ss$" path)
|
||||||
(regexp-match #rx"make" path)))))
|
(regexp-match #rx"make" path)))))
|
||||||
|
|
||||||
|
|
||||||
;without frtime bundled:
|
;without frtime bundled:
|
||||||
(pack-collections "mztake-208.plt" "MzTake Debugger"
|
(pack-collections "mztake-208.plt" "MzTake Debugger"
|
||||||
'(("mztake")) #t '(("frtime")("stepper")) my-filter #f)
|
'(("mztake")) #t '(("frtime")("stepper")) my-filter #f)
|
||||||
|
|
||||||
(pack-collections "mztake-frtime-pre-208.plt" "MzTake Debugger"
|
(pack-collections "mztake-frtime-pre-208.plt" "MzTake Debugger"
|
||||||
'(("mztake")("frtime")) #t '(("stepper")) my-filter #f))
|
'(("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
|
(module mztake-lang mzscheme
|
||||||
(require "mztake.ss"
|
(require "mztake.ss"
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "class.ss")
|
(lib "class.ss")
|
||||||
(lib "unitsig.ss")
|
(lib "unitsig.ss")
|
||||||
(lib "bitmap-label.ss" "mrlib")
|
(lib "bitmap-label.ss" "mrlib")
|
||||||
(lib "contract.ss")
|
(lib "contract.ss")
|
||||||
(lib "mred.ss" "mred")
|
(lib "mred.ss" "mred")
|
||||||
(lib "tool.ss" "drscheme")
|
(lib "tool.ss" "drscheme")
|
||||||
(lib "framework.ss" "framework")
|
(lib "framework.ss" "framework")
|
||||||
(lib "string-constant.ss" "string-constants"))
|
(lib "string-constant.ss" "string-constants"))
|
||||||
|
|
||||||
(provide tool@)
|
(provide tool@)
|
||||||
|
|
||||||
(define tool@
|
(define tool@
|
||||||
(unit/sig drscheme:tool-exports^
|
(unit/sig drscheme:tool-exports^
|
||||||
(import drscheme:tool^)
|
(import drscheme:tool^)
|
||||||
|
|
||||||
;############################MZTAKE LANGUAGE RELATED FUNCTIONS##############################################
|
;############################MZTAKE LANGUAGE RELATED FUNCTIONS##############################################
|
||||||
(define (phase1) (void))
|
(define (phase1) (void))
|
||||||
(define (phase2)
|
(define (phase2)
|
||||||
(drscheme:language-configuration:add-language
|
(drscheme:language-configuration:add-language
|
||||||
(make-object ((drscheme:language:get-default-mixin) (make-mztake-language mztake-language%)))))
|
(make-object ((drscheme:language:get-default-mixin) (make-mztake-language mztake-language%)))))
|
||||||
|
|
||||||
(define (make-mztake-language base)
|
(define (make-mztake-language base)
|
||||||
(class (drscheme:language:module-based-language->language-mixin
|
(class (drscheme:language:module-based-language->language-mixin
|
||||||
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
||||||
base))
|
base))
|
||||||
(field (watch-list empty))
|
(field (watch-list empty))
|
||||||
(inherit get-language-position)
|
(inherit get-language-position)
|
||||||
(define/override (on-execute settings run-in-user-thread)
|
(define/override (on-execute settings run-in-user-thread)
|
||||||
(let ([drs-eventspace (current-eventspace)])
|
(let ([drs-eventspace (current-eventspace)])
|
||||||
(super on-execute settings run-in-user-thread)
|
(super on-execute settings run-in-user-thread)
|
||||||
(run-in-user-thread
|
(run-in-user-thread
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ([new-watch (namespace-variable-value 'render)]
|
(let ([new-watch (namespace-variable-value 'render)]
|
||||||
[set-evspc (namespace-variable-value 'set-eventspace)])
|
[set-evspc (namespace-variable-value 'set-eventspace)])
|
||||||
(set-evspc drs-eventspace)
|
(set-evspc drs-eventspace)
|
||||||
(set! watch-list
|
(set! watch-list
|
||||||
((if (weak-member new-watch watch-list)
|
((if (weak-member new-watch watch-list)
|
||||||
identity
|
identity
|
||||||
(lambda (r) (cons (make-weak-box new-watch) r)))
|
(lambda (r) (cons (make-weak-box new-watch) r)))
|
||||||
(filter weak-box-value watch-list))))))))
|
(filter weak-box-value watch-list))))))))
|
||||||
|
|
||||||
(define/override (render-value/format value settings port width)
|
(define/override (render-value/format value settings port width)
|
||||||
(super render-value/format (watch watch-list value)
|
(super render-value/format (watch watch-list value)
|
||||||
settings port width))
|
settings port width))
|
||||||
(define/override (render-value value settings port)
|
(define/override (render-value value settings port)
|
||||||
(super render-value (watch watch-list value)
|
(super render-value (watch watch-list value)
|
||||||
settings port))
|
settings port))
|
||||||
(define/override (use-namespace-require/copy?) #t)
|
(define/override (use-namespace-require/copy?) #t)
|
||||||
(super-instantiate ())))
|
(super-instantiate ())))
|
||||||
|
|
||||||
|
|
||||||
(define mztake-language%
|
(define mztake-language%
|
||||||
(class* object% (drscheme:language:simple-module-based-language<%>)
|
(class* object% (drscheme:language:simple-module-based-language<%>)
|
||||||
(define/public (get-language-numbers)
|
(define/public (get-language-numbers)
|
||||||
'(1000 -400))
|
'(1000 -400))
|
||||||
(define/public (get-language-position)
|
(define/public (get-language-position)
|
||||||
(list (string-constant experimental-languages) "MzTake"))
|
(list (string-constant experimental-languages) "MzTake"))
|
||||||
(define/public (get-module)
|
(define/public (get-module)
|
||||||
'(lib "mztake-syntax.ss" "mztake"))
|
'(lib "mztake-syntax.ss" "mztake"))
|
||||||
(define/public (get-one-line-summary)
|
(define/public (get-one-line-summary)
|
||||||
(format "MzTake Debugger (~a)" mztake-version))
|
(format "MzTake Debugger (~a)" mztake-version))
|
||||||
(define/public (get-language-url) #f)
|
(define/public (get-language-url) #f)
|
||||||
(define/public (get-reader)
|
(define/public (get-reader)
|
||||||
(lambda (name port offsets)
|
(lambda (name port offsets)
|
||||||
(let ([v (read-syntax name port offsets)])
|
(let ([v (read-syntax name port offsets)])
|
||||||
(if (eof-object? v)
|
(if (eof-object? v)
|
||||||
v
|
v
|
||||||
(namespace-syntax-introduce v)))))
|
(namespace-syntax-introduce v)))))
|
||||||
(super-instantiate ())))
|
(super-instantiate ())))
|
||||||
|
|
||||||
;;;;;;;;;;;;;FRTIME REPL STUFF;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;FRTIME REPL STUFF;;;;;;;;;;;;;;;;;;;;;;
|
||||||
(define (weak-member obj lis)
|
(define (weak-member obj lis)
|
||||||
(let ([cmp (lambda (v) (eq? v obj))])
|
(let ([cmp (lambda (v) (eq? v obj))])
|
||||||
(let loop ([lis lis])
|
(let loop ([lis lis])
|
||||||
(and (cons? lis)
|
(and (cons? lis)
|
||||||
(or
|
(or
|
||||||
(cond
|
(cond
|
||||||
[(weak-box-value (first lis)) => cmp]
|
[(weak-box-value (first lis)) => cmp]
|
||||||
[else false])
|
[else false])
|
||||||
(loop (rest lis)))))))
|
(loop (rest lis)))))))
|
||||||
|
|
||||||
(define (watch watch-list value)
|
(define (watch watch-list value)
|
||||||
(foldl
|
(foldl
|
||||||
(lambda (wb acc)
|
(lambda (wb acc)
|
||||||
(cond
|
(cond
|
||||||
[(weak-box-value wb)
|
[(weak-box-value wb)
|
||||||
=> (lambda (f) (f acc))]
|
=> (lambda (f) (f acc))]
|
||||||
[else acc]))
|
[else acc]))
|
||||||
value
|
value
|
||||||
watch-list))
|
watch-list))
|
||||||
;###########################################################################################################
|
;###########################################################################################################
|
||||||
|
|
||||||
|
|
||||||
(define debugger-bitmap
|
(define debugger-bitmap
|
||||||
(bitmap-label-maker
|
(bitmap-label-maker
|
||||||
"Syntax Location"
|
"Syntax Location"
|
||||||
(build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png")))
|
(build-path (collection-path "mztake" "icons") "stock_macro-check-brackets-16.png")))
|
||||||
|
|
||||||
(define (debugger-unit-frame-mixin super%)
|
(define (debugger-unit-frame-mixin super%)
|
||||||
(class super%
|
(class super%
|
||||||
|
|
||||||
(inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar)
|
(inherit get-button-panel get-interactions-text get-definitions-text get-menu-bar)
|
||||||
|
|
||||||
(super-instantiate ())
|
(super-instantiate ())
|
||||||
|
|
||||||
(define debugger-button
|
(define debugger-button
|
||||||
(make-object button%
|
(make-object button%
|
||||||
(debugger-bitmap this)
|
(debugger-bitmap this)
|
||||||
(get-button-panel)
|
(get-button-panel)
|
||||||
(lambda (button evt)
|
(lambda (button evt)
|
||||||
(let* ([pos (send (get-definitions-text) get-start-position)]
|
(let* ([pos (send (get-definitions-text) get-start-position)]
|
||||||
[line (send (get-definitions-text) position-paragraph pos)]
|
[line (send (get-definitions-text) position-paragraph pos)]
|
||||||
[column (- pos (send (get-definitions-text) line-start-position
|
[column (- pos (send (get-definitions-text) line-start-position
|
||||||
(send (get-definitions-text) position-line pos)))])
|
(send (get-definitions-text) position-line pos)))])
|
||||||
|
|
||||||
(message-box "Syntax Location"
|
(message-box "Syntax Location"
|
||||||
(format "Line: ~a~nColumn: ~a" (add1 line) column))))))
|
(format "Line: ~a~nColumn: ~a" (add1 line) column))))))
|
||||||
(send (get-button-panel) change-children
|
(send (get-button-panel) change-children
|
||||||
(lambda (_) (cons debugger-button (remq debugger-button _))))))
|
(lambda (_) (cons debugger-button (remq debugger-button _))))))
|
||||||
|
|
||||||
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))
|
(drscheme:get/extend:extend-unit-frame debugger-unit-frame-mixin))))
|
||||||
|
|
@ -1,71 +1,71 @@
|
||||||
(module mztake-structs mzscheme
|
(module mztake-structs mzscheme
|
||||||
(require (prefix frp: (lib "frp.ss" "frtime"))
|
(require (prefix frp: (lib "frp.ss" "frtime"))
|
||||||
(lib "more-useful-code.ss" "mztake" "private"))
|
(lib "more-useful-code.ss" "mztake" "private"))
|
||||||
|
|
||||||
(provide (all-defined-except loc make-loc)
|
(provide (all-defined-except loc make-loc)
|
||||||
(rename loc loc$)
|
(rename loc loc$)
|
||||||
(rename make-loc loc))
|
(rename make-loc loc))
|
||||||
|
|
||||||
; ;;;;; ; ;
|
; ;;;;; ; ;
|
||||||
; ; ; ; ;
|
; ; ; ; ;
|
||||||
; ; ; ;
|
; ; ; ;
|
||||||
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
|
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ;;;;
|
||||||
; ; ; ;; ; ; ; ; ; ; ;
|
; ; ; ;; ; ; ; ; ; ; ;
|
||||||
; ;;; ; ; ; ; ; ; ;
|
; ;;; ; ; ; ; ; ; ;
|
||||||
; ;;; ; ; ; ; ; ; ;
|
; ;;; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ;;;;
|
; ; ; ; ; ; ; ; ;;;;
|
||||||
; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ;; ; ; ; ; ;
|
; ; ; ; ; ; ;; ; ; ; ; ;
|
||||||
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
|
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;
|
||||||
|
|
||||||
(define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver
|
(define-struct trace-struct (evnt-rcvr thunk)) ; frp:event-receiver
|
||||||
|
|
||||||
(define-struct debug-client (modpath ; complete-path of the module
|
(define-struct debug-client (modpath ; complete-path of the module
|
||||||
tracepoints ; hash-table of traces
|
tracepoints ; hash-table of traces
|
||||||
line-col->pos ; memoized O(n) function to map line/col -> byte offset
|
line-col->pos ; memoized O(n) function to map line/col -> byte offset
|
||||||
process)) ; parent debug-process
|
process)) ; parent debug-process
|
||||||
|
|
||||||
(define-struct debug-process (custodian ; If you shutdown-all it will kill the debugger 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
|
run-semaphore ; When you post to this the debuggee will continue executing
|
||||||
running-e ; Is the program (supposed-to-be) currently running
|
running-e ; Is the program (supposed-to-be) currently running
|
||||||
run-manager ; saves behavior that actually pauses/resumes from GC
|
run-manager ; saves behavior that actually pauses/resumes from GC
|
||||||
pause-requested?
|
pause-requested?
|
||||||
resume-requested?
|
resume-requested?
|
||||||
|
|
||||||
exited? ; FrTime cell receives #t when the target exits
|
exited? ; FrTime cell receives #t when the target exits
|
||||||
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
|
exceptions ; (an event stream) Exceptions thrown during the evaluation of the target
|
||||||
main-client ; the main client module that will be run
|
main-client ; the main client module that will be run
|
||||||
clients ; list of all the clients attached to this process
|
clients ; list of all the clients attached to this process
|
||||||
|
|
||||||
where ; a behavior signaling each position where we pause
|
where ; a behavior signaling each position where we pause
|
||||||
marks)) ; while paused, the marks at the point of the pause (else false)
|
marks)) ; while paused, the marks at the point of the pause (else false)
|
||||||
|
|
||||||
(define-struct loc (modpath line col))
|
(define-struct loc (modpath line col))
|
||||||
|
|
||||||
;###########################################################################################################
|
;###########################################################################################################
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
; ;;;;; ; ; ;;;;; ;
|
; ;;;;; ; ; ;;;;; ;
|
||||||
; ; ; ; ; ;; ; ;
|
; ; ; ; ; ;; ; ;
|
||||||
; ; ; ; ; ;
|
; ; ; ; ; ;
|
||||||
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
|
; ; ;;;;;; ;;; ; ; ;;; ;;;;; ; ; ;;; ;;; ;;;; ;;;;; ;;;; ; ;;; ;;;;
|
||||||
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
|
; ; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ;
|
||||||
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
|
; ;;; ; ; ; ; ; ; ; ; ; ; ;;;;; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
|
; ; ; ; ; ; ; ; ; ; ;;;;;;; ; ; ; ; ; ; ;;;;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||||
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
|
; ; ; ; ; ; ;; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ;
|
||||||
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
|
; ;;;;; ;;;; ;;;; ; ;;; ;;; ;;;;; ; ;;;; ;;;; ; ;;; ;;;; ; ;;;;
|
||||||
|
|
||||||
(define (create-empty-debug-client)
|
(define (create-empty-debug-client)
|
||||||
(make-debug-client null ; modpath
|
(make-debug-client null ; modpath
|
||||||
(make-hash) ; tracepoints
|
(make-hash) ; tracepoints
|
||||||
null ; line-col->pos function
|
null ; line-col->pos function
|
||||||
null)) ; process
|
null)) ; process
|
||||||
|
|
||||||
;###########################################################################################################
|
;###########################################################################################################
|
||||||
)
|
)
|
||||||
|
|
@ -1,108 +1,108 @@
|
||||||
(module load-annotator mzscheme
|
(module load-annotator mzscheme
|
||||||
|
|
||||||
(require (lib "moddep.ss" "syntax")
|
(require (lib "moddep.ss" "syntax")
|
||||||
(lib "class.ss" "mzlib")
|
(lib "class.ss" "mzlib")
|
||||||
(lib "mred.ss" "mred"))
|
(lib "mred.ss" "mred"))
|
||||||
|
|
||||||
(provide eval/annotations
|
(provide eval/annotations
|
||||||
require/annotations
|
require/annotations
|
||||||
require/sandbox+annotations
|
require/sandbox+annotations
|
||||||
load-module/annotate)
|
load-module/annotate)
|
||||||
|
|
||||||
#|load-with-annotations :
|
#|load-with-annotations :
|
||||||
|
|
||||||
>initial-module : (union (listof symbol?) string?)
|
>initial-module : (union (listof symbol?) string?)
|
||||||
Takes in a require spec -- "../file.ss", (file "complete-path.ss"), (lib ...), etc
|
Takes in a require spec -- "../file.ss", (file "complete-path.ss"), (lib ...), etc
|
||||||
In other words -
|
In other words -
|
||||||
pass it a relative filename or a quoted lib to require
|
pass it a relative filename or a quoted lib to require
|
||||||
"mztake.ss" or '(lib "mztake.ss" "mztake")
|
"mztake.ss" or '(lib "mztake.ss" "mztake")
|
||||||
|
|
||||||
>annotate-module? : (string? symbol? . -> . boolean)
|
>annotate-module? : (string? symbol? . -> . boolean)
|
||||||
(filename module-name)
|
(filename module-name)
|
||||||
If true, loads source file and annotates.
|
If true, loads source file and annotates.
|
||||||
Else, tries to load compiled or source, no annotation.
|
Else, tries to load compiled or source, no annotation.
|
||||||
|
|
||||||
>annotator : (string? symbol? syntax? . -> . syntax?)
|
>annotator : (string? symbol? syntax? . -> . syntax?)
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator)
|
(define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator)
|
||||||
(parameterize ([current-custodian custodian]
|
(parameterize ([current-custodian custodian]
|
||||||
[current-namespace (make-namespace-with-mred)]
|
[current-namespace (make-namespace-with-mred)]
|
||||||
[error-display-handler err-display-handler])
|
[error-display-handler err-display-handler])
|
||||||
(require/annotations initial-module annotate-module? annotator)))
|
(require/annotations initial-module annotate-module? annotator)))
|
||||||
|
|
||||||
|
|
||||||
(define (require/annotations initial-module annotate-module? annotator)
|
(define (require/annotations initial-module annotate-module? annotator)
|
||||||
(eval/annotations #`(require #,initial-module) annotate-module? annotator))
|
(eval/annotations #`(require #,initial-module) annotate-module? annotator))
|
||||||
|
|
||||||
(define (eval/annotations stx annotate-module? annotator)
|
(define (eval/annotations stx annotate-module? annotator)
|
||||||
(parameterize
|
(parameterize
|
||||||
([current-load/use-compiled
|
([current-load/use-compiled
|
||||||
(let ([ocload/use-compiled (current-load/use-compiled)])
|
(let ([ocload/use-compiled (current-load/use-compiled)])
|
||||||
(lambda (fn m)
|
(lambda (fn m)
|
||||||
(cond [(annotate-module? fn m)
|
(cond [(annotate-module? fn m)
|
||||||
(load-module/annotate annotator fn m)]
|
(load-module/annotate annotator fn m)]
|
||||||
[else
|
[else
|
||||||
(ocload/use-compiled fn m)])))])
|
(ocload/use-compiled fn m)])))])
|
||||||
(eval-syntax (annotator stx))))
|
(eval-syntax (annotator stx))))
|
||||||
|
|
||||||
(define (load-module/annotate annotator fn m)
|
(define (load-module/annotate annotator fn m)
|
||||||
(let-values ([(base _ __) (split-path fn)]
|
(let-values ([(base _ __) (split-path fn)]
|
||||||
[(in-port src) (build-input-port fn)])
|
[(in-port src) (build-input-port fn)])
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(lambda () (void))
|
(lambda () (void))
|
||||||
|
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(parameterize ([read-accept-compiled #f]
|
(parameterize ([read-accept-compiled #f]
|
||||||
[current-load-relative-directory base])
|
[current-load-relative-directory base])
|
||||||
(unless m (raise 'module-name-not-passed-to-load-module/annotate))
|
(unless m (raise 'module-name-not-passed-to-load-module/annotate))
|
||||||
(with-module-reading-parameterization
|
(with-module-reading-parameterization
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let* ([first (expand (read-syntax src in-port))]
|
(let* ([first (expand (read-syntax src in-port))]
|
||||||
[module-ized-exp (annotator (check-module-form first m fn))]
|
[module-ized-exp (annotator (check-module-form first m fn))]
|
||||||
[second (read in-port)])
|
[second (read in-port)])
|
||||||
(unless (eof-object? second)
|
(unless (eof-object? second)
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
'load-module/annotate
|
'load-module/annotate
|
||||||
(format "expected only a `module' declaration for `~s', but found an extra expression" m)
|
(format "expected only a `module' declaration for `~s', but found an extra expression" m)
|
||||||
second))
|
second))
|
||||||
(eval module-ized-exp))))))
|
(eval module-ized-exp))))))
|
||||||
|
|
||||||
(lambda () (close-input-port in-port)))))
|
(lambda () (close-input-port in-port)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
; taken directly from mred.ss -- it's not exported...
|
; taken directly from mred.ss -- it's not exported...
|
||||||
(define (build-input-port filename)
|
(define (build-input-port filename)
|
||||||
(let ([p (open-input-file filename)])
|
(let ([p (open-input-file filename)])
|
||||||
(port-count-lines! p)
|
(port-count-lines! p)
|
||||||
(let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
|
(let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
|
||||||
(let ([t (make-object text%)])
|
(let ([t (make-object text%)])
|
||||||
(send t insert-file p 'standard)
|
(send t insert-file p 'standard)
|
||||||
(close-input-port p)
|
(close-input-port p)
|
||||||
(open-input-text-editor t))]
|
(open-input-text-editor t))]
|
||||||
[else p])])
|
[else p])])
|
||||||
(port-count-lines! p)
|
(port-count-lines! p)
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(when (with-handlers ([exn:fail? (lambda (x) #f)])
|
(when (with-handlers ([exn:fail? (lambda (x) #f)])
|
||||||
(regexp-match-peek "^#!" p))
|
(regexp-match-peek "^#!" p))
|
||||||
(let lloop ([prev #f])
|
(let lloop ([prev #f])
|
||||||
(let ([c (read-char-or-special p)])
|
(let ([c (read-char-or-special p)])
|
||||||
(if (or (eof-object? c)
|
(if (or (eof-object? c)
|
||||||
(eq? c #\return)
|
(eq? c #\return)
|
||||||
(eq? c #\newline))
|
(eq? c #\newline))
|
||||||
(when (eq? prev #\\)
|
(when (eq? prev #\\)
|
||||||
(loop))
|
(loop))
|
||||||
(lloop c))))))
|
(lloop c))))))
|
||||||
(values p filename))))
|
(values p filename))))
|
||||||
|
|
||||||
|
|
||||||
(define (test annotate-all?)
|
(define (test annotate-all?)
|
||||||
(require/annotations '(lib "mztake.ss" "mztake")
|
(require/annotations '(lib "mztake.ss" "mztake")
|
||||||
(lambda (fn m)
|
(lambda (fn m)
|
||||||
(printf "~a ~a~n" fn m)
|
(printf "~a ~a~n" fn m)
|
||||||
annotate-all?)
|
annotate-all?)
|
||||||
(lambda (fn m stx) stx)))
|
(lambda (fn m stx) stx)))
|
||||||
;(test #t) ; slow
|
;(test #t) ; slow
|
||||||
;(test #f) ; fast
|
;(test #f) ; fast
|
||||||
)
|
)
|
||||||
|
|
@ -1,292 +1,292 @@
|
||||||
(module more-useful-code mzscheme
|
(module more-useful-code mzscheme
|
||||||
(require (lib "list.ss")
|
(require (lib "list.ss")
|
||||||
(lib "pretty.ss")
|
(lib "pretty.ss")
|
||||||
(lib "etc.ss"))
|
(lib "etc.ss"))
|
||||||
|
|
||||||
(provide assert
|
(provide assert
|
||||||
cons-to-end
|
cons-to-end
|
||||||
assoc-get
|
assoc-get
|
||||||
debug
|
debug
|
||||||
make-to-string
|
make-to-string
|
||||||
make-debug
|
make-debug
|
||||||
to-string
|
to-string
|
||||||
member-eq?
|
member-eq?
|
||||||
string->char
|
string->char
|
||||||
last
|
last
|
||||||
member-str?
|
member-str?
|
||||||
quicksort-vector!
|
quicksort-vector!
|
||||||
struct->list/deep
|
struct->list/deep
|
||||||
make-for-each
|
make-for-each
|
||||||
begin0/rtn
|
begin0/rtn
|
||||||
with-handlers/finally
|
with-handlers/finally
|
||||||
pretty-print-syntax
|
pretty-print-syntax
|
||||||
with-semaphore
|
with-semaphore
|
||||||
|
|
||||||
make-hash
|
make-hash
|
||||||
hash?
|
hash?
|
||||||
hash-get
|
hash-get
|
||||||
hash-put!
|
hash-put!
|
||||||
hash-remove!
|
hash-remove!
|
||||||
hash-map
|
hash-map
|
||||||
hash-for-each
|
hash-for-each
|
||||||
hash-size/slow
|
hash-size/slow
|
||||||
hash-mem?
|
hash-mem?
|
||||||
hash-fold
|
hash-fold
|
||||||
hash-filter!
|
hash-filter!
|
||||||
hash-keys
|
hash-keys
|
||||||
hash-values
|
hash-values
|
||||||
hash-pairs
|
hash-pairs
|
||||||
hash-add-all!
|
hash-add-all!
|
||||||
hash-get-or-define!
|
hash-get-or-define!
|
||||||
|
|
||||||
(all-from (lib "list.ss"))
|
(all-from (lib "list.ss"))
|
||||||
(all-from (lib "etc.ss")))
|
(all-from (lib "etc.ss")))
|
||||||
|
|
||||||
(define-struct (exn:assert exn) ())
|
(define-struct (exn:assert exn) ())
|
||||||
|
|
||||||
(define-syntax (assert stx)
|
(define-syntax (assert stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(src-assert bool) #'(src-assert bool "")]
|
[(src-assert bool) #'(src-assert bool "")]
|
||||||
[(src-assert bool msg ...)
|
[(src-assert bool msg ...)
|
||||||
(with-syntax ([src-text (datum->syntax-object
|
(with-syntax ([src-text (datum->syntax-object
|
||||||
(syntax src-assert)
|
(syntax src-assert)
|
||||||
(format "~a:~a:~a: assertion failed: "
|
(format "~a:~a:~a: assertion failed: "
|
||||||
(syntax-source (syntax bool))
|
(syntax-source (syntax bool))
|
||||||
(syntax-line (syntax bool))
|
(syntax-line (syntax bool))
|
||||||
(syntax-column (syntax bool))))])
|
(syntax-column (syntax bool))))])
|
||||||
#'(unless bool
|
#'(unless bool
|
||||||
(raise (make-exn:assert (apply string-append
|
(raise (make-exn:assert (apply string-append
|
||||||
(cons src-text
|
(cons src-text
|
||||||
(map (lambda (item)
|
(map (lambda (item)
|
||||||
(string-append (to-string item) " "))
|
(string-append (to-string item) " "))
|
||||||
(list msg ...))))
|
(list msg ...))))
|
||||||
(current-continuation-marks)))))]))
|
(current-continuation-marks)))))]))
|
||||||
|
|
||||||
(define-syntax (begin0/rtn stx)
|
(define-syntax (begin0/rtn stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(begin0/rtn body bodies ...)
|
[(begin0/rtn body bodies ...)
|
||||||
(with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)])
|
(with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)])
|
||||||
(syntax (let ([rtn body]) bodies ... rtn)))]))
|
(syntax (let ([rtn body]) bodies ... rtn)))]))
|
||||||
|
|
||||||
(define-syntax with-handlers/finally
|
(define-syntax with-handlers/finally
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
[(_ (handler ...) body finally)
|
[(_ (handler ...) body finally)
|
||||||
(let ([finally-fn (lambda () finally)])
|
(let ([finally-fn (lambda () finally)])
|
||||||
(begin0
|
(begin0
|
||||||
(with-handlers
|
(with-handlers
|
||||||
(handler ...
|
(handler ...
|
||||||
[(lambda (exn) #t)
|
[(lambda (exn) #t)
|
||||||
(lambda (exn) (finally-fn) (raise exn))])
|
(lambda (exn) (finally-fn) (raise exn))])
|
||||||
body)
|
body)
|
||||||
(finally-fn)))]))
|
(finally-fn)))]))
|
||||||
|
|
||||||
(define (make-for-each . iterator-fns)
|
(define (make-for-each . iterator-fns)
|
||||||
(lambda (obj fn)
|
(lambda (obj fn)
|
||||||
(cond ((list? obj) (for-each fn obj))
|
(cond ((list? obj) (for-each fn obj))
|
||||||
((vector? obj) (let loop ((x 0))
|
((vector? obj) (let loop ((x 0))
|
||||||
(if (< x (vector-length obj))
|
(if (< x (vector-length obj))
|
||||||
(begin (fn (vector-ref obj x)) (loop (+ x 1))))))
|
(begin (fn (vector-ref obj x)) (loop (+ x 1))))))
|
||||||
((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key))))
|
((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key))))
|
||||||
(true (let loop ((cur iterator-fns))
|
(true (let loop ((cur iterator-fns))
|
||||||
(if (empty? cur)
|
(if (empty? cur)
|
||||||
(if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj)
|
(if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj)
|
||||||
(error "for-each: no iterator for value:" obj))
|
(error "for-each: no iterator for value:" obj))
|
||||||
(or ((first cur) obj fn)
|
(or ((first cur) obj fn)
|
||||||
(loop (rest cur)))))))))
|
(loop (rest cur)))))))))
|
||||||
|
|
||||||
|
|
||||||
(define (quicksort-vector! v less-than)
|
(define (quicksort-vector! v less-than)
|
||||||
(let ([count (vector-length v)])
|
(let ([count (vector-length v)])
|
||||||
(let loop ([min 0][max count])
|
(let loop ([min 0][max count])
|
||||||
(if (< min (sub1 max))
|
(if (< min (sub1 max))
|
||||||
(let ([pval (vector-ref v min)])
|
(let ([pval (vector-ref v min)])
|
||||||
(let pivot-loop ([pivot min]
|
(let pivot-loop ([pivot min]
|
||||||
[pos (add1 min)])
|
[pos (add1 min)])
|
||||||
(if (< pos max)
|
(if (< pos max)
|
||||||
(let ([cval (vector-ref v pos)])
|
(let ([cval (vector-ref v pos)])
|
||||||
(if (less-than cval pval)
|
(if (less-than cval pval)
|
||||||
(begin
|
(begin
|
||||||
(vector-set! v pos (vector-ref v pivot))
|
(vector-set! v pos (vector-ref v pivot))
|
||||||
(vector-set! v pivot cval)
|
(vector-set! v pivot cval)
|
||||||
(pivot-loop (add1 pivot) (add1 pos)))
|
(pivot-loop (add1 pivot) (add1 pos)))
|
||||||
(pivot-loop pivot (add1 pos))))
|
(pivot-loop pivot (add1 pos))))
|
||||||
(if (= min pivot)
|
(if (= min pivot)
|
||||||
(loop (add1 pivot) max)
|
(loop (add1 pivot) max)
|
||||||
(begin
|
(begin
|
||||||
(loop min pivot)
|
(loop min pivot)
|
||||||
(loop pivot max)))))))))
|
(loop pivot max)))))))))
|
||||||
v)
|
v)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define (member-str? s ls)
|
(define (member-str? s ls)
|
||||||
(cond
|
(cond
|
||||||
((empty? ls) false)
|
((empty? ls) false)
|
||||||
((string=? s (first ls)) true)
|
((string=? s (first ls)) true)
|
||||||
(else (member-str? s (rest ls)))))
|
(else (member-str? s (rest ls)))))
|
||||||
|
|
||||||
(define (last ls)
|
(define (last ls)
|
||||||
(cond
|
(cond
|
||||||
((empty? ls) (error "took a last but it was emptry"))
|
((empty? ls) (error "took a last but it was emptry"))
|
||||||
((empty? (rest ls)) (first ls))
|
((empty? (rest ls)) (first ls))
|
||||||
(else (last (rest ls)))))
|
(else (last (rest ls)))))
|
||||||
|
|
||||||
(define (string->char s)
|
(define (string->char s)
|
||||||
(first (string->list s)))
|
(first (string->list s)))
|
||||||
|
|
||||||
(define (member-eq? x ls)
|
(define (member-eq? x ls)
|
||||||
(not (empty? (filter (lambda (y) (eq? x y)) ls))))
|
(not (empty? (filter (lambda (y) (eq? x y)) ls))))
|
||||||
|
|
||||||
(define (to-string arg . extra-printers)
|
(define (to-string arg . extra-printers)
|
||||||
(let ([on-stack-ids (make-hash)]
|
(let ([on-stack-ids (make-hash)]
|
||||||
[used-ids (make-hash)]
|
[used-ids (make-hash)]
|
||||||
[free-id 0])
|
[free-id 0])
|
||||||
(let loop ((arg arg))
|
(let loop ((arg arg))
|
||||||
(if (hash-mem? on-stack-ids arg)
|
(if (hash-mem? on-stack-ids arg)
|
||||||
(begin
|
(begin
|
||||||
(hash-put! used-ids arg true)
|
(hash-put! used-ids arg true)
|
||||||
(format "#~a#" (hash-get on-stack-ids arg)))
|
(format "#~a#" (hash-get on-stack-ids arg)))
|
||||||
(let ([my-id free-id])
|
(let ([my-id free-id])
|
||||||
(hash-put! on-stack-ids arg my-id)
|
(hash-put! on-stack-ids arg my-id)
|
||||||
(set! free-id (add1 free-id))
|
(set! free-id (add1 free-id))
|
||||||
(let ([result
|
(let ([result
|
||||||
(or
|
(or
|
||||||
(let printer-loop ([printers extra-printers])
|
(let printer-loop ([printers extra-printers])
|
||||||
(if (empty? printers)
|
(if (empty? printers)
|
||||||
false
|
false
|
||||||
(or (if (procedure-arity-includes? (car printers) 2)
|
(or (if (procedure-arity-includes? (car printers) 2)
|
||||||
((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers))))
|
((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers))))
|
||||||
((car printers) arg))
|
((car printers) arg))
|
||||||
(printer-loop (cdr printers)))))
|
(printer-loop (cdr printers)))))
|
||||||
(cond
|
(cond
|
||||||
[(not arg) "#f"]
|
[(not arg) "#f"]
|
||||||
[(void? arg) "#<void>"]
|
[(void? arg) "#<void>"]
|
||||||
[(eq? arg #t) "#t"]
|
[(eq? arg #t) "#t"]
|
||||||
[(char? arg) (list->string (list arg))]
|
[(char? arg) (list->string (list arg))]
|
||||||
[(string? arg) (format "\"~a\"" arg)]
|
[(string? arg) (format "\"~a\"" arg)]
|
||||||
[(symbol? arg) (symbol->string arg)]
|
[(symbol? arg) (symbol->string arg)]
|
||||||
[(number? arg) (number->string arg)]
|
[(number? arg) (number->string arg)]
|
||||||
[(vector? arg) (string-append "#" (loop (vector->list arg)))]
|
[(vector? arg) (string-append "#" (loop (vector->list arg)))]
|
||||||
[(box? arg) (string-append "#&" (loop (unbox arg)))]
|
[(box? arg) (string-append "#&" (loop (unbox arg)))]
|
||||||
[(empty? arg) "empty"]
|
[(empty? arg) "empty"]
|
||||||
[(list? arg)
|
[(list? arg)
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
`("(" ,@(cons (loop (first arg))
|
`("(" ,@(cons (loop (first arg))
|
||||||
(map (lambda (item) (string-append " " (loop item))) (rest arg)))
|
(map (lambda (item) (string-append " " (loop item))) (rest arg)))
|
||||||
")"))]
|
")"))]
|
||||||
[(cons? arg) (format "(~a . ~a)"
|
[(cons? arg) (format "(~a . ~a)"
|
||||||
(loop (first arg))
|
(loop (first arg))
|
||||||
(loop (rest arg)))]
|
(loop (rest arg)))]
|
||||||
|
|
||||||
[(hash-table? arg)
|
[(hash-table? arg)
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
`("[hash:"
|
`("[hash:"
|
||||||
,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg))
|
,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg))
|
||||||
"]"))]
|
"]"))]
|
||||||
|
|
||||||
[(syntax? arg)
|
[(syntax? arg)
|
||||||
(format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))]
|
(format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))]
|
||||||
|
|
||||||
[(struct? arg)
|
[(struct? arg)
|
||||||
(let ([as-list (vector->list (struct->vector arg))])
|
(let ([as-list (vector->list (struct->vector arg))])
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
`("[" ,@(cons (loop (first as-list))
|
`("[" ,@(cons (loop (first as-list))
|
||||||
(map (lambda (item) (string-append " " (loop item)))
|
(map (lambda (item) (string-append " " (loop item)))
|
||||||
(rest as-list))) "]")))]
|
(rest as-list))) "]")))]
|
||||||
|
|
||||||
[else
|
[else
|
||||||
(format "~a" arg)]))])
|
(format "~a" arg)]))])
|
||||||
(hash-remove! on-stack-ids arg)
|
(hash-remove! on-stack-ids arg)
|
||||||
(if (hash-mem? used-ids arg)
|
(if (hash-mem? used-ids arg)
|
||||||
(format "#~a=~a" my-id result)
|
(format "#~a=~a" my-id result)
|
||||||
result)))))))
|
result)))))))
|
||||||
|
|
||||||
;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string]))))
|
;; 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
|
;; The printers have to take two arguments: the item to converts and the to-string function for subitems
|
||||||
(define (make-debug to-string-fn)
|
(define (make-debug to-string-fn)
|
||||||
(lambda args
|
(lambda args
|
||||||
(for-each (lambda (x)
|
(for-each (lambda (x)
|
||||||
(display (if (string? x) x (to-string-fn x)))
|
(display (if (string? x) x (to-string-fn x)))
|
||||||
(display " "))
|
(display " "))
|
||||||
args)
|
args)
|
||||||
(newline)))
|
(newline)))
|
||||||
|
|
||||||
(define debug (make-debug to-string))
|
(define debug (make-debug to-string))
|
||||||
|
|
||||||
(define (make-to-string predicate-printer-pairs)
|
(define (make-to-string predicate-printer-pairs)
|
||||||
(let ([printers (map (lambda (pair) (lambda (arg printer)
|
(let ([printers (map (lambda (pair) (lambda (arg printer)
|
||||||
(cond [(not ((first pair) arg)) false]
|
(cond [(not ((first pair) arg)) false]
|
||||||
[(procedure-arity-includes? (second pair) 2)
|
[(procedure-arity-includes? (second pair) 2)
|
||||||
((second pair) arg printer)]
|
((second pair) arg printer)]
|
||||||
[else ((second pair) arg)])))
|
[else ((second pair) arg)])))
|
||||||
predicate-printer-pairs)])
|
predicate-printer-pairs)])
|
||||||
(case-lambda
|
(case-lambda
|
||||||
[(arg) (apply to-string arg printers)]
|
[(arg) (apply to-string arg printers)]
|
||||||
[(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))])))
|
[(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))])))
|
||||||
|
|
||||||
(define (assoc-get label ls)
|
(define (assoc-get label ls)
|
||||||
(cond
|
(cond
|
||||||
((empty? ls) (error (string-append "failed to find " (to-string label))))
|
((empty? ls) (error (string-append "failed to find " (to-string label))))
|
||||||
((eq? label (first (first ls)))
|
((eq? label (first (first ls)))
|
||||||
(first ls))
|
(first ls))
|
||||||
(else (assoc-get label (rest ls)))))
|
(else (assoc-get label (rest ls)))))
|
||||||
|
|
||||||
(define (cons-to-end a ls)
|
(define (cons-to-end a ls)
|
||||||
(cond
|
(cond
|
||||||
((empty? ls) (cons a ls))
|
((empty? ls) (cons a ls))
|
||||||
(else (cons (first ls)
|
(else (cons (first ls)
|
||||||
(cons-to-end a (rest ls))))))
|
(cons-to-end a (rest ls))))))
|
||||||
|
|
||||||
(define (struct->list/deep item)
|
(define (struct->list/deep item)
|
||||||
(cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))]
|
(cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))]
|
||||||
[(list? item) (map struct->list/deep item)]
|
[(list? item) (map struct->list/deep item)]
|
||||||
[(vector? item) (list->vector (map struct->list/deep (vector->list item)))]
|
[(vector? item) (list->vector (map struct->list/deep (vector->list item)))]
|
||||||
[else item]))
|
[else item]))
|
||||||
|
|
||||||
(define (struct-name s) (vector-ref (struct->vector s) 0))
|
(define (struct-name s) (vector-ref (struct->vector s) 0))
|
||||||
|
|
||||||
(define (pretty-print-syntax width stx)
|
(define (pretty-print-syntax width stx)
|
||||||
(pretty-print-columns width)
|
(pretty-print-columns width)
|
||||||
(pretty-print (syntax-object->datum stx)))
|
(pretty-print (syntax-object->datum stx)))
|
||||||
|
|
||||||
(define (with-semaphore sem proc)
|
(define (with-semaphore sem proc)
|
||||||
(semaphore-wait sem)
|
(semaphore-wait sem)
|
||||||
(let ([result (proc)])
|
(let ([result (proc)])
|
||||||
(semaphore-post sem)
|
(semaphore-post sem)
|
||||||
result))
|
result))
|
||||||
|
|
||||||
(define make-hash make-hash-table)
|
(define make-hash make-hash-table)
|
||||||
(define hash? hash-table?)
|
(define hash? hash-table?)
|
||||||
(define hash-get hash-table-get)
|
(define hash-get hash-table-get)
|
||||||
(define hash-put! hash-table-put!)
|
(define hash-put! hash-table-put!)
|
||||||
(define hash-remove! hash-table-remove!)
|
(define hash-remove! hash-table-remove!)
|
||||||
(define hash-map hash-table-map)
|
(define hash-map hash-table-map)
|
||||||
(define hash-for-each hash-table-for-each)
|
(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-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-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-mem? hash item) (let/ec k (begin (hash-get hash item (lambda () (k false))) true)))
|
||||||
(define (hash-fold hash init fn)
|
(define (hash-fold hash init fn)
|
||||||
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
|
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
|
||||||
(define (hash-filter! hash predicate)
|
(define (hash-filter! hash predicate)
|
||||||
(hash-for-each
|
(hash-for-each
|
||||||
hash (lambda (key val) (if (not (predicate key val))
|
hash (lambda (key val) (if (not (predicate key val))
|
||||||
(hash-remove! hash key)))))
|
(hash-remove! hash key)))))
|
||||||
(define (hash-keys hash)
|
(define (hash-keys hash)
|
||||||
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
|
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
|
||||||
(define (hash-values hash)
|
(define (hash-values hash)
|
||||||
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
|
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
|
||||||
(define (hash-pairs hash)
|
(define (hash-pairs hash)
|
||||||
(hash-fold hash empty (lambda (key val acc) (cons (list key val) acc))))
|
(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
|
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
|
||||||
(hash-for-each from-hash
|
(hash-for-each from-hash
|
||||||
(lambda (key val) (hash-put! to-hash key val))))
|
(lambda (key val) (hash-put! to-hash key val))))
|
||||||
|
|
||||||
(define (hash-get-or-define! hash key val-fn)
|
(define (hash-get-or-define! hash key val-fn)
|
||||||
(if (not (hash-mem? hash key))
|
(if (not (hash-mem? hash key))
|
||||||
(begin (let ((v (val-fn)))
|
(begin (let ((v (val-fn)))
|
||||||
(hash-put! hash key v)
|
(hash-put! hash key v)
|
||||||
v))
|
v))
|
||||||
(hash-get hash key))))
|
(hash-get hash key))))
|
||||||
|
|
|
||||||
|
|
@ -1,66 +1,66 @@
|
||||||
(module useful-code (lib "frtime.ss" "frtime")
|
(module useful-code (lib "frtime.ss" "frtime")
|
||||||
|
|
||||||
(require (lib "string.ss")
|
(require (lib "string.ss")
|
||||||
(lib "contract.ss")
|
(lib "contract.ss")
|
||||||
(lib "list.ss"))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(provide (all-defined))
|
(provide (all-defined))
|
||||||
|
|
||||||
; Everything is contracted to 'any' for speed benefits, though there is already a big performance hit
|
; 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
|
; Keeps a list of the last n values of a behavior
|
||||||
(define/contract history-e (case-> (number? event? . -> . any)
|
(define/contract history-e (case-> (number? event? . -> . any)
|
||||||
(event? . -> . any))
|
(event? . -> . any))
|
||||||
(case-lambda [(stream)
|
(case-lambda [(stream)
|
||||||
(define ((add-to-complete-hist x) hist) (append hist (list x)))
|
(define ((add-to-complete-hist x) hist) (append hist (list x)))
|
||||||
(accum-e (stream . ==> . add-to-complete-hist) empty)]
|
(accum-e (stream . ==> . add-to-complete-hist) empty)]
|
||||||
|
|
||||||
[(n stream)
|
[(n stream)
|
||||||
(define ((add-to-short-hist x) hist) (append (if (< (length hist) n) hist (rest hist)) (list x)))
|
(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)]))
|
(accum-e (stream . ==> . add-to-short-hist) empty)]))
|
||||||
|
|
||||||
(define/contract history-b (case-> (number? event? . -> . any)
|
(define/contract history-b (case-> (number? event? . -> . any)
|
||||||
(event? . -> . any))
|
(event? . -> . any))
|
||||||
(case-lambda [(stream) (hold (history-e stream) empty)]
|
(case-lambda [(stream) (hold (history-e stream) empty)]
|
||||||
[(n stream) (hold (history-e n stream) empty)]))
|
[(n stream) (hold (history-e n stream) empty)]))
|
||||||
|
|
||||||
; Counts number of events on an event stream
|
; Counts number of events on an event stream
|
||||||
(define/contract count-b (event? . -> . any)
|
(define/contract count-b (event? . -> . any)
|
||||||
(lambda (stream)
|
(lambda (stream)
|
||||||
(hold (accum-e (stream . -=> . add1) 0) 0)))
|
(hold (accum-e (stream . -=> . add1) 0) 0)))
|
||||||
|
|
||||||
; Keeps track of the largest value seen on a stream
|
; Keeps track of the largest value seen on a stream
|
||||||
(define/contract largest-val-b (event? . -> . any)
|
(define/contract largest-val-b (event? . -> . any)
|
||||||
(lambda (stream)
|
(lambda (stream)
|
||||||
(hold (accum-e (stream
|
(hold (accum-e (stream
|
||||||
. ==> .
|
. ==> .
|
||||||
(lambda (last)
|
(lambda (last)
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(if (> x last) x last))))
|
(if (> x last) x last))))
|
||||||
-inf.0))))
|
-inf.0))))
|
||||||
|
|
||||||
; Keeps track of the smallest value seen on a stream
|
; Keeps track of the smallest value seen on a stream
|
||||||
(define/contract smallest-val-b (event? . -> . any)
|
(define/contract smallest-val-b (event? . -> . any)
|
||||||
(lambda (stream)
|
(lambda (stream)
|
||||||
(hold (accum-e (stream
|
(hold (accum-e (stream
|
||||||
. ==> .
|
. ==> .
|
||||||
(lambda (last)
|
(lambda (last)
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(if (< x last) x last))))
|
(if (< x last) x last))))
|
||||||
+inf.0))))
|
+inf.0))))
|
||||||
|
|
||||||
; Matches a sequence of items in a list to event pings
|
; Matches a sequence of items in a list to event pings
|
||||||
(define/contract sequence-match? ((listof any/c) . -> . any)
|
(define/contract sequence-match? ((listof any/c) . -> . any)
|
||||||
(lambda (seq evs)
|
(lambda (seq evs)
|
||||||
(equal? seq (history-b (length seq) evs))))
|
(equal? seq (history-b (length seq) evs))))
|
||||||
|
|
||||||
; Cheap printf for behaviors
|
; Cheap printf for behaviors
|
||||||
(define printf-b format)
|
(define printf-b format)
|
||||||
|
|
||||||
; Flattens a list
|
; Flattens a list
|
||||||
(define (flatten x)
|
(define (flatten x)
|
||||||
(cond ((empty? x) '())
|
(cond ((empty? x) '())
|
||||||
((and (list? x)
|
((and (list? x)
|
||||||
(list? (first x)))
|
(list? (first x)))
|
||||||
(append (flatten (car x)) (flatten (cdr x))))
|
(append (flatten (car x)) (flatten (cdr x))))
|
||||||
(else (list x)))))
|
(else (list x)))))
|
||||||
Loading…
Reference in New Issue
Block a user