trimmed base.ss
svn: r2578
This commit is contained in:
Guillaume Marceau
parent
7f6a5b3c12
commit
65f188723a
9
collects/mztake/demos/dijkstra/heap-speed-mztake.ss
Normal file
9
collects/mztake/demos/dijkstra/heap-speed-mztake.ss
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
(require (lib "mztake.ss" "mztake"))
|
||||
(set-main! "heap.ss")
|
||||
|
||||
(define start (current-milliseconds))
|
||||
(set-running! #t)
|
||||
(exited?)
|
||||
(- (hold (map-e (lambda (e) (current-milliseconds))
|
||||
(changes (exited?)))) start)
|
||||
|
||||
|
|
@ -1,13 +1,12 @@
|
|||
(module heap mzscheme
|
||||
|
||||
(require (lib "etc.ss")
|
||||
"base-gm.ss"
|
||||
"dv.ss")
|
||||
"dv.ss")
|
||||
|
||||
|
||||
(provide make-heap heap-empty? heap-size heap-insert heap-pop
|
||||
heap-peak heap-remove heap-find
|
||||
heap-contains heap-resort heap-tostring)
|
||||
heap-contains heap-resort)
|
||||
|
||||
|
||||
|
||||
|
|
@ -121,14 +120,7 @@
|
|||
(heap-remove heap item)
|
||||
(heap-insert heap item))
|
||||
|
||||
(define (heap-tostring heap . fns)
|
||||
(let* ((data (t-data heap))
|
||||
(data-list (let loop ((i 1))
|
||||
(if (> i (heap-last heap)) empty
|
||||
(cons (dv:ref data i) (loop (+ i 1)))))))
|
||||
|
||||
(string-append "heap: sz " (number->string (heap-size heap)) ", "
|
||||
(apply to-string (cons data-list fns)))))
|
||||
|
||||
|
||||
(define (test)
|
||||
(define f (make-heap > eq?))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,7 @@
|
|||
(module engine mzscheme
|
||||
(require "marks.ss"
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(prefix frp: (lib "lang-ext.ss" "frtime"))
|
||||
(rename (lib "frp-core.ss" "frtime")
|
||||
frp:signal-thunk signal-thunk)
|
||||
|
|
@ -162,6 +164,7 @@
|
|||
(let* ([t (first traces)]
|
||||
[e (apply (trace-struct-thunk t) vals)])
|
||||
(frp:send-synchronous-event (trace-struct-evnt-rcvr t) e))]
|
||||
[no-traces? (void)]
|
||||
[else (frp:send-synchronous-events (traces->events traces vals))])
|
||||
|
||||
;; With a where event to generate
|
||||
|
|
@ -211,8 +214,10 @@
|
|||
(cons (first lst) (head (rest lst) (sub1 n)))))
|
||||
|
||||
(define (dir-contains? dir filename)
|
||||
(let ([dir-lst (unbuild-path dir)])
|
||||
(equal? dir-lst (head (unbuild-path filename) (length dir-lst)))))
|
||||
(let ([dir-lst (unbuild-path dir)]
|
||||
[file-lst (unbuild-path filename)])
|
||||
(and (< (length dir-lst) (length file-lst))
|
||||
(equal? dir-lst (head file-lst (length dir-lst))))))
|
||||
|
||||
(define (map-policy-tag tag)
|
||||
(cond [(eq? tag 'fast) false]
|
||||
|
|
|
|||
|
|
@ -1,31 +1,8 @@
|
|||
(module more-useful-code mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(require-for-syntax (lib "list.ss"))
|
||||
|
||||
(provide assert
|
||||
cons-to-end
|
||||
assoc-get
|
||||
debug
|
||||
debug-x
|
||||
make-to-string
|
||||
make-debug
|
||||
to-string
|
||||
member-eq?
|
||||
string->char
|
||||
last
|
||||
member-str?
|
||||
quicksort-vector!
|
||||
struct->list/deep
|
||||
make-for-each
|
||||
begin0/rtn
|
||||
with-handlers/finally
|
||||
pretty-print-syntax
|
||||
with-semaphore
|
||||
|
||||
make-hash
|
||||
(provide make-hash
|
||||
hash?
|
||||
hash-get
|
||||
hash-put!
|
||||
|
|
@ -40,241 +17,9 @@
|
|||
hash-values
|
||||
hash-pairs
|
||||
hash-add-all!
|
||||
hash-get-or-define!
|
||||
|
||||
(all-from (lib "list.ss"))
|
||||
(all-from (lib "etc.ss")))
|
||||
|
||||
(define-struct (exn:assert exn) ())
|
||||
|
||||
(define-syntax (assert stx)
|
||||
(syntax-case stx ()
|
||||
[(src-assert bool) #'(src-assert bool "")]
|
||||
[(src-assert bool msg ...)
|
||||
(with-syntax ([src-text (datum->syntax-object
|
||||
(syntax src-assert)
|
||||
(format "~a:~a:~a: assertion failed: "
|
||||
(syntax-source (syntax bool))
|
||||
(syntax-line (syntax bool))
|
||||
(syntax-column (syntax bool))))])
|
||||
#'(unless bool
|
||||
(raise (make-exn:assert (apply string-append
|
||||
(cons src-text
|
||||
(map (lambda (item)
|
||||
(string-append (to-string item) " "))
|
||||
(list msg ...))))
|
||||
(current-continuation-marks)))))]))
|
||||
|
||||
(define-syntax (begin0/rtn stx)
|
||||
(syntax-case stx ()
|
||||
[(begin0/rtn body bodies ...)
|
||||
(with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)])
|
||||
(syntax (let ([rtn body]) bodies ... rtn)))]))
|
||||
|
||||
(define-syntax with-handlers/finally
|
||||
(syntax-rules ()
|
||||
[(_ (handler ...) body finally)
|
||||
(let ([finally-fn (lambda () finally)])
|
||||
(begin0
|
||||
(with-handlers
|
||||
(handler ...
|
||||
[(lambda (exn) #t)
|
||||
(lambda (exn) (finally-fn) (raise exn))])
|
||||
body)
|
||||
(finally-fn)))]))
|
||||
|
||||
(define (make-for-each . iterator-fns)
|
||||
(lambda (obj fn)
|
||||
(cond ((list? obj) (for-each fn obj))
|
||||
((vector? obj) (let loop ((x 0))
|
||||
(if (< x (vector-length obj))
|
||||
(begin (fn (vector-ref obj x)) (loop (+ x 1))))))
|
||||
((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key))))
|
||||
(true (let loop ((cur iterator-fns))
|
||||
(if (empty? cur)
|
||||
(if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj)
|
||||
(error "for-each: no iterator for value:" obj))
|
||||
(or ((first cur) obj fn)
|
||||
(loop (rest cur)))))))))
|
||||
|
||||
|
||||
(define (quicksort-vector! v less-than)
|
||||
(let ([count (vector-length v)])
|
||||
(let loop ([min 0][max count])
|
||||
(if (< min (sub1 max))
|
||||
(let ([pval (vector-ref v min)])
|
||||
(let pivot-loop ([pivot min]
|
||||
[pos (add1 min)])
|
||||
(if (< pos max)
|
||||
(let ([cval (vector-ref v pos)])
|
||||
(if (less-than cval pval)
|
||||
(begin
|
||||
(vector-set! v pos (vector-ref v pivot))
|
||||
(vector-set! v pivot cval)
|
||||
(pivot-loop (add1 pivot) (add1 pos)))
|
||||
(pivot-loop pivot (add1 pos))))
|
||||
(if (= min pivot)
|
||||
(loop (add1 pivot) max)
|
||||
(begin
|
||||
(loop min pivot)
|
||||
(loop pivot max)))))))))
|
||||
v)
|
||||
hash-get-or-define!)
|
||||
|
||||
|
||||
|
||||
(define (member-str? s ls)
|
||||
(cond
|
||||
((empty? ls) false)
|
||||
((string=? s (first ls)) true)
|
||||
(else (member-str? s (rest ls)))))
|
||||
|
||||
(define (last ls)
|
||||
(cond
|
||||
((empty? ls) (error "took a last but it was emptry"))
|
||||
((empty? (rest ls)) (first ls))
|
||||
(else (last (rest ls)))))
|
||||
|
||||
(define (string->char s)
|
||||
(first (string->list s)))
|
||||
|
||||
(define (member-eq? x ls)
|
||||
(not (empty? (filter (lambda (y) (eq? x y)) ls))))
|
||||
|
||||
(define (to-string arg . extra-printers)
|
||||
(let ([on-stack-ids (make-hash)]
|
||||
[used-ids (make-hash)]
|
||||
[free-id 0])
|
||||
(let loop ((arg arg))
|
||||
(if (hash-mem? on-stack-ids arg)
|
||||
(begin
|
||||
(hash-put! used-ids arg true)
|
||||
(format "#~a#" (hash-get on-stack-ids arg)))
|
||||
(let ([my-id free-id])
|
||||
(hash-put! on-stack-ids arg my-id)
|
||||
(set! free-id (add1 free-id))
|
||||
(let ([result
|
||||
(or
|
||||
(let printer-loop ([printers extra-printers])
|
||||
(if (empty? printers)
|
||||
false
|
||||
(or (if (procedure-arity-includes? (car printers) 2)
|
||||
((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers))))
|
||||
((car printers) arg))
|
||||
(printer-loop (cdr printers)))))
|
||||
(cond
|
||||
[(not arg) "#f"]
|
||||
[(void? arg) "#<void>"]
|
||||
[(eq? arg #t) "#t"]
|
||||
[(char? arg) (list->string (list arg))]
|
||||
[(string? arg) (format "\"~a\"" arg)]
|
||||
[(symbol? arg) (symbol->string arg)]
|
||||
[(number? arg) (number->string arg)]
|
||||
[(vector? arg) (string-append "#" (loop (vector->list arg)))]
|
||||
[(box? arg) (string-append "#&" (loop (unbox arg)))]
|
||||
[(empty? arg) "empty"]
|
||||
[(list? arg)
|
||||
(apply
|
||||
string-append
|
||||
`("(" ,@(cons (loop (first arg))
|
||||
(map (lambda (item) (string-append " " (loop item))) (rest arg)))
|
||||
")"))]
|
||||
[(cons? arg) (format "(~a . ~a)"
|
||||
(loop (first arg))
|
||||
(loop (rest arg)))]
|
||||
|
||||
[(hash-table? arg)
|
||||
(apply
|
||||
string-append
|
||||
`("[hash:"
|
||||
,@(map (lambda (item) (string-append " " (loop item))) (hash-pairs arg))
|
||||
"]"))]
|
||||
|
||||
[(syntax? arg)
|
||||
(format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg))]
|
||||
|
||||
[(struct? arg)
|
||||
(let ([as-list (vector->list (struct->vector arg))])
|
||||
(apply
|
||||
string-append
|
||||
`("[" ,@(cons (loop (first as-list))
|
||||
(map (lambda (item) (string-append " " (loop item)))
|
||||
(rest as-list))) "]")))]
|
||||
|
||||
[else
|
||||
(format "~a" arg)]))])
|
||||
(hash-remove! on-stack-ids arg)
|
||||
(if (hash-mem? used-ids arg)
|
||||
(format "#~a=~a" my-id result)
|
||||
result)))))))
|
||||
|
||||
(define-syntax (debug-x stx)
|
||||
(syntax-case stx ()
|
||||
[(_ rest ... expr)
|
||||
#`(let ([result expr])
|
||||
(printf "~a:~a ~a: ~a ~a~n"
|
||||
#,(syntax-line stx)
|
||||
#,(syntax-column stx)
|
||||
'#,(if (syntax->list #'expr)
|
||||
(syntax-e (first (syntax->list #'expr)))
|
||||
(syntax-e #'expr))
|
||||
result
|
||||
(list rest ...))
|
||||
result)]))
|
||||
|
||||
;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string]))))
|
||||
;; The printers have to take two arguments: the item to converts and the to-string function for subitems
|
||||
(define (make-debug to-string-fn)
|
||||
(lambda args
|
||||
(for-each (lambda (x)
|
||||
(display (if (string? x) x (to-string-fn x)))
|
||||
(display " "))
|
||||
args)
|
||||
(newline)))
|
||||
|
||||
(define debug (make-debug to-string))
|
||||
|
||||
(define (make-to-string predicate-printer-pairs)
|
||||
(let ([printers (map (lambda (pair) (lambda (arg printer)
|
||||
(cond [(not ((first pair) arg)) false]
|
||||
[(procedure-arity-includes? (second pair) 2)
|
||||
((second pair) arg printer)]
|
||||
[else ((second pair) arg)])))
|
||||
predicate-printer-pairs)])
|
||||
(case-lambda
|
||||
[(arg) (apply to-string arg printers)]
|
||||
[(arg extra-printers) (apply to-string (append (list arg) printers extra-printers))])))
|
||||
|
||||
(define (assoc-get label ls)
|
||||
(cond
|
||||
((empty? ls) (error (string-append "failed to find " (to-string label))))
|
||||
((eq? label (first (first ls)))
|
||||
(first ls))
|
||||
(else (assoc-get label (rest ls)))))
|
||||
|
||||
(define (cons-to-end a ls)
|
||||
(cond
|
||||
((empty? ls) (cons a ls))
|
||||
(else (cons (first ls)
|
||||
(cons-to-end a (rest ls))))))
|
||||
|
||||
(define (struct->list/deep item)
|
||||
(cond [(struct? item) (map struct->list/deep (vector->list (struct->vector item)))]
|
||||
[(list? item) (map struct->list/deep item)]
|
||||
[(vector? item) (list->vector (map struct->list/deep (vector->list item)))]
|
||||
[else item]))
|
||||
|
||||
(define (struct-name s) (vector-ref (struct->vector s) 0))
|
||||
|
||||
(define (pretty-print-syntax width stx)
|
||||
(pretty-print-columns width)
|
||||
(pretty-print (syntax-object->datum stx)))
|
||||
|
||||
(define (with-semaphore sem proc)
|
||||
(semaphore-wait sem)
|
||||
(let ([result (proc)])
|
||||
(semaphore-post sem)
|
||||
result))
|
||||
|
||||
(define make-hash make-hash-table)
|
||||
(define hash? hash-table?)
|
||||
(define hash-get hash-table-get)
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(module mztake-structs mzscheme
|
||||
(require (lib "match.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "more-useful-code.ss" "mztake"))
|
||||
|
||||
(provide (all-defined))
|
||||
|
|
|
|||
|
|
@ -111,14 +111,16 @@
|
|||
[(_ loc body ...)
|
||||
(trace* (current-process) loc (lambda () body ...))]))
|
||||
|
||||
(define (mztake-top* name thunk )
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(with-handlers
|
||||
([exn:fail? (lambda (exn2) (raise exn))])
|
||||
(bind* (current-process) name)))])
|
||||
(thunk)))
|
||||
(define (mztake-top* name thunk)
|
||||
(if (debug-process-marks (current-process))
|
||||
(with-handlers
|
||||
([exn:fail?
|
||||
(lambda (exn)
|
||||
(with-handlers
|
||||
([exn:fail? (lambda (exn2) (raise exn2))])
|
||||
(bind* (current-process) name)))])
|
||||
(thunk))
|
||||
(thunk)))
|
||||
|
||||
(define-syntax (mztake-top stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -127,12 +129,12 @@
|
|||
|
||||
(define (lookup-in-top-level p name)
|
||||
(let/ec success
|
||||
(for-each
|
||||
(lambda (m)
|
||||
(let/ec fail
|
||||
(let ([fail* (lambda () (fail false))])
|
||||
(success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*)))))
|
||||
(map mark-module-name (debug-process-marks p)))
|
||||
(define (try m)
|
||||
(let/ec fail
|
||||
(define (fail*) (fail false))
|
||||
(success (hash-get (hash-get (debug-process-top-level p) m fail*) name fail*))))
|
||||
(for-each try (map mark-module-name (debug-process-marks p)))
|
||||
(hash-for-each (debug-process-top-level p) (lambda (m ns) (try m)))
|
||||
(error 'bind "variable `~a' not found in target at the current location" name)))
|
||||
|
||||
(define (bind* p name)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user