picolisp

commit 7d49f22ea64f370afc15b465d312fa6ea53fac59
parent df107bed5a083367bcb459a895c8e63f2db096a2
Author: Alexander Burger <abu@software-lab.de>
Date:   Mon,  4 Mar 2013 08:14:44 +0100

'idxRel' factorization and '+IdxFold' class
Diffstat:
M
CHANGES
 | 
2
+-
M
lib/db.l
 | 
94
++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------

2 files changed, 65 insertions(+), 31 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,4 @@
-* DDmmm13 picoLisp-3.1.2
+* DDmar13 picoLisp-3.1.2
    'fold' analog to 'lowc' / 'uppc'
    'fold' second arg default zero
    Removed 'dbg' startup script
diff --git a/lib/db.l b/lib/db.l
@@ -1,4 +1,4 @@
-# 25feb13abu
+# 03mar13abu
 # (c) Software Lab. Alexander Burger
 
 # *Dbs *Jnl *Blob upd
@@ -448,7 +448,7 @@
    (extra Var (cdr Lst)) )
 
 
-# (+Key) hook
+# (+Key +relation) [hook]
 (class +Key +index)
 
 (dm mis> (Val Obj Hook)
@@ -486,7 +486,7 @@
    (extra Obj Val Hook) )
 
 
-# (+Ref) hook
+# (+Ref +relation) [hook]
 (class +Ref +index)
 # aux ub
 
@@ -565,7 +565,7 @@
    (extra Obj Val Hook) )
 
 
-# (+Idx) cnt hook
+# (+Idx +relation) [cnt [hook]]
 (class +Idx +Ref)
 # min
 
@@ -573,51 +573,48 @@
    (=: min (or (car Lst) 3))
    (super Var (cdr Lst)) )
 
-(dm rel> (Obj Old New Hook)
+(de idxRel (Obj Old Olds New News Hook)
    (let
       (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
-         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
+         Aux (mapcar '((S) (get Obj S)) (: aux))
+         Aux2 (append Aux (cons Obj)) )
+      (setq Aux (conc Aux Obj))
       (when Old
          (store Tree (cons Old Aux) NIL (: dbf))
-         (for S (split (cdr (chop Old)) " " "^J")
+         (for S Olds
             (while (nth S (: min))
                (store Tree (cons (pack S) Aux2) NIL (: dbf))
                (pop 'S) ) ) )
       (when (and New (not (get Obj T)))
          (store Tree (cons New Aux) Obj (: dbf))
-         (for S (split (cdr (chop New)) " " "^J")
+         (for S News
             (while (nth S (: min))
                (store Tree (cons (pack S) Aux2) Obj (: dbf))
-               (pop 'S) ) ) ) )
+               (pop 'S) ) ) ) ) )
+
+(dm rel> (Obj Old New Hook)
+   (idxRel Obj
+      Old (split (cdr (chop Old)) " " "^J")
+      New (split (cdr (chop New)) " " "^J")
+      Hook )
    (extra Obj Old New Hook) )
 
 (dm lose> (Obj Val Hook)
-   (let
-      (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
-         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
-      (store Tree (cons Val Aux) NIL (: dbf))
-      (for S (split (cdr (chop Val)) " " "^J")
-         (while (nth S (: min))
-            (store Tree (cons (pack S) Aux2) NIL (: dbf))
-            (pop 'S) ) ) )
+   (idxRel Obj
+      Val (split (cdr (chop Val)) " " "^J")
+      NIL NIL
+      Hook )
    (extra Obj Val Hook) )
 
 (dm keep> (Obj Val Hook)
-   (let
-      (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
-         Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj)
-         Aux2 (conc (mapcar '((S) (get Obj S)) (: aux)) (cons Obj)) )
-      (store Tree (cons Val Aux) Obj (: dbf))
-      (for S (split (cdr (chop Val)) " " "^J")
-         (while (nth S (: min))
-            (store Tree (cons (pack S) Aux2) Obj (: dbf))
-            (pop 'S) ) ) )
+   (idxRel Obj
+      NIL NIL
+      Val (split (cdr (chop Val)) " " "^J")
+      Hook )
    (extra Obj Val Hook) )
 
 
-# (+Sn +index) hook
+# (+Sn +index) [hook]
 (class +Sn)
 
 (dm rel> (Obj Old New Hook)
@@ -644,7 +641,7 @@
    (extra Obj Val Hook) )
 
 
-# (+Fold +index) hook
+# (+Fold +index) [hook]
 (class +Fold)
 
 (dm has> (Val X)
@@ -661,6 +658,43 @@
    (extra Obj (fold Val) Hook) )
 
 
+# (+IdxFold +relation) [cnt [hook]]
+(class +IdxFold +Fold +Ref)
+
+(dm T (Var Lst)
+   (=: min (or (car Lst) 3))
+   (super Var (cdr Lst)) )
+
+(dm rel> (Obj Old New Hook)
+   (idxRel Obj
+      (fold Old)
+      (extract '((L) (extract fold L))
+         (split (cdr (chop Old)) " " "^J") )
+      (fold New)
+      (extract '((L) (extract fold L))
+         (split (cdr (chop New)) " " "^J") )
+      Hook )
+   (extra Obj Old New Hook) )
+
+(dm lose> (Obj Val Hook)
+   (idxRel Obj
+      (fold Val)
+      (extract '((L) (extract fold L))
+         (split (cdr (chop Val)) " " "^J") )
+      NIL NIL
+      Hook )
+   (extra Obj Val Hook) )
+
+(dm keep> (Obj Val Hook)
+   (idxRel Obj
+      NIL NIL
+      (fold Val)
+      (extract '((L) (extract fold L))
+         (split (cdr (chop Val)) " " "^J") )
+      Hook )
+   (extra Obj Val Hook) )
+
+
 # (+Aux) lst
 (class +Aux)