svn: r147

collects/mztake/demos/dijkstra/base-gm.ss

@@ -0,0 +1,213 @@
+(module base-gm mzscheme
+  (require (lib "list.ss")
+	   (lib  "etc.ss"))
+  
+  (provide cons-to-end
+	   assoc-get
+	   debug
+	   make-debug
+	   to-string
+	   member-eq?	   
+	   string->char
+	   last
+	   member-str?
+	   quicksort-vector!
+	   for
+	   for-vector
+	   but-last
+	   halt
+	   prog1
+	   struct->list
+           for-list
+
+	   make-hash
+	   hash-get
+	   hash-put!
+	   hash-remove!
+	   hash-map
+	   hash-for-each
+	   hash-mem?
+
+	   (all-from (lib "list.ss"))
+	   (all-from (lib "etc.ss")))
+  
+  (define-syntax prog1
+    (syntax-rules
+	() 
+      {(prog1 arg1 args ...)
+       (let ((v arg1))
+	 args ...
+	 v)}))
+  
+  (define-syntax halt
+    (syntax-rules
+	()
+      [(halt arg ...)
+       (begin
+	 (debug "There was a problem with " arg ...)
+	 (error "Error."))]))  
+  
+;;;(define (halt . args)
+;;;  (apply error
+;;;	 (list (string-append
+;;;		"Error: "
+;;;		(foldl string-append "" (reverse (map to-string args)))))))
+  
+  (define (but-last ls)
+    (cond
+     ((empty? ls) (error "incorrect list to butlast"))
+     ((empty? (rest ls)) empty)
+     (else (cons (first ls) (but-last (rest ls))))))
+  
+  (define-syntax for
+    (syntax-rules
+	()
+      [(for x start stop body ...)
+       (let ((x start))
+	 (letrec ((loop
+		   (lambda ()
+		     (if (> x stop)
+			 'done
+			 (begin
+			   body ...
+			   (set! x (+ x 1))
+			   (loop))))))
+	   (loop)))]))
+  
+  (define-syntax for-vector
+    (syntax-rules
+	(with)
+      [(for-vector v with x body ...)
+       (for x 0 (- (vector-length v) 1)
+	    body ...)]))
+
+  (define-syntax for-list
+    (syntax-rules
+     (with)
+     [(for-list ls with x body ...)
+      (let ((x 'dummy))
+        (letrec ((loop
+                  (lambda (param)
+                    (if (empty? param)
+                        'done
+                        (begin
+                          (set! x (car param))
+                          body ...
+                          (loop (rest param)))))))
+          (loop ls)))]))
+
+  (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 . fns)
+    (let loop ((arg arg))
+      (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) (loop (vector->list 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))
+		     ")"))
+       
+       (true (let loop ((cur fns))
+	       (if (empty? cur) (halt "to-string: " arg)
+		   (or ((first cur) arg) 
+		       (loop (rest cur)))))))))
+    
+
+  (define (debug . args)
+    (for-each display args)
+    (newline))
+
+  (define (make-debug . fns)
+    (lambda args (for-each (lambda (x) (display (apply to-string (cons x fns)))
+				   (display " ")) args)
+	    (newline)))
+
+  (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-get hash-table-get)
+  (define hash-put! hash-table-put!)
+  (define hash-remove! hash-table-remove!)
+  (define hash-map hash-table-map)
+  (define hash-for-each hash-table-for-each)
+  (define (hash-mem? hash item) (hash-get hash item (lambda () false)))
+)

collects/mztake/demos/dijkstra/dijkstra-solver.ss

