[plt-scheme] Graphs
oh, yes, base-gm.ss is my catch-all file. It contains, among other
things, my ASSERT macro.
I always wondered why plt-scheme doesn't come with a standard assert
macro.
(define-syntax (assert stx)
(syntax-case stx ()
[(src-assert bool) (syntax (src-assert bool ""))]
[(src-assert bool msg ...)
(syntax-case (datum->syntax-object (syntax src-assert)
(format "~a:~a:~a: assertion failed"
(syntax-source (syntax bool))
(syntax-line (syntax bool))
(syntax-column (syntax bool)))) ()
[src (syntax (if (not bool)
(error (string-append src (format " ~a" msg) ...))))])]))
Due to popular demand, I will package my graph.ss a little bit more
neatly, and post it on planet. You can use the attached base-gm.ss to
start working now. The interface of graph.ss will not change in the
clean up.
On Tue, 2005-02-08 at 19:29 +0000, Paulo Jorge de Oliveira Cantante de
Matos wrote:
> For list-related administrative tasks:
> http://list.cs.brown.edu/mailman/listinfo/plt-scheme
>
> (require "base-gm.ss")
>
> You have only this require. Which file is this?
>
> Cheers,
>
> Paulo Matos
>
> Guillaume Marceau said:
> > On Tue, 2005-02-08 at 16:26 +0000, Paulo Jorge de Oliveira
> > Cantante de
> > Matos wrote:
> >> For list-related administrative tasks:
> >> http://list.cs.brown.edu/mailman/listinfo/plt-scheme
> >>
> >> Hi all,
> >>
> >> Is there any implementation of graphs structures and
> >> algorithms
> >> that work under MzScheme?
> >>
> >> Cheers,
> >
> > I attached my implementation of a graph data structure.
> >
> > It implements imperative graphs, backed with hash tables. Nodes
> > are
> > arbitrary objects, and they are compared using either EQ? or
> > EQUAL?
> >
> > Graphs can be directed or undirected. The graphs can throw an
> > exception
> > for nodes added multiple times, edge added multiple times, and
> > edges
> > added between objects that are not in the graph. You can enable
> > the
> > checks by passing the flag 'SAFE to the constructor.
> >
> > Both nodes and edges can have arbitrary labels.
> >
> > There are only three algorithms coded so far: dfs, topological
> > sort, and
> > strongly connected components.
> >
> >
> > --
> > "The thing I remember most about America is that it's silly.
> > That can be quite a relief at times." -- Thom Yorke,
> > Radiohead
> >
> > - Guillaume
> >
>
>
--
"The thing I remember most about America is that it's silly.
That can be quite a relief at times." -- Thom Yorke, Radiohead
- Guillaume
-------------- next part --------------
(module base-gm mzscheme
(require (lib "list.ss")
(lib "etc.ss"))
(provide assert
cons-to-end
assoc-get
debug
make-to-string
make-debug
to-string
member-eq?
string->char
last
member-str?
quicksort-vector!
struct->list
make-for-each
begin0/rtn
make-hash
hash?
hash-get
hash-put!
hash-remove!
hash-map
hash-for-each
hash-size/slow
hash-mem?
hash-fold
hash-filter!
hash-keys
hash-values
hash-pairs
hash-add-all!
hash-gad!
(all-from (lib "list.ss"))
(all-from (lib "etc.ss")))
(define-syntax (assert stx)
(syntax-case stx ()
[(src-assert bool) (syntax (src-assert bool ""))]
[(src-assert bool msg ...)
(syntax-case (datum->syntax-object (syntax src-assert)
(format "~a:~a:~a: assertion failed"
(syntax-source (syntax bool))
(syntax-line (syntax bool))
(syntax-column (syntax bool)))) ()
[src (syntax (if (not bool)
(error (string-append src (format " ~a" msg) ...))))])]))
(define-syntax (begin0/rtn stx)
(syntax-case stx ()
[(begin0/rtn body bodies ...)
(with-syntax ([rtn (datum->syntax-object (syntax begin0/rtn) 'rtn)])
(syntax (let ([rtn body]) bodies ... rtn)))]))
(define-syntax with-handlers/finally
(syntax-rules ()
[(_ (handler ...) body finally)
(let ([finally-fn (lambda () finally)])
(begin0
(with-handlers
(handler ...
[(lambda (exn) #t)
(lambda (exn) (finally-fn) (raise exn))])
body)
(finally-fn)))]))
(define (make-for-each . iterator-fns)
(lambda (obj fn)
(cond ((list? obj) (for-each fn obj))
((vector? obj) (let loop ((x 0))
(if (< x (vector-length obj))
(begin (fn (vector-ref obj x)) (loop (+ x 1))))))
((hash-table? obj) (hash-for-each obj (lambda (key val) (fn key))))
(true (let loop ((cur iterator-fns))
(if (empty? cur)
(if (struct? obj) (error "for-each: no iterator for struct `" (struct-name obj) "' value:" obj)
(error "for-each: no iterator for value:" obj))
(or ((first cur) obj fn)
(loop (rest cur)))))))))
(define (quicksort-vector! v less-than)
(let ([count (vector-length v)])
(let loop ([min 0][max count])
(if (< min (sub1 max))
(let ([pval (vector-ref v min)])
(let pivot-loop ([pivot min]
[pos (add1 min)])
(if (< pos max)
(let ([cval (vector-ref v pos)])
(if (less-than cval pval)
(begin
(vector-set! v pos (vector-ref v pivot))
(vector-set! v pivot cval)
(pivot-loop (add1 pivot) (add1 pos)))
(pivot-loop pivot (add1 pos))))
(if (= min pivot)
(loop (add1 pivot) max)
(begin
(loop min pivot)
(loop pivot max)))))))))
v)
(define (member-str? s ls)
(cond
((empty? ls) false)
((string=? s (first ls)) true)
(else (member-str? s (rest ls)))))
(define (last ls)
(cond
((empty? ls) (error "took a last but it was emptry"))
((empty? (rest ls)) (first ls))
(else (last (rest ls)))))
(define (string->char s)
(first (string->list s)))
(define (member-eq? x ls)
(not (empty? (filter (lambda (y) (eq? x y)) ls))))
(define (to-string arg . extra-printers)
(let ([on-stack-ids (make-hash)]
[used-ids (make-hash)]
[free-id 0])
(let loop ((arg arg))
(if (hash-mem? on-stack-ids arg)
(begin
(hash-put! used-ids arg true)
(format "#~a#" (hash-get on-stack-ids arg)))
(let ([my-id free-id])
(hash-put! on-stack-ids arg my-id)
(set! free-id (add1 free-id))
(let ([result
(or
(let printer-loop ([printers extra-printers])
(if (empty? printers)
false
(or (if (procedure-arity-includes? (car printers) 2)
((car printers) arg (lambda (arg) (apply to-string (cons arg extra-printers))))
((car printers) arg))
(printer-loop (cdr printers)))))
(cond
((not arg) "#f")
((void? arg) "#<void>")
((eq? arg #t) "#t")
((char? arg) (list->string (list arg)))
((string? arg) 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) (string-append
"("
(loop (first arg))
(foldr string-append ""
(map (lambda (x)
(string-append " "
(loop x))) (rest arg)))
")"))
((cons? arg) (string-append
"("
(loop (first arg))
" . "
(loop (rest arg))
")"))
((hash-table? arg)
(apply
string-append
`("[hash:"
,@(map (lambda (p) (string-append " " (loop p))) (hash-pairs arg))
"]")))
((syntax? arg)
(format "[syntax: ~a:~a]" (syntax-line arg) (syntax-column arg)))
(true
(format "~a" arg))))])
(hash-remove! on-stack-ids arg)
(if (hash-mem? used-ids arg)
(format "#~a=~a" my-id result)
result)))))))
;; make-debug: usage example: (define debug-f (make-debug (make-to-string `([,is-type? ,type-to-string]))))
;; The printers have to take two arguments: the item to converts and the to-string function for subitems
(define (make-debug to-string-fn)
(lambda args
(for-each (lambda (x)
(display (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 itm)
(cond [(struct? itm) (map struct->list (vector->list (struct->vector itm)))]
[(list? itm) (map struct->list itm)]
[else itm]))
(define (struct-name s) (vector-ref (struct->vector s) 0))
(define make-hash make-hash-table)
(define hash? hash-table?)
(define hash-get hash-table-get)
(define hash-remove! hash-table-remove!)
(define hash-map hash-table-map)
(define hash-for-each hash-table-for-each)
(define (hash-size/slow hash) (hash-fold hash 0 (lambda (key val acc) (+ acc 1))))
(define (hash-mem? hash item) (let/ec k (begin (hash-get hash item (lambda () (k false))) true)))
(define (hash-fold hash init fn)
(hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
(define (hash-filter! hash predicate)
(hash-for-each
hash (lambda (key val) (if (not (predicate key val))
(hash-remove! hash key)))))
(define (hash-keys hash)
(hash-fold hash empty (lambda (key val acc) (cons key acc))))
(define (hash-values hash)
(hash-fold hash empty (lambda (key val acc) (cons val acc))))
(define (hash-pairs hash)
(hash-fold hash empty (lambda (key val acc) (cons (cons key val) acc))))
(define (hash-add-all! to-hash from-hash) ;; // memcpy-style argument order
(hash-for-each from-hash
(lambda (key val) (hash-put! to-hash key val))))
(define (hash-gad! hash key val-fn)
(if (not (hash-mem? hash key))
(begin (let ((v (val-fn)))
(hash-put! hash key v)
v))
(hash-get hash key))))
![[logo]](/logo.png){kind=logo}