refactored ebus code

1 files changed, 215 insertions, 0 deletions

diff --git a/ebus-racket/3rdparty/bzlib/base/registry.ss b/ebus-racket/3rdparty/bzlib/base/registry.ss
new file mode 100644
index 0000000..d0b0c72
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/registry.ss
@@ -0,0 +1,215 @@
+#lang scheme/base 
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules 
+;; 
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code.  We are not likely to 
+;; fix the code any time soon, and hence any of the functions here are 
+;; explicitly likely to be obsoleted or moved elsewhere. 
+;; 
+;; Proceed with caution. 
+;; 
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; registry.ss - generalized key/value access (including an extensible condition object)
+;; yc 9/8/2009 - first version 
+;; yc 7/7/2010 - add registry-clear! & modified registry definition. 
+(require mzlib/pconvert-prop
+         scheme/port
+         scheme/string
+         scheme/contract
+         "base.ss"
+         )
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; registry
+;; a abstraction over key/value pairs 
+
+(define-struct registry (get set del make (table #:mutable)))
+
+(define (registry-set! reg key val)
+  (set-registry-table! reg
+                     ((registry-set reg) (registry-table reg) key val)))
+
+(define (registry-del! reg key)
+  (set-registry-table! reg
+                     ((registry-del reg) (registry-table reg) key)))
+
+(define (registry-ref reg key (default #f))
+  ((registry-get reg) (registry-table reg) key default))
+;; (trace registry-ref)
+
+(define (registry-clear! reg) ;; clearing the registry... we need to fill it with a default value, of course. 
+  ;; that means we need a way to get the default value... does that mean we will have to empty out the whole value... 
+  ;; is there a way to do so without adding a new field? 
+  ;; it is completely unclear... hmm... 
+  ;; a hash's function is make-hash... 
+  ;; an immutable-hash's function is make-immutable-hash-helper... 
+  ;; an assoc's function
+  (set-registry-table! reg ((registry-make reg))))
+  
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-hash-registry
+(define (make-hash-registry (hash (make-hash)))
+  (define (set hash key val)
+    (hash-set! hash key val)
+    hash)
+  (define (del hash key)
+    (hash-remove! hash key)
+    hash)
+  (define (make (value (make-hash)))
+    (cond ((hash? value) value) 
+          ((list? value)
+           (let ((h (make-hash))) 
+             (for-each (lambda (kv)
+                         (hash-set! h (car kv) (cdr kv)))
+                       value)
+             h))
+          (else (error 'make-hash-unknown-input "~a" value))))
+  (make-registry hash-ref set del make (make hash)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-immutable-hash-registry
+(define (make-immutable-hash-registry (hash (make-immutable-hash '())))
+  (define (make (value (make-immutable-hash '())))
+    (cond ((and (immutable? value) (hash? value)) value)
+          ((hash? value) (make-immutable-hash (hash-map value cons)))
+          ((list? value) (make-immutable-hash value))
+          (else (error 'make-immutable-hash-unknown-input "~a" value))))
+  (make-registry hash-ref hash-set hash-remove make (make hash)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-assoc-registry (not thread safe if multiple addition & deletion)
+;; let's also a list registry via assoc.
+(define (assoc-ref lst key (default #f))
+  (define (assoc/cdr key value (default #f))
+    (let ((value (assoc key value)))
+      (if (not value) default
+          (cdr value))))
+  (assoc/cdr key lst default))
+;; (trace assoc-ref)
+;; if we just want to remove the first guy with the key... how to do that? not with filter.
+
+(define (assoc-del lst key)
+  (define (helper k kv)
+    (equal? k (car kv)))
+  ;; (trace helper)
+  (remove key lst helper))
+
+(define (assoc-set lst key val)
+  (let ((exists? #f))
+    (let ((lst (map (lambda (kv)
+                      (cons (car kv)
+                            (cond ((equal? (car kv) key)
+                                   (set! exists? #t)
+                                   val)
+                                  (else (cdr kv)))))
+                    lst)))
+      (if exists? lst
+          (cons (cons key val) lst)))))
+
+(define (make-list (lst '())) 
+    (if (list? lst) 
+        lst 
+        (error 'make-assoc-list-unknown-input "~a" lst)))
+
+(define (make-assoc-registry (lst '()))
+  (make-registry assoc-ref assoc-set assoc-del make-list (make-list lst)))
+
+;; what can be passed into ? it must be a list of lists.
+(define (list->assoc-registry lst)
+  (define (helper kvs)
+    (cons (car kvs)
+          (make-assoc-registry (cdr kvs))))
+  ;; (trace helper)
+  (make-assoc-registry (map helper lst)))
+
+(define (assoc-registry->list reg)
+  (map (lambda (kv)
+         (cons (car kv)
+               (registry-table (cdr kv))))
+       (registry-table reg)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; cond-registry (takes in a cond & result pair).
+(define (cond-ref lst key (default #f))
+  (let ((it (assf (lambda (cond)
+                    (cond key)) lst)))
+    (if (not it) default
+        (cdr it))))
+
+(define (make-cond-registry (lst '()))
+  (make-registry cond-ref assoc-set assoc-del make-list (make-list lst)))
+
+(provide/contract
+ (struct registry ((get (->* (any/c any/c)
+                             (any/c)
+                             any))
+                   (set (-> any/c any/c any/c any))
+                   (del (-> any/c any/c any))
+                   (make (->* () 
+                              (any/c) 
+                              any/c))
+                   (table any/c)))
+ (registry-ref (->* (registry? any/c)
+                    (any/c)
+                    any))
+ (registry-set! (-> registry? any/c any/c any))
+ (registry-del! (-> registry? any/c any))
+ (registry-clear! (-> registry? any))
+ (make-hash-registry (->* ()
+                          ((or/c list? hash?))
+                          registry?))
+ (make-immutable-hash-registry (->* ()
+                                    ((or/c list? (and/c immutable? hash?)))
+                                    registry?))
+ (assoc-ref (->* (list? any/c)
+                 (any/c)
+                 any))
+ (assoc-set (-> list? any/c any/c any))
+ (assoc-del (-> list? any/c any))
+ (make-assoc-registry (->* ()
+                           (list?)
+                           registry?))
+ (list->assoc-registry (-> list? registry?))
+ (assoc-registry->list (-> registry? list?))
+ (make-cond-registry (->* ()
+                          (list?)
+                          registry?))
+ )
+
+;; let's see how something can be flushed...
+(define (registry->out reg out)
+  (write (registry-table reg) out))
+
+(define (registry->string reg)
+  (let ((out (open-output-bytes)))
+    (registry->out reg out)
+    (get-output-string out)))
+
+(define (in->registry in)
+  (let ((value (read in)))
+    (cond ((list? value)
+           (make-assoc-registry value))
+          ((and (hash? value) (immutable? value))
+           (make-immutable-hash-registry value))
+          ((hash? value)
+           (make-hash-registry value))
+          ((eof-object? value)
+           (make-assoc-registry))
+          (else
+           (error 'in->registry "unknown registry type ~a" value)))))
+
+(define (string->registry string)
+  (in->registry (open-input-string string)))
+
+(provide/contract
+ (registry->out (-> registry? output-port? any))
+ (registry->string (-> registry? string?))
+ (in->registry (-> input-port? registry?))
+ (string->registry (-> string? registry?))
+ )
+