From 3d50bb27f23ceb66f49b586c49ae2b382577226c Mon Sep 17 00:00:00 2001
From: Guillaume Marceau <gmarceau@racket-lang.org>
Date: Tue, 4 Apr 2006 23:20:27 +0000
Subject: [PATCH] cleaned up and fixed base-gm.ss in frtime and mztake

svn: r2595
---
 collects/frtime/base-gm.ss | 42 +++++++++++++++++++++++++++++++---
 collects/frtime/heap.ss    | 47 ++++++++++++++++++--------------------
 2 files changed, 61 insertions(+), 28 deletions(-)

diff --git a/collects/frtime/base-gm.ss b/collects/frtime/base-gm.ss
index cf4c0ca651..8d05420e3a 100644
--- a/collects/frtime/base-gm.ss
+++ b/collects/frtime/base-gm.ss
@@ -2,13 +2,40 @@
   (require (lib "list.ss")
 	   (lib  "etc.ss"))
   
-  (provide make-hash
+  (provide assert
+           print-each
+           make-hash
 	   hash-get
 	   hash-put!
 	   hash-remove!
 	   hash-map
 	   hash-for-each
-	   hash-mem?)
+	   hash-mem?
+           hash-fold
+           hash-keys
+           hash-add-all!)
+
+  (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 (format-each src-text msg ...)))))]))
+  
+  (define (format-each . args)
+    (apply string-append (map (lambda (s) (format "~a " s)) args)))
+  
+  (define (print-each . args)
+    (printf "~a~n" (apply format-each args)))
+
   
   (define make-hash make-hash-table)
   (define hash-get hash-table-get)
@@ -16,4 +43,13 @@
   (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))))
\ No newline at end of file
+  (define (hash-mem? hash item) (hash-get hash item (lambda () false)))
+  (define (hash-fold hash init fn)
+    (hash-for-each hash (lambda (key val) (set! init (fn key val init)))) init)
+  (define (hash-keys hash)
+    (hash-fold hash empty (lambda (key val acc) (cons key 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))))
+
+  )
\ No newline at end of file
diff --git a/collects/frtime/heap.ss b/collects/frtime/heap.ss
index a64ea1fced..fad7748c1c 100644
--- a/collects/frtime/heap.ss
+++ b/collects/frtime/heap.ss
@@ -2,12 +2,13 @@
   
   (require (lib "etc.ss")
 	   "base-gm.ss"
+           (lib "list.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 heap->list)
   
   
   
@@ -119,43 +120,39 @@
   (define (heap-resort heap item)
     (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 (heap->list heap)
+    (vector->list (t-data heap)))
   
   (define (test)
     (define f (make-heap > eq?))
     (define d (t-data f))
     (heap-insert f 99)
-    (debug "A " d) 
+    (print-each "A " d) 
     (heap-remove-pos f 1)
-    (debug "B " d)
+    (print-each "B " d)
     (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)
-    (heap-remove f 10) (debug " " d)
-    (heap-remove f 5) (debug " " d)
-    (heap-remove f 8) (debug " " d)
-    (heap-remove f 13) (debug " " d)
-    (debug (heap-contains f 11))
-    (debug (heap-contains f 123))
+    (print-each "C " d)
+    (heap-remove f 10) (print-each " " d)
+    (heap-remove f 5) (print-each " " d)
+    (heap-remove f 8) (print-each " " d)
+    (heap-remove f 13) (print-each " " d)
+    (print-each (heap-contains f 11))
+    (print-each (heap-contains f 123))
     (heap-pop f)
     (heap-pop f)
     (heap-pop f)
-    (heap-pop f) (debug " " d)
-    (debug (heap-contains f 11))
-    (debug (heap-contains f 4))
-    (debug (heap-tostring f))
+    (heap-pop f) (print-each " " d)
+    (print-each (heap-contains f 11))
+    (print-each (heap-contains f 4))
+    (print-each (heap->list f))
     (heap-remove f 2)
-    (debug (heap-tostring f))
+    (print-each (heap->list f))
     (heap-remove f 3)
-    (debug (heap-tostring f))
+    (print-each (heap->list f))
     )
+  
+  ;(test)
 
   )