commit 65976e89d6d0c74806f0c92dbc91de0d13c2a36b
parent 89c68e5b7d6475492c765c6135a5a9389f9029f7
Author: Alexander Burger <abu@software-lab.de>
Date: Fri, 20 May 2011 14:15:58 +0200
UB-Tree support
Diffstat:
13 files changed, 172 insertions(+), 58 deletions(-)
diff --git a/CHANGES b/CHANGES
@@ -1,4 +1,5 @@
* XXjun11 picoLisp-3.0.7
+ UB-Tree support in "lib/db.l"
Renamed "ersatz/picolisp" to "ersatz/pil"
Changed '@' to '!' for functions in URLs
64-bit version for PowerPC (ppc64)
diff --git a/ReleaseNotes b/ReleaseNotes
@@ -1,4 +1,4 @@
-16may11abu
+20may11abu
(c) Software Lab. Alexander Burger
@@ -34,3 +34,7 @@
5. For Ersatz PicoLisp, the startup script's name was changed from "picolisp" to
"pil", to be consistent with 'pil' in "real" PicoLisp.
+
+6. There is a new prefix class '+UB' for '+Aux' relations. It maintains
+ UB-Trees, which allow efficient range access to multidimensional data.
+ Currently, only numeric keys are supported.
diff --git a/doc/db b/doc/db
@@ -25,15 +25,16 @@
Key Arguments for DB- and Pilog-functions:
- 123, {abc} -> (123) (123 . T)
- T -> All
- "abc" -> ("abc") ("abcT" . T)
+ 123, {abc} -> (123) (123 . T)
+ T -> All
+ "abc" -> ("abc") ("abcT" . T)
- (a b) -> (a b) (a b . T)
- ((a 1) b 2) -> (a 1) (b 2 . T)
+ (a b) -> (a b) (a b . T)
+ ((a 1) b 2) -> (a 1) (b 2 . T)
+ ((1 . 3) (4 . 7)) -> (33 . 61)
- (a . b) -> (a) (b . T)
- (b . a) -> (b . T) (a)
+ (a . b) -> (a) (b . T)
+ (b . a) -> (b . T) (a)
loaded/dirty/deleted
diff --git a/doc/ref.html b/doc/ref.html
@@ -2321,6 +2321,7 @@ abbreviations:
<a href="refS.html#+Sn">+Sn</a>
<a href="refF.html#+Fold">+Fold</a>
<a href="refA.html#+Aux">+Aux</a>
+ <a href="refU.html#+UB">+UB</a>
<a href="refD.html#+Dep">+Dep</a>
<a href="refL.html#+List">+List</a>
<a href="refN.html#+Need">+Need</a>
diff --git a/doc/refA.html b/doc/refA.html
@@ -96,7 +96,8 @@ href="refR.html#+relation">+relation</a></code>s, in addition to <code><a
href="refR.html#+Ref">+Ref</a></code> or <code><a
href="refI.html#+Idx">+Idx</a></code> indexes. Expects a list of auxiliary
attributes of the same object, and combines all keys in that order into a single
-index key. See also <code><a href="refA.html#aux">aux</a></code> and <code><a
+index key. See also <code><a href="refU.html#+UB">+UB</a></code>, <code><a
+href="refA.html#aux">aux</a></code> and <code><a
href="ref.html#dbase">Database</a></code>.
<pre><code>
diff --git a/doc/refR.html b/doc/refR.html
@@ -85,6 +85,7 @@ href="refI.html#+Idx">+Idx</a></code>, <code><a
href="refS.html#+Sn">+Sn</a></code>, <code><a
href="refF.html#+Fold">+Fold</a></code>, <code><a
href="refA.html#+Aux">+Aux</a></code>, <code><a
+href="refU.html#+UB">+UB</a></code>, <code><a
href="refD.html#+Dep">+Dep</a></code>, <code><a
href="refL.html#+List">+List</a></code>, <code><a
href="refN.html#+Need">+Need</a></code>, <code><a
diff --git a/doc/refU.html b/doc/refU.html
@@ -29,6 +29,60 @@ href="refL.html#locale">locale</a></code>.
-> ("abc" NIL (1 2 3))
</code></pre>
+<dt><a name="+UB"><code>+UB</code></a>
+<dd>Prefix class for <code><a href="refA.html#+Aux">+Aux</a></code> to maintain
+an UB-Tree index instead of the direct values. This allows efficient range
+access to multidimensional data. Currently, only numeric keys are supported. See
+also <code><a href="ref.html#dbase">Database</a></code>.
+
+<pre><code>
+(class +Pos +Entity)
+(rel x (+UB +Aux +Ref +Number) (y z))
+(rel y (+Ref +Number))
+(rel z (+Ref +Number))
+
+: (scan (tree 'x '+Pos))
+...
+(664594005183881683 . {D}) {D}
+(899018453307525604 . {E}) {E} # UBKEY of (516516 690628 706223)
+(943014863198293414 . {2}) {2}
+(988682500781514058 . {C}) {C}
+(994667870851824704 . {:}) {:}
+(1016631364991047263 . {A}) {A}
+...
+
+: (show '{E})
+{E} (+Pos)
+ z 706223
+ y 690628
+ x 516516
+-> {E}
+
+# Discrete queries work the same way as without the +UB prefix
+: (db 'x '+Pos 516516 'y 690628 'z 706223)
+-> {E}
+: (aux 'x '+Pos 516516 690628 706223)
+-> {E}
+: (? (db x +Pos (516516 690628 706223) @Pos))
+ @Pos={E}
+-> NIL
+
+# Efficient range queries are are possible now
+: (?
+ @X (416511 . 616519)
+ @Y (590621 . 890629)
+ @Z (606221 . 906229)
+ (select (@@)
+ ((x +Pos (@X @Y @Z))) # Range query
+ (range @X @@ x) # Filter
+ (range @Y @@ y)
+ (range @Z @@ z) ) )
+ @X=(416511 . 616519) @Y=(590621 . 890629) @Z=(606221 . 906229) @@={E}
+ @X=(416511 . 616519) @Y=(590621 . 890629) @Z=(606221 . 906229) @@={:}
+
+
+</code></pre>
+
<dt><a name="u"><code>(u) -> T</code></a>
<dd>Removes <code><a href="ref_.html#!">!</a></code> all breakpoints in all
subexpressions of the current breakpoint. Typically used when single-stepping a
diff --git a/ersatz/mkJar b/ersatz/mkJar
@@ -1,5 +1,5 @@
-#!./picolisp
-# 17nov10abu
+#!./pil
+# 20may11abu
# (c) Software Lab. Alexander Burger
(load "../src64/version.l")
diff --git a/ersatz/picolisp.jar b/ersatz/picolisp.jar
Binary files differ.
diff --git a/lib/db.l b/lib/db.l
@@ -1,4 +1,4 @@
-# 09mar11abu
+# 20may11abu
# (c) Software Lab. Alexander Burger
# *Dbs *Jnl *Blob upd
@@ -53,8 +53,9 @@
(fetch Tree Val) )
(let Key (cons (if (isa '+Fold This) (fold Val) Val))
(let? A (: aux)
- (for (L (rest) (and L (== (pop 'A) (pop 'L))) (cdr L))
- (conc Key (cons (car L))) ) )
+ (while (and (args) (== (pop 'A) (next)))
+ (conc Key (cons (next))) )
+ (and (: ub) (setq Key (ubZval Key))) )
(let Q (init Tree Key (append Key T))
(loop
(NIL (step Q T))
@@ -70,10 +71,11 @@
# (aux 'var 'cls ['hook] 'any ..) -> sym
(de aux (Var Cls . @)
(with (treeRel Var Cls)
- (step
- (init (tree (: var) (: cls) (and (: hook) (next)))
- (rest)
- (conc (rest) T) ) ) ) )
+ (let Key (if (: ub) (ubZval (rest)) (rest))
+ (step
+ (init (tree (: var) (: cls) (and (: hook) (next)))
+ Key
+ (append Key T) ) ) ) ) )
# (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst
@@ -469,31 +471,51 @@
# (+Ref) hook
(class +Ref +index)
-# aux
+# aux ub
(dm rel> (Obj Old New Hook)
(let
(Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
- Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) )
+ Aux (mapcar '((S) (get Obj S)) (: aux)) )
(when Old
- (store Tree (cons Old Aux) NIL (: dbf)) )
+ (let Key (cons Old Aux)
+ (store Tree
+ (if (: ub)
+ (ubZval Key Obj)
+ (append Key Obj) )
+ NIL
+ (: dbf) ) ) )
(and New
(not (get Obj T))
- (store Tree (cons New Aux) Obj (: dbf)) ) )
+ (let Key (cons New Aux)
+ (store Tree
+ (if (: ub)
+ (ubZval Key Obj)
+ (conc Key Obj) )
+ Obj
+ (: dbf) ) ) ) )
(extra Obj Old New Hook) )
(dm lose> (Obj Val Hook)
- (store
- (tree (: var) (: cls) (or Hook (get Obj (: hook))))
- (cons Val (conc (mapcar '((S) (get Obj S)) (: aux)) Obj))
- NIL (: dbf) )
+ (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux)))
+ (store
+ (tree (: var) (: cls) (or Hook (get Obj (: hook))))
+ (if (: ub)
+ (ubZval Key Obj)
+ (conc Key Obj) )
+ NIL
+ (: dbf) ) )
(extra Obj Val Hook) )
(dm keep> (Obj Val Hook)
- (store
- (tree (: var) (: cls) (or Hook (get Obj (: hook))))
- (cons Val (conc (mapcar '((S) (get Obj S)) (: aux)) Obj))
- Obj (: dbf) )
+ (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux)))
+ (store
+ (tree (: var) (: cls) (or Hook (get Obj (: hook))))
+ (if (: ub)
+ (ubZval Key Obj)
+ (conc Key Obj) )
+ Obj
+ (: dbf) ) )
(extra Obj Val Hook) )
@@ -575,7 +597,6 @@
(extra Obj Val Hook) )
-
# (+Sn +index) hook
(class +Sn)
@@ -638,26 +659,50 @@
(let? Val (get Obj A)
(with (meta Obj A)
(let Tree (tree (: var) (: cls) (get Obj (: hook)))
- (store Tree
- (conc
- (cons Val
- (mapcar
- '((S)
- (if (== S Var) Old (get Obj S)) )
- (: aux) ) )
- Obj )
- NIL
- (: dbf) )
- (store Tree
- (conc
- (cons Val
- (mapcar
- '((S)
- (if (== S Var) (get Obj Var) (get Obj S)) )
- (: aux) ) )
- Obj )
- Obj
- (: dbf) ) ) ) ) ) )
+ (let Key
+ (cons Val
+ (mapcar
+ '((S)
+ (if (== S Var) Old (get Obj S)) )
+ (: aux) ) )
+ (store Tree
+ (if (: ub)
+ (ubZval Key Obj)
+ (conc Key Obj) )
+ NIL
+ (: dbf) ) )
+ (let Key
+ (cons Val
+ (mapcar
+ '((S)
+ (if (== S Var) (get Obj Var) (get Obj S)) )
+ (: aux) ) )
+ (store Tree
+ (if (: ub)
+ (ubZval Key Obj)
+ (conc Key Obj) )
+ Obj
+ (: dbf) ) ) ) ) ) ) )
+
+
+# UB-Tree (+Aux prefix)
+(class +UB)
+
+(dm T (Var Lst)
+ (=: ub T)
+ (extra Var Lst) )
+
+(de ubZval (Lst X)
+ (let (Res 0 P 1)
+ (while (find gt0 Lst)
+ (map
+ '((L)
+ (let N (or (gt0 (car L)) 0)
+ (and (bit? 1 N) (setq Res (| Res P)))
+ (setq P (>> -1 P))
+ (set L (>> 1 N)) ) )
+ Lst ) )
+ (cons Res X) ) )
### Relation prefix classes ###
diff --git a/lib/pilog.l b/lib/pilog.l
@@ -1,4 +1,4 @@
-# 17jan11abu
+# 20may11abu
# (c) Software Lab. Alexander Burger
# *Rule
@@ -161,10 +161,16 @@
(cond
((not (; Rel aux)) (quit "No Aux"))
((atom (car Val))
+ (and (; Rel ub) (setq Val (ubZval Val)))
(init Tree Val (append Val T)) )
- ((>= (cdr Val) (car Val))
- (init Tree (car Val) (append (cdr Val) T)) )
- (T (init Tree (append (car Val) T) (cdr Val))) ) )
+ ((atom (cdar Val))
+ (init Tree
+ (ubZval (mapcar car Val))
+ (ubZval (mapcar cdr Val) T) ) )
+ (T
+ (if (>= (cdr Val) (car Val))
+ (init Tree (car Val) (append (cdr Val) T))
+ (init Tree (append (car Val) T) (cdr Val)) ) ) ) )
((isa '+Key Rel)
(init Tree (car Val) (cdr Val)) )
((>= (cdr Val) (car Val))
diff --git a/src/vers.h b/src/vers.h
@@ -1 +1 @@
-static byte Version[4] = {3,0,6,12};
+static byte Version[4] = {3,0,6,13};
diff --git a/src64/version.l b/src64/version.l
@@ -1,6 +1,6 @@
-# 16may11abu
+# 20may11abu
# (c) Software Lab. Alexander Burger
-(de *Version 3 0 6 12)
+(de *Version 3 0 6 13)
# vi:et:ts=3:sw=3
