[plt-scheme] Graphs

From: Guillaume Marceau (gmarceau at cs.brown.edu)
Date: Tue Feb 8 15:19:32 EST 2005

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))))

Posted on the users mailing list.