Merge remote-tracking branch 'arvyy/master'

1 files changed, 111 insertions, 0 deletions

diff --git a/srfi/plist-impl.scm b/srfi/plist-impl.scm
new file mode 100644
index 0000000..d291870
--- /dev/null
+++ b/srfi/plist-impl.scm
@@ -0,0 +1,111 @@
+(define plist-dtd
+  (let ()
+
+    (define (plist? dtd l)
+      (and (list? l)
+           (or (null? l)
+               (symbol? (car l)))))
+
+    (define (plist-map dtd proc plist)
+      (let loop ((pl plist)
+                 (new-pl/rev '()))
+        (cond
+         ((null? pl) (reverse new-pl/rev))
+         ((null? (cdr pl)) (error "Malformed plist" plist))
+         (else
+          (let ((key (car pl))
+                (value (cadr pl))
+                (rest (cddr pl)))
+            (loop rest
+                  (append (list (proc key value) key) new-pl/rev)))))))
+
+    (define (plist-filter dtd pred plist)
+      (let loop ((pl plist)
+                 (new-pl/rev '()))
+        (cond
+         ((null? pl) (reverse new-pl/rev))
+         ((null? (cdr pl)) (error "Malformed plist" plist))
+         (else
+          (let ((key (car pl))
+                (value (cadr pl))
+                (rest (cddr pl)))
+            (if (pred key value)
+                (loop rest
+                      (append (list value key) new-pl/rev))
+                (loop rest
+                      new-pl/rev)))))))
+
+    (define (find-plist-entry key plist)
+      (cond
+       ((null? plist) #f)
+       ((eq? key (car plist)) plist)
+       (else (find-plist-entry key (cddr plist)))))
+    
+    (define (plist-delete key-to-delete plist)
+      (let loop ((pl plist)
+                 (new-pl/rev '()))
+        (cond
+          ((null? pl) (reverse new-pl/rev))
+          ((null? (cdr pl)) (error "Malformed plist"))
+          (else (let ((key (car pl))
+                      (value (cadr pl))
+                      (rest (cddr pl)))
+                  (if (eq? key-to-delete key)
+                      (loop rest new-pl/rev)
+                      (loop rest (append (list value key) new-pl/rev))))))))
+
+    (define (plist-alter dtd plist key failure success)
+      (define (handle-success pair)
+        (define old-key (car pair))
+        (define old-value (cadr pair))
+        (define (update new-key new-value)
+          (cond
+            ((and (eq? old-key
+                       new-key)
+                  (eq? old-value
+                       new-value))
+             plist)
+            (else
+              (let ((new-list
+                      (append (list new-key new-value)
+                              (plist-delete old-key plist))))
+                new-list))))
+        (define (remove)
+          (plist-delete old-key plist))
+        (success old-key old-value update remove))
+
+      (define (handle-failure)
+        (define (insert value)
+          (append (list key value) plist))
+        (define (ignore)
+          plist)
+        (failure insert ignore))
+      (cond
+        ((find-plist-entry key plist) => handle-success)
+        (else (handle-failure))))
+
+    (define (plist-size dtd plist)
+      (/ (length plist) 2))
+
+    (define (plist-foreach dtd proc plist)
+      (let loop ((pl plist))
+        (if (null? pl) #t
+            (begin
+              (proc (car pl) (cadr pl))
+              (loop (cddr pl))))))
+    
+    (define (plist-mutable? dtd plist)
+      #f)
+
+    (define (plist-comparator dtd plist)
+      #f)
+
+    (make-dtd
+     dictionary?-id plist?
+     dict-mutable?-id plist-mutable?
+     dict-map-id plist-map
+     dict-filter-id plist-filter
+     dict-alter-id plist-alter
+     dict-size-id plist-size
+     dict-for-each-id plist-foreach
+     dict-comparator-id plist-comparator)))