@@ -1,5 +1,5 @@
 (module dijkstra-solver mzscheme
-  (require (lib "heap.ss" "frtime")
+  (require "heap.ss"
            (lib "list.ss")
            "graph.ss")
 

collects/mztake/demos/dijkstra/dijkstra-test.ss

@@ -4,7 +4,7 @@
 
 (mztake-process p 
                 ("dijkstra.ss")
-                ((lib "heap.ss" "frtime")
+                ("heap.ss"
                    [inserts 49 6 bind 'item]
                    [removes 67 10 bind 'result]))
 

collects/mztake/demos/dijkstra/dv.ss

@@ -0,0 +1,100 @@
+; -*- Scheme -*-
+
+; Shriram Krishnamurthi (shriram@cs.rice.edu)
+; Tue Jul 25 23:20:45 EDT 1995
+
+; (define-structure (dv:vector length size contents))
+
+(module dv mzscheme 
+
+  (provide dv:make dv:make-w/-init dv:length dv:contents dv:append
+           dv:remove-last dv:legitimate-index dv:ref dv:set!)
+  
+  (define dv:vector?
+    (lambda (obj)
+      (if (vector? obj)
+          (if (= (vector-length obj) 4)
+              (eq? (vector-ref obj 0) 'dv:vector)
+              #f)
+          #f)))
+  (define dv:vector-length
+    (lambda (obj) (vector-ref obj 1)))
+  (define dv:vector-size
+    (lambda (obj) (vector-ref obj 2)))
+  (define dv:vector-contents
+    (lambda (obj) (vector-ref obj 3)))
+  (define dv:set-vector-length!
+    (lambda (obj newval) (vector-set! obj 1 newval)))
+  (define dv:set-vector-size!
+    (lambda (obj newval) (vector-set! obj 2 newval)))
+  (define dv:set-vector-contents!
+    (lambda (obj newval) (vector-set! obj 3 newval)))
+  (define dv:make-vector
+    (lambda (length size contents)
+      ((lambda () (vector 'dv:vector length size contents)))))
+  
+  (define dv:make
+    (let* ((default-initial-size 8)
+           (default-initial-vector (make-vector default-initial-size)))
+      (lambda arg
+        (cond
+          ((null? arg)
+           (dv:make-vector 0 default-initial-size default-initial-vector))
+          ((= 1 (length arg))
+           (let ((l (car arg)))
+             (dv:make-vector 0 l (make-vector l))))
+          (else
+           (error 'dv:make "wrong number of arguments"))))))
+  
+  (define dv:make-w/-init
+    (lambda values
+      (let ((l (length values)))
+        (dv:make-vector l l (list->vector values)))))
+  
+  (define dv:append
+    (lambda (dv item)
+      (let ((length   (dv:vector-length dv))
+            (size     (dv:vector-size dv))
+            (contents (dv:vector-contents dv)))
+        (if (< length size)
+            (begin
+              (vector-set! contents length item)
+              (dv:set-vector-length! dv (+ length 1)))
+            (begin
+              (let ((new-vector (make-vector (* size 2))))
+                (let loop
+		  ((i 0))
+                  (when (< i size)
+                    (vector-set! new-vector i (vector-ref contents i))
+                    (loop (+ i 1))))
+                (dv:set-vector-contents! dv new-vector)
+                (dv:set-vector-size! dv (* size 2))
+                (dv:append dv item)))))))
+  
+  (define dv:remove-last
+    (lambda (dv) 
+      (dv:set-vector-length! dv (- (dv:vector-length dv) 1))
+      (vector-set! (dv:vector-contents dv) (dv:vector-length dv) 0)))
+  
+  
+  (define dv:legitimate-index
+    (lambda (dv index)
+      (< index (dv:vector-length dv))))
+  
+  (define dv:ref
+    (lambda (dv index)
+      (if (dv:legitimate-index dv index)
+          (vector-ref (dv:vector-contents dv) index)
+          (error 'dv:ref "index too large"))))
+  
+  (define dv:set!
+    (lambda (dv index value)
+      (if (dv:legitimate-index dv index)
+          (vector-set! (dv:vector-contents dv) index value)
+          (error 'dv:set! "index too large"))))
+  
+  (define dv:contents dv:vector-contents)
+  
+  (define dv:length dv:vector-length)
+  )
+