internals impl; tests

3 files changed, 589 insertions, 74 deletions

diff --git a/indexes.scm b/indexes.scm
index 4476943..c126c52 100644
--- a/indexes.scm
+++ b/indexes.scm
@@ -39,32 +39,32 @@
 ;;; Maps names to indexes
 
 (define dname-map 
-  `(dictionary? . ,d?)
-   (dict-empty? . ,dempty?)
-   (dict-contains? . ,dcontains?)
-   (dict-ref . ,dref)
-   (dict-ref/default . ,dref/default)
-   (dict-set! . ,dset!)
-   (dict-adjoin! . ,dadjoin!)
-   (dict-delete! . ,ddelete!)
-   (dict-delete-all! . ,ddelete-all!)
-   (dict-replace! . ,dreplace!)
-   (dict-intern! . ,dintern!)
-   (dict-update! . ,dupdate!)
-   (dict-update/default! . ,dupdate/default!)
-   (dict-pop! . ,dpop!)
-   (dict-map! . ,dmap!)
-   (dict-filter! . ,dfilter!)
-   (dict-remove! . ,dremove!)
-   (dict-search! . ,dsearch!)
-   (dict-size . ,dsize)
-   (dict-for-each . ,dfor-each)
-   (dict-count . ,dcount)
-   (dict-any . ,dany)
-   (dict-every . ,devery)
-   (dict-keys . ,dkeys)
-   (dict-values . ,dvalues)
-   (dict-entries . ,dentries)
-   (dict-fold . ,dfold)
-   (dict-map->list . ,dmap->list)
-   (dict->alist . ,d->alist))
+  `((dictionary? . ,d?)
+    (dict-empty? . ,dempty?)
+    (dict-contains? . ,dcontains?)
+    (dict-ref . ,dref)
+    (dict-ref/default . ,dref/default)
+    (dict-set! . ,dset!)
+    (dict-adjoin! . ,dadjoin!)
+    (dict-delete! . ,ddelete!)
+    (dict-delete-all! . ,ddelete-all!)
+    (dict-replace! . ,dreplace!)
+    (dict-intern! . ,dintern!)
+    (dict-update! . ,dupdate!)
+    (dict-update/default! . ,dupdate/default!)
+    (dict-pop! . ,dpop!)
+    (dict-map! . ,dmap!)
+    (dict-filter! . ,dfilter!)
+    (dict-remove! . ,dremove!)
+    (dict-search! . ,dsearch!)
+    (dict-size . ,dsize)
+    (dict-for-each . ,dfor-each)
+    (dict-count . ,dcount)
+    (dict-any . ,dany)
+    (dict-every . ,devery)
+    (dict-keys . ,dkeys)
+    (dict-values . ,dvalues)
+    (dict-entries . ,dentries)
+    (dict-fold . ,dfold)
+    (dict-map->list . ,dmap->list)
+    (dict->alist . ,d->alist)))
diff --git a/internals-test.scm b/internals-test.scm
new file mode 100644
index 0000000..dd760d9
--- /dev/null
+++ b/internals-test.scm
@@ -0,0 +1,392 @@
+(import (scheme base)
+        (srfi 1)
+        (srfi 64))
+
+(include "indexes.scm")
+(include "internals.scm")
+
+(define (alist? vec l)
+  (and (list? l) (every pair? l)))
+
+(define (alist-map! vec proc alist)
+  (map 
+    (lambda (e)
+      (define key (car e))
+      (define value (cdr e))
+      (cons key (proc key value))) 
+    alist))
+
+(define (alist-filter! vec pred alist)
+  (filter
+    (lambda (e)
+      (pred (car e) (cdr e))) 
+    alist))
+
+(define (alist-search! vec alist key failure success)
+  (define (handle-success pair)
+    (define old-key (car pair))
+    (define old-value (cdr pair))
+    (define (update new-key new-value obj)
+      (cond 
+        ((and (eq? old-key
+                   new-key)
+              (eq? old-value
+                   new-value))
+         (values alist obj))
+        (else
+          (let ((new-list 
+                  (alist-cons
+                    new-key new-value
+                    (alist-delete old-key alist))))
+            (values new-list obj)))))
+    (define (remove obj)
+      (values (alist-delete old-key alist) obj))
+    (success old-key old-value update remove))
+  
+  (define (handle-failure)
+    (define (insert value obj)
+      (values (alist-cons key value alist)
+              obj))
+    (define (ignore obj)
+      (values alist obj))
+    (failure insert ignore))
+  (cond
+    ((assoc key alist) => handle-success)
+    (else (handle-failure))))
+
+(define (alist-size vec alist)
+  (define keys (map car alist))
+  (define (fold-proc el set)
+    (lset-adjoin equal? set el))
+  (define key-set (fold fold-proc '() keys))
+  (length key-set))
+
+(define (alist-foreach vec proc alist)
+  (define (proc* e)
+    (proc (car e) (cdr e)))
+  (for-each proc* alist))
+
+
+(define vec (vector-copy model-vec))
+(vector-set! vec d? alist?)
+(vector-set! vec dmap! alist-map!)
+(vector-set! vec dfilter! alist-filter!)
+(vector-set! vec dsearch! alist-search!)
+(vector-set! vec dsize alist-size)
+(vector-set! vec dfor-each alist-foreach)
+
+(test-begin "Dictionary test")
+
+(test-group
+  "idictionary?"
+  (test-assert (dcall d? vec '()))
+  (test-assert (dcall d? vec '((a . b)))))
+
+(test-group
+  "idict-empty?"
+  (test-assert (dcall dempty? vec '()))
+  (test-assert (not (dcall dempty? vec '((a . b))))))
+
+(test-group
+  "idict-contains?"
+  (test-assert (not (dcall dcontains? vec '() 'a)))
+  (test-assert (not (dcall dcontains? vec '((b . c)) 'a)))
+  (test-assert (dcall dcontains? vec '((a . b)) 'a)))
+
+(test-group
+  "idict-ref"
+  (test-assert (dcall dref vec '((a . b)) 'a (lambda () #f) (lambda (x) #t)))
+  (test-assert (dcall dref vec '((a . b)) 'b (lambda () #t) (lambda (x) #f))))
+
+(test-group
+  "idict-ref/default"
+  (test-equal (dcall dref/default vec '((a . b)) 'a 'c) 'b)
+  (test-equal (dcall dref/default vec '((a* . b)) 'a 'c) 'c))
+
+(test-group
+  "idict-set!"
+  (define d (dcall dset! vec '((a . b)) 'a 'c 'a2 'b2))
+  (test-equal '(a . c) (assoc 'a d))
+  (test-equal '(a2 . b2) (assoc 'a2 d)))
+
+(test-group
+  "idict-adjoin!"
+  (define d (dcall dset! vec '((a . b)) 'a 'c 'a2 'b2))
+  (test-equal '(a . c) (assoc 'a d))
+  (test-equal '(a2 . b2) (assoc 'a2 d)))
+
+(test-group
+  "idict-delete!"
+  (define d (dcall ddelete! vec '((a . b) (c . d)) 'a 'b))
+  (test-equal d '((c . d))))
+
+(test-group
+  "idict-delete-all!"
+  (define d (dcall ddelete-all! vec '((a . b) (c . d)) '(a b)))
+  (test-equal d '((c . d))))
+
+(test-group
+  "idict-replace!"
+  (define d (dcall dreplace! vec '((a . b) (c . d)) 'a 'b2))
+  (test-equal '(a . b2) (assoc 'a d))
+  (test-equal '(c . d) (assoc 'c d)))
+
+(test-group
+  "idict-intern!"
+  
+  ;; intern existing
+  (let ()
+   (define-values 
+     (d value) 
+     (dcall dintern! vec '((a . b)) 'a (lambda () 'd))) 
+   (test-equal '(a . b) (assoc 'a d))
+   (test-equal 'b value))
+  
+  ;; intern missing
+  (let ()
+   (define-values
+     (d value)
+     (dcall dintern! vec '((a . b)) 'c (lambda () 'd)))
+   (test-equal '(a . b) (assoc 'a d))
+   (test-equal '(c . d) (assoc 'c d))
+   (test-equal 'd value)))
+
+(test-group
+  "idict-update!"
+  
+  ;; update existing
+  (let ()
+   (define d (dcall dupdate! vec '((a . "b")) 'a 
+                    (lambda (value) 
+                      (string-append value "2"))
+                    error
+                    (lambda (x) (string-append x "1")))) 
+   (test-equal '(a . "b12") (assoc 'a d)))
+  
+  ;; update missing
+  (let ()
+   (define d (dcall dupdate! vec '((a . "b")) 'c
+                    (lambda (value) 
+                      (string-append value "2"))
+                    (lambda () "d1")
+                    (lambda (x) (string-append x "1")))) 
+   (test-equal '(c . "d12") (assoc 'c d))))
+
+(test-group
+  "idict-update/default!"
+  ;; update existing
+  (let ()
+   (define d (dcall dupdate/default! vec '((a . "b")) 'a 
+                    (lambda (value) 
+                      (string-append value "2"))
+                    "d1")) 
+   (test-equal '(a . "b2") (assoc 'a d)))
+  
+  ;; update missing
+  (let ()
+   (define d (dcall dupdate/default! vec '((a . "b")) 'c
+                    (lambda (value) 
+                      (string-append value "2"))
+                    "d1")) 
+   (test-equal '(c . "d12") (assoc 'c d))))
+
+(test-group
+  "idict-pop!"
+  (define-values
+    (new-dict key value)
+    (dcall dpop! vec '((a . b) (c . d)) error))
+  (test-equal new-dict '((c . d)))
+  (test-equal key 'a)
+  (test-equal value 'b))
+
+(test-group
+  "idict-map!"
+  (define d (dcall dmap! vec 
+                   (lambda (key value)
+                     (string-append value "2"))
+                   '((a . "a") (b . "b"))))
+  (test-equal '(a . "a2") (assoc 'a d))
+  (test-equal '(b . "b2") (assoc 'b d)))
+
+(test-group
+  "idict-filter!"
+  (define d (dcall dfilter! vec
+                   (lambda (key value)
+                     (equal? value 'b))
+                   '((a . b) (c . d))))
+  (test-equal '((a . b)) d))
+
+(test-group
+  "idict-remove!"
+  (define d (dcall dremove! vec
+                   (lambda (key value)
+                     (equal? value 'b))
+                   '((a . b) (c . d))))
+  (test-equal '((c . d)) d))
+
+(test-group
+  "idict-search!"
+  
+  ;; ignore 
+  (let ()
+   (define-values 
+     (dict value)
+     (dcall dsearch! vec '((a . b)) 'c
+            (lambda (insert ignore)
+              (ignore 'foo))
+            (lambda args
+              (error))))
+   (test-equal '((a . b)) dict)
+   (test-equal value 'foo))
+  
+  ;; insert
+  (let ()
+   (define-values 
+     (dict value)
+     (dcall dsearch! vec '((a . b)) 'c
+            (lambda (insert ignore)
+              (insert 'd 'foo))
+            (lambda args
+              (error))))
+   (test-equal '(a . b) (assoc 'a dict))
+   (test-equal '(c . d) (assoc 'c dict))
+   (test-equal value 'foo))
+  
+  ;; update
+  (let ()
+   (define-values 
+     (dict value)
+     (dcall dsearch! vec '((a . b)) 'a
+            (lambda args
+              (error))
+            (lambda (key value update delete)
+              (update 'a2 'b2 'foo))))
+   (test-equal '((a2 . b2)) dict)
+   (test-equal value 'foo))
+  
+  ;; delete
+  (let ()
+   (define-values 
+     (dict value)
+     (dcall dsearch! vec '((a . b) (c . d)) 'a
+            (lambda args
+              (error))
+            (lambda (key value update delete)
+              (delete 'foo))))
+   (test-equal '((c . d)) dict)
+   (test-equal value 'foo)))
+
+(test-group
+  "idict-size"
+  (test-equal 2 (dcall dsize vec '((a . b) (c . d))))
+  (test-equal 0 (dcall dsize vec '())))
+
+(test-group
+  "idict-for-each"
+  (define lst '())
+  (dcall dfor-each vec
+         (lambda (key value)
+           (set! lst (append lst (list key value))))
+         '((a . b) (c . d)))
+  (test-equal '(a b c d) lst))
+
+(test-group
+  "idict-count"
+  (define count (dcall dcount vec
+                       (lambda (key value)
+                         (equal? value 'b))
+                       '((a . b) (c . d))))
+  (test-equal count 1))
+
+(test-group
+  "idict-any"
+  
+  (let ()
+   (define value 
+     (dcall dany vec
+            (lambda (key value)
+              (if (equal? 'b value) 'foo #f))
+            '((a . b) (c . d))))
+   (test-equal value 'foo))
+
+  (let ()
+   (define value 
+     (dcall dany vec
+            (lambda (key value)
+              (if (equal? 'e value) 'foo #f))
+            '((a . b) (c . d))))
+   (test-equal value #f)))
+
+(test-group
+  "idict-every"
+  (let ()
+   (define value
+     (dcall devery vec
+            (lambda (key value)
+              (if (equal? 'b value) 'foo #f))
+            '((a . b) (c . b))))
+   (test-equal value 'foo))
+  
+  (let ()
+   (define value
+     (dcall devery vec
+            (lambda (key value)
+              (if (equal? 'b value) 'foo #f))
+            '()))
+   (test-equal value #t))
+  
+  (let ()
+   (define value
+     (dcall devery vec
+            (lambda (key value)
+              (if (equal? 'b value) 'foo #f))
+            '((a . b) (c . d))))
+   (test-equal value #f)))
+
+(test-group
+  "idict-keys"
+  (define keys
+    (dcall dkeys vec '((a . b) (c . d))))
+  (test-equal '(a c) keys))
+
+(test-group
+  "idict-values"
+  (define vals
+    (dcall dvalues vec '((a . b) (c . d))))
+  (test-equal '(b d) vals))
+
+(test-group
+  "idict-entries"
+  (define-values
+    (keys vals)
+    (dcall dentries vec '((a . b) (c . d))))
+  (test-equal '(a c) keys)
+  (test-equal '(b d) vals))
+
+(test-group
+  "idict-fold"
+  (define value
+    (dcall dfold vec
+           (lambda (key value acc)
+             (append acc (list key value)))
+           '()
+           '((a . b) (c . d))))
+  (test-equal value '(a b c d)))
+
+(test-group
+  "idict-map->list"
+  (define lst
+    (dcall dmap->list vec
+           (lambda (key value)
+             (string-append (symbol->string key)
+                            value))
+           '((a . "b") (c . "d"))))
+  (test-equal '("ab" "cd") lst))
+
+(test-group
+  "idict->alist"
+  (define alist
+    (dcall d->alist vec '((a . b) (c . d))))
+  (test-equal alist '((a . b) (c . d))))
+
+(test-end)
diff --git a/internals.scm b/internals.scm
index 76aed2c..c732684 100644
--- a/internals.scm
+++ b/internals.scm
@@ -11,7 +11,7 @@
 (define-syntax dcall
   (syntax-rules ()
     ((dcall dproc vec dictionary arg ...)
-     ((vector-ref vec dindex) vec dictionary arg ...))))
+     ((vector-ref vec dproc) vec dictionary arg ...))))
 
 (define (idictionary? vec obj)
   (error "dictionary? method not defined"))
@@ -24,46 +24,120 @@
          (lambda () #f) (lambda (x) #t)))
 
 (define (idict-ref vec dictionary key failure success)
-  #f)
+  (define-values
+    (new-dict result)
+    (dcall dsearch! vec dictionary key 
+           (lambda (_ ignore)
+             (ignore (failure)))
+           (lambda (key value update _)
+             (update key value (success value)))))
+  result)
 
 (define (idict-ref/default vec dictionary key default)
-  #f)
+  (dcall dref vec dictionary key
+         (lambda () default)
+         (lambda (x) x)))
+
+;; private
+(define (idict-set!* vec dictionary use-old? objs)
+  (let loop ((objs objs)
+             (dictionary dictionary))
+    (cond
+      ((null? objs) 
+       dictionary)
+      ((null? (cdr objs))
+       (error "mismatch of key / values argument list"))
+      (else (let*-values
+              (((key) (car objs))
+               ((value) (cadr objs))
+               ((new-d _) (dcall dsearch! vec dictionary key
+                                 (lambda (insert ignore)
+                                   (insert value #f))
+                                 (lambda (key old-value update delete)
+                                   (update key (if use-old? old-value value) #f)))))
+              (loop (cddr objs)
+                    new-d))))))
 
 (define (idict-set! vec dictionary . objs)
-  #f)
+  (idict-set!* vec dictionary #f objs))
 
 (define (idict-adjoin! vec dictionary . objs)
-  #f)
+  (idict-set!* vec dictionary #t objs))
 
 (define (idict-delete! vec dictionary . keys)
-  #f)
+  (dcall ddelete-all! vec dictionary keys))
 
 (define (idict-delete-all! vec dictionary keylist)
-  #f)
+  (let loop ((keylist keylist)
+             (dictionary dictionary))
+    (cond
+      ((null? keylist) dictionary)
+      (else (let*-values 
+              (((key) (car keylist))
+               ((new-d _) (dcall dsearch! vec dictionary key
+                                 (lambda (_ ignore) 
+                                   (ignore #f))
+                                 (lambda (key old-value _ delete)
+                                   (delete #f)))))
+              (loop (cdr keylist)
+                    new-d))))))
 
 (define (idict-replace! vec dictionary key value)
-  #f)
+  (define-values
+    (new-dict _)
+    (dcall dsearch! vec dictionary key
+         (lambda (_ ignore)
+           (ignore #f))
+         (lambda (key old-value update _)
+           (update key value #f))))
+  new-dict)
 
 (define (idict-intern! vec dictionary key failure)
-  #f)
+  (dcall dsearch! vec dictionary key
+         (lambda (insert _)
+           (let ((value (failure)))
+            (insert value value)))
+         (lambda (key value update _)
+           (update key value value))))
 
 (define (idict-update! vec dictionary key updater failure success)
-  #f)
+  (define-values
+    (new-dict _)
+    (dcall dsearch! vec dictionary key
+           (lambda (insert ignore)
+             (insert (updater (failure)) #f))
+           (lambda (key value update _)
+             (update key (updater (success value)) #f))))
+  new-dict)
 
 (define (idict-update/default! vec dictionary key updater default)
-  #f)
+  (dcall dupdate! vec dictionary key updater
+         (lambda () default)
+         (lambda (x) x)))
 
 (define (idict-pop! vec dictionary failure)
-  #f)
-
-(define (idict-map! proc vec dictionary)
+  (define (do-pop)
+    (call/cc
+      (lambda (cont)
+        (dcall dfor-each vec
+               (lambda (key value)
+                 (define new-dict
+                   (dcall ddelete! vec dictionary key))
+                 (cont new-dict key value)) 
+               dictionary))))
+  (define empty? (dcall dempty? vec dictionary))
+  (if empty?
+      (failure)
+      (do-pop)))
+
+(define (idict-map! vec proc dictionary)
   (error "dict-map method not defined"))
 
-(define (idict-filter! pred vec dictionary)  
+(define (idict-filter! vec pred dictionary)  
   (error "dict-filter! method not defined"))
 
 (define (idict-remove! vec pred dictionary)
-  #f)
+  (dcall dfilter! vec (lambda (key value) (not (pred key value))) dictionary))
 
 (define (idict-search! vec dictionary key failure success)
   (error "dict-search! method not defined"))
@@ -71,42 +145,91 @@
 (define (idict-size vec dictionary)
   (error "dict-size method not defined"))
 
-(define (idict-for-each proc vec dictionary)
+(define (idict-for-each vec proc dictionary)
   (error "dict-for-each method not defined"))
 
-(define (idict-count pred vec dictionary)
-  #f)
-
-(define (idict-any pred vec dictionary)
-  #f)
-
-(define (idict-every pred vec dictionary)
-  #f)
+(define (idict-count vec pred dictionary)
+  (dcall dfold vec
+         (lambda (key value acc)
+           (if (pred key value)
+               (+ 1 acc)
+               acc))
+         0
+         dictionary))
+
+(define (idict-any vec pred dictionary)
+  (call/cc
+    (lambda (cont)
+      (dcall dfor-each vec
+             (lambda (key value)
+               (define ret (pred key value))
+               (when ret
+                 (cont ret)))
+             dictionary)
+      #f)))
+
+(define (idict-every vec pred dictionary)
+  (define last #t)
+  (call/cc
+    (lambda (cont)
+      (dcall dfor-each vec
+             (lambda (key value)
+               (define ret (pred key value))
+               (when (not ret)
+                 (cont #f))
+               (set! last ret))
+             dictionary)
+      last)))
 
 (define (idict-keys vec dictionary)
-  #f)
+  (reverse
+    (dcall dfold vec
+         (lambda (key value acc)
+           (cons key acc))
+         '()
+         dictionary)))
 
 (define (idict-values vec dictionary)
-  #f)
+  (reverse
+    (dcall dfold vec
+         (lambda (key value acc)
+           (cons value acc))
+         '()
+         dictionary)))
 
 (define (idict-entries vec dictionary)
-  #f)
-
-(define (idict-fold proc knil vec dictionary)
-  #f)
-
-(define (idict-map->list proc vec dictionary)
-  #f)
+  (values (dcall dkeys vec dictionary)
+          (dcall dvalues vec dictionary)))
+
+(define (idict-fold vec proc knil dictionary)
+  (define acc knil)
+  (dcall dfor-each vec
+         (lambda (key value)
+           (set! acc (proc key value acc)))
+         dictionary)
+  acc)
+
+(define (idict-map->list vec proc dictionary)
+  (call-with-values
+    (lambda ()
+      (dcall dentries vec dictionary))
+    (lambda (keys vals)
+      (map proc
+           keys
+           vals))))
 
 (define (idict->alist vec dictionary)
-  #f)
-
-(define model-vec #(
-  idictionary?  idict-empty?  idict-contains?  idict-ref
-  idict-ref/default idict-set!  idict-adjoin!  idict-delete!
-  idict-delete-all!  idict-replace!  idict-intern!
-  idict-update!  idict-pop!  idict-map!  idict-filter!
-  idict-remove!  idict-search!  idict-size idict-for-each
-  idict-count idict-any idict-every idict-keys
-  idict-values idict-entries idict-fold idict-map->list
-  idict->alist))
+  (dcall dmap->list vec
+         cons
+         dictionary))
+
+(define model-vec 
+  (vector
+    idictionary?  idict-empty?  idict-contains?  idict-ref
+    idict-ref/default idict-set!  idict-adjoin!  idict-delete!
+    idict-delete-all!  idict-replace!  idict-intern!
+    idict-update! idict-update/default! idict-pop!  idict-map!
+    idict-filter!  idict-remove!  idict-search!  idict-size 
+    idict-for-each idict-count idict-any idict-every idict-keys
+    idict-values idict-entries idict-fold idict-map->list
+    idict->alist))