picolisp 3.1.5.2-2 / usr / share / picolisp / lib / db.l

# 12oct13abu
# (c) Software Lab. Alexander Burger

# *Dbs *Jnl *Blob upd

### DB Sizes ###
(de dbs Lst
   (default *Dbs (_dbs 1)) )

(de dbs+ (N . Lst)
   (unless (cdr (nth *Dbs N))
      (conc *Dbs (_dbs N)) ) )

(de _dbs (N)
   (mapcar
      '((L)
         (let Dbf (cons N (>> (- (car L)) 64))
            (for Cls (cdr L)
               (if (atom Cls)
                  (put Cls 'Dbf Dbf)
                  (for Var (cdr Cls)
                     (unless (get Cls 1 Var)
                        (quit "Bad relation" (cons Var (car Cls))) )
                     (put (get (car Cls) Var) 'dbf Dbf) ) ) ) )
         (inc 'N)
         (car L) )
      Lst ) )

(de db: Typ
   (or (meta Typ 'Dbf 1) 1) )


### Tree Access ###
(de tree (Var Cls Hook)
   (cons Var
      (if Hook
         (cons Cls Hook)
         Cls ) ) )

(de treeRel (Var Cls)
   (with (or (get Cls Var) (meta Cls Var))
      (or
         (find '((B) (isa '+index B)) (: bag))
         This ) ) )

# (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym
(de db (Var Cls . @)
   (with (treeRel Var Cls)
      (let (Tree (tree (: var) (: cls) (and (: hook) (next)))  Val (next))
         (if (isa '+Key This)
            (if (args)
               (and (fetch Tree Val) (pass _db @))
               (fetch Tree Val) )
            (let Key (cons (if (isa '+Fold This) (fold Val) Val))
               (let? A (: aux)
                  (while (and (args) (== (pop 'A) (arg 1)))
                     (next)
                     (queue 'Key (next)) )
                  (and (: ub) (setq Key (ubZval Key))) )
               (let Q (init Tree Key (append Key T))
                  (loop
                     (NIL (step Q T))
                     (T (pass _db @ Var Val) @) ) ) ) ) ) ) )

(de _db (Obj . @)
   (when (isa Cls Obj)
      (loop
         (NIL (next) Obj)
         (NIL (has> Obj (arg) (next))) ) ) )


# (aux 'var 'cls ['hook] 'any ..) -> sym
(de aux (Var Cls . @)
   (with (treeRel Var Cls)
      (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
(de collect (Var Cls . @)
   (with (treeRel Var Cls)
      (let
         (Tree (tree (: var) (: cls) (and (: hook) (next)))
            X1 (next)
            X2 (if (args) (next) (or X1 T)) )
         (make
            (cond
               ((isa '+Key This)
                  (iter Tree
                     '((X) (and (isa Cls X) (link (pass get X))))
                     X1 X2 ) )
               ((: ub)
                  (if X1
                     (ubIter Tree (inc (length (: aux)))
                        '((X) (and (isa Cls X) (link (pass get X))))
                        X1 X2 )
                     (iter Tree
                        '((X) (and (isa Cls X) (link (pass get X)))) ) ) )
               (T
                  (when (isa '+Fold This)
                     (setq X1 (fold X1)  X2 (or (=T X2) (fold X2))) )
                  (if (>= X2 X1)
                     (if (pair X1)
                        (setq X2 (append X2 T))
                        (setq X1 (cons X1)  X2 (cons X2 T)) )
                     (if (pair X1)
                        (setq X1 (append X1 T))
                        (setq X1 (cons X1 T)  X2 (cons X2)) ) )
                  (iter Tree
                     '((X)
                        (and (isa Cls X) (link (pass get X))) )
                     X1 X2
                     (or (isa '+Idx This) (isa '+IdxFold This)) ) ) ) ) ) ) )


(de genKey (Var Cls Hook Min Max)
   (if (lt0 Max)
      (let K (minKey (tree Var Cls Hook) Min Max)
         (if (lt0 K) (dec K) (or Max -1)) )
      (let K (maxKey (tree Var Cls Hook) Min Max)
         (if (gt0 K) (inc K) (or Min 1)) ) ) )

(de useKey (Var Cls Hook)
   (let (Tree (tree Var Cls Hook)  Max (* 2 (inc (count Tree)))  N)
      (while (fetch Tree (setq N (rand 1 Max))))
      N ) )

(de genStrKey (Str Var Cls Hook)
   (while (fetch (tree Var Cls Hook) Str)
      (setq Str (pack "# " Str)) )
   Str )


### Relations ###
(class +relation)
# cls var

(dm T (Var Lst)
   (=: cls *Class)
   (=: var Var) )

# Type check
(dm mis> (Val Obj))  #> lst
(dm ele> (Val))

# Value present?
(dm has> (Val X)  #> any | NIL
   (and (= Val X) X) )

# Set value
(dm put> (Obj Old New)
   New )

# Delete value
(dm del> (Obj Old Val)
   (and (<> Old Val) Val) )

# Maintain relations
(dm rel> (Obj Old New))

(dm lose> (Obj Val))

(dm keep> (Obj Val))

# Finalizer
(dm zap> (Obj Val))


(class +Any +relation)


# (+Bag) (cls ..) (..) (..)
(class +Bag +relation)
# bag

(dm T (Var Lst)
   (=: bag
      (mapcar
         '((L)
            (prog1
               (new (car L) Var (cdr L))
               (and (get @ 'hook) (=: hook T)) ) )
         Lst ) )
   (super Var) )

(dm mis> (Val Obj)
   (or
      (ifn (lst? Val) "Not a Bag")
      (pick
         '((This V)
            (mis> This V Obj
               (get
                  (if (sym? (: hook)) Obj Val)
                  (: hook) ) ) )
         (: bag)
         Val ) ) )

(dm ele> (Val)
   (and Val
      (or
         (atom Val)
         (find 'ele> (: bag) Val) ) ) )

(dm has> (Val X)
   (and Val
      (or
         (super Val X)
         (pick 'has> (: bag) (circ Val) X) ) ) )

(dm put> (Obj Old New)
   (trim
      (mapcar
         '((X O N) (put> X Obj O N))
         (: bag)
         Old
         New ) ) )

(dm rel> (Obj Old New)
   (when Old
      (mapc
         '((This O)
            (rel> This Obj O NIL
               (get
                  (if (sym? (: hook)) Obj Old)
                  (: hook) ) ) )
         (: bag)
         Old ) )
   (when New
      (mapc
         '((This N)
            (rel> This Obj NIL N
               (get
                  (if (sym? (: hook)) Obj New)
                  (: hook) ) ) )
         (: bag)
         New ) ) )

(dm lose> (Obj Val)
   (mapc
      '((This V)
         (lose> This Obj V
            (get
               (if (sym? (: hook)) Obj Val)
               (: hook) ) ) )
      (: bag)
      Val ) )

(dm keep> (Obj Val)
   (mapc
      '((This V)
         (keep> This Obj V
            (get
               (if (sym? (: hook)) Obj Val)
               (: hook) ) ) )
      (: bag)
      Val ) )


(class +Bool +relation)

(dm mis> (Val Obj)
   (and Val (nT Val) ,"Boolean input expected") )


# (+Number) [num]
(class +Number +relation)
# scl

(dm T (Var Lst)
   (=: scl (car Lst))
   (super Var (cdr Lst)) )

(dm mis> (Val Obj)
   (and Val (not (num? Val)) ,"Numeric input expected") )


# (+Date)
(class +Date +Number)

(dm T (Var Lst)
   (super Var (cons NIL Lst)) )


# (+Time)
(class +Time +Number)

(dm T (Var Lst)
   (super Var (cons NIL Lst)) )


# (+Symbol)
(class +Symbol +relation)

(dm mis> (Val Obj)
   (unless (sym? Val)
      ,"Symbolic type expected" ) )


# (+String)
(class +String +Symbol)

(dm mis> (Val Obj)
   (and Val (not (str? Val)) ,"String type expected") )


# (+Link) typ
(class +Link +relation)
# type

(dm T (Var Lst)
   (unless (=: type (car Lst))
      (quit "No Link" Var) )
   (super Var (cdr Lst)) )

(de canQuery (Val)
   (and
      (pair Val)
      (pair (car Val))
      (not
         (find
            '((L)
               (not
                  (find
                     '((Cls)
                        (get
                           Cls
                           ((if (lst? (car L)) cadr car) L) ) )
                     (: type) ) ) )
            Val ) ) ) )

(dm mis> (Val Obj)
   (and
      Val
      (nor
         (isa (: type) Val)
         (canQuery Val) )
      ,"Type error" ) )


# (+Joint) var typ
(class +Joint +Link)
# slot

(dm T (Var Lst)
   (=: slot (car Lst))
   (super Var (cdr Lst)) )

(dm mis> (Val Obj)
   (and
      Val
      (nor
         (canQuery Val)
         (and
            (isa (: type) Val)
            (with (meta Val (: slot))
               (or
                  (isa '+Joint This)
                  (find
                     '((B) (isa '+Joint B))
                     (: bag) ) ) ) ) )
      ,"Type error" ) )

(dm rel> (Obj Old New)
   (and Old (del> Old (: slot) Obj))
   (and New
      (not (get Obj T))
      (put> New (: slot) Obj) ) )

(dm lose> (Obj Val)
   (when Val
      (put Val (: slot)
         (del> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) )

(dm keep> (Obj Val)
   (when Val
      (put Val (: slot)
         (put> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) )


# +Link or +Joint prefix
(class +Hook)

(dm rel> (Obj Old New Hook)
   (let L
      (extract
         '((X)
            (and (atom X) (setq X (cons T X)))
            (and
               (or
                  (== (: var) (meta Obj (cdr X) 'hook))
                  (find
                     '((B) (== (: var) (get B 'hook)))
                     (meta Obj (cdr X) 'bag) ) )
               X ) )
         (getl Obj) )
      (for X L
         (rel> (meta Obj (cdr X)) Obj (car X) NIL (or Old *DB))
         (rel> (meta Obj (cdr X)) Obj NIL (car X) (or New *DB)) ) )
   (extra Obj Old New Hook) )


# +Index prefix
(class +Hook2)

(dm rel> (Obj Old New Hook)
   (extra Obj Old New *DB)
   (when (or (and Hook (n== Hook *DB)) (get Obj (: hook)))
      (extra Obj Old New Hook) ) )

(dm lose> (Obj Val Hook)
   (extra Obj Val *DB)
   (when (or (and Hook (n== Hook *DB)) (get Obj (: hook)))
      (extra Obj Val Hook) ) )

(dm keep> (Obj Val Hook)
   (extra Obj Val *DB)
   (when (or (and Hook (n== Hook *DB)) (get Obj (: hook)))
      (extra Obj Val Hook) ) )


# (+Blob)
(class +Blob +relation)

(de blob (Obj Var)
   (pack *Blob (glue "/" (chop Obj)) "." Var) )

(dm put> (Obj Old New)
   (and
      New
      (dirname (blob Obj))
      (call 'mkdir "-p" @) )
   (if (flg? New)
      New
      (in New (out (blob Obj (: var)) (echo)))
      T ) )

(dm zap> (Obj Val)
   (and Val (call 'rm "-f" (blob Obj (: var)))) )


### Index classes ###
(class +index)
# hook dbf

(dm T (Var Lst)
   (=: hook (car Lst))
   (extra Var (cdr Lst)) )


# (+Key +relation) [hook]
(class +Key +index)

(dm mis> (Val Obj Hook)
   (or
      (extra Val Obj Hook)
      (and
         Val
         (not (has> Obj (: var) Val))
         (fetch
            (tree (: var) (: cls) (or Hook (get Obj (: hook))))
            Val )
         ,"Not unique" ) ) )

(dm rel> (Obj Old New Hook)
   (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      (and Old
         (= Obj (fetch Tree Old))
         (store Tree Old NIL (: dbf)) )
      (and New
         (not (get Obj T))
         (not (fetch Tree New))
         (store Tree New Obj (: dbf)) ) )
   (extra Obj Old New Hook) )

(dm lose> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      Val NIL (: dbf) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      Val Obj (: dbf) )
   (extra Obj Val Hook) )


# (+Ref +relation) [hook]
(class +Ref +index)
# aux ub

(dm rel> (Obj Old New Hook)
   (let
      (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
         Aux (mapcar '((S) (get Obj S)) (: aux)) )
      (when Old
         (let Key (cons Old Aux)
            (store Tree
               (if (: ub)
                  (ubZval Key Obj)
                  (append Key Obj) )
               NIL
               (: dbf) ) ) )
      (and New
         (not (get Obj T))
         (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)
   (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)
   (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) )


# Backing index prefix
(class +Ref2)

(dm T (Var Lst)
   (unless (meta *Class Var)
      (quit "No Ref2" Var) )
   (extra Var Lst) )

(dm rel> (Obj Old New Hook)
   (with (meta (: cls) (: var))
      (let Tree (tree (: var) (: cls))
         (when Old
            (store Tree (cons Old Obj) NIL (: dbf)) )
         (and New
            (not (get Obj T))
            (store Tree (cons New Obj) Obj (: dbf)) ) ) )
   (extra Obj Old New Hook) )

(dm lose> (Obj Val Hook)
   (with (meta (: cls) (: var))
      (store (tree (: var) (: cls)) (cons Val Obj) NIL (: dbf)) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (with (meta (: cls) (: var))
      (store (tree (: var) (: cls)) (cons Val Obj) Obj (: dbf)) )
   (extra Obj Val Hook) )


# (+Idx +relation) [cnt [hook]]
(class +Idx +Ref)
# min

(dm T (Var Lst)
   (=: min (or (car Lst) 3))
   (super Var (cdr Lst)) )

(de idxRel (Obj Old Olds New News Hook)
   (let
      (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
         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 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 News
            (while (nth S (: min))
               (store Tree (cons (pack S) Aux2) Obj (: dbf))
               (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)
   (idxRel Obj
      Val (split (cdr (chop Val)) " " "^J")
      NIL NIL
      Hook )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (idxRel Obj
      NIL NIL
      Val (split (cdr (chop Val)) " " "^J")
      Hook )
   (extra Obj Val Hook) )


# (+Sn +index) [hook]
(class +Sn)

(dm rel> (Obj Old New Hook)
   (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      (when Old
         (store Tree (cons (ext:Snx Old) Obj T) NIL (: dbf)) )
      (and New
         (not (get Obj T))
         (store Tree (cons (ext:Snx New) Obj T) Obj (: dbf)) ) )
   (extra Obj Old New Hook) )

(dm lose> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      (cons (ext:Snx Val) Obj T)
      NIL (: dbf) )
   (extra Obj Val Hook) )

(dm keep> (Obj Val Hook)
   (store
      (tree (: var) (: cls) (or Hook (get Obj (: hook))))
      (cons (ext:Snx Val) Obj T)
      Obj (: dbf) )
   (extra Obj Val Hook) )


# (+Fold +index) [hook]
(class +Fold)

(dm has> (Val X)
   (extra Val
      (if (= Val (fold Val)) (fold X) X) ) )

(dm rel> (Obj Old New Hook)
   (extra Obj (fold Old) (fold New) Hook) )

(dm lose> (Obj Val Hook)
   (extra Obj (fold Val) Hook) )

(dm keep> (Obj Val Hook)
   (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)

(dm T (Var Lst)
   (=: aux (car Lst))
   (with *Class
      (for A (car Lst)
         (if (asoq A (: Aux))
            (queue '@ Var)
            (queue (:: Aux) (list A Var)) ) ) )
   (extra Var (cdr Lst)) )

(de relAux (Obj Var Old Lst)
   (let New (get Obj Var)
      (put Obj Var Old)
      (for A Lst
         (rel> (meta Obj A) Obj (get Obj A) NIL) )
      (put Obj Var New)
      (for A Lst
         (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) )


# 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 n0 Lst)
         (map
            '((L)
               (and (bit? 1 (car L)) (setq Res (| Res P)))
               (setq P (>> -1 P))
               (set L (>> 1 (car L))) )
            Lst ) )
      (cons Res X) ) )

(dm has> (Val X)
   (and Val
      (or
         (extra Val X)
         (extra
            (let (N (inc (length (: aux)))  M 1  V 0)
               (until (=0 Val)
                  (and (bit? 1 Val) (inc 'V M))
                  (setq M (>> -1 M)  Val (>> N Val)) )
               V )
            X ) ) ) )


### Relation prefix classes ###
(class +Dep)
# dep

(dm T (Var Lst)
   (=: dep (car Lst))
   (extra Var (cdr Lst)) )

(dm rel> (Obj Old New Hook)
   (unless New
      (for Var (: dep)
         (let? V (get Obj Var)
            (rel> (meta Obj Var) Obj V
               (put> (meta Obj Var) Obj V NIL) ) ) ) )
   (extra Obj Old New Hook) )


(class +List)

(dm mis> (Val Obj)
   (or
      (ifn (lst? Val) "Not a List")
      (pick '((V) (extra V Obj)) Val) ) )

(dm ele> (Val)
   (and Val (or (atom Val) (find extra Val))) )

(dm has> (Val X)
   (and Val
      (or
         (extra Val X)
         (find '((X) (extra Val X)) X) ) ) )

(dm put> (Obj Old New)
   (if (ele> This New)
      (cons (extra Obj Old New) Old)
      (mapcar
         '((N O) (extra Obj O N))
         New
         Old ) ) )

(dm del> (Obj Old Val)
   (and
      (<> Old Val)
      (delete Val Old) ) )

(dm rel> (Obj Old New Hook)
   (if (or (ele> This Old) (ele> This New))
      (extra Obj Old New Hook)
      (for O (diff Old New)
         (extra Obj O NIL Hook) )
      (for N New
         (extra Obj NIL N Hook) ) ) )

(dm lose> (Obj Val Hook)
   (if (ele> This Val)
      (extra Obj Val Hook)
      (for V Val
         (extra Obj V Hook) ) ) )

(dm keep> (Obj Val Hook)
   (if (ele> This Val)
      (extra Obj Val Hook)
      (for V Val
         (extra Obj V Hook) ) ) )


(class +Need)

(dm mis> (Val Obj)
   (ifn Val
      ,"Input required"
      (extra Val Obj) ) )


(class +Mis)
# mis

(dm T (Var Lst)
   (=: mis (car Lst))
   (extra Var (cdr Lst)) )

(dm mis> (Val Obj)
   (or ((: mis) Val Obj) (extra Val Obj)) )


(class +Alt)

(dm T (Var Lst)
   (extra Var (cdr Lst))
   (=: cls (car Lst)) )


(class +Swap)
# dbf

(dm has> (Val X)
   (or (extra Val X) (extra Val (val X))) )

(dm put> (Obj Old New)
   (prog1
      (or
         (ext? (get Obj (: var)))
         (new (or (: dbf 1) 1)) )
      (set @ (extra Obj (val Old) New)) ) )

(dm del> (Obj Old Val)
   (ifn (ext? (get Obj (: var)))
      (extra Obj Old Val)
      (set @ (extra Obj (val Old) Val))
      @ ) )


### Entities ###
(class +Entity)

(var Dbf)
(var Aux)

(de dbSync (Obj)
   (let *Run NIL
      (while (lock (or Obj *DB))
         (wait 40) )
      (sync) ) )

(de new! ("Typ" . @)
   (prog2
      (dbSync)
      (pass new (or (meta "Typ" 'Dbf 1) 1) "Typ")
      (commit 'upd) ) )

(de set! (Obj Val)
   (unless (= Val (val Obj))
      (dbSync)
      (set Obj Val)
      (commit 'upd) )
   Val )

(de put! (Obj Var Val)
   (unless (= Val (get Obj Var))
      (dbSync)
      (put Obj Var Val)
      (commit 'upd) )
   Val )

(de inc! (Obj Var Val)
   (when (num? (get Obj Var))
      (dbSync)
      (prog1 (inc (prop Obj Var) (or Val 1))
         (commit 'upd) ) ) )

(de blob! (Obj Var File)
   (put!> Obj Var File)
   (blob+ Obj Var)
   File )

(de blob+ (Obj Var)
   (when *Jnl
      (chdir *Blob
         (call 'ln "-sf"
            (pack (glue "/" (chop Obj)) "." Var)
            (pack (name Obj) "." Var) ) ) ) )

(dm T @
   (while (args)
      (cond
         ((=T (next)) (put This T T))
         ((atom (arg)) (put> This (arg) (next)))
         (T (put> This (car (arg)) (eval (cdr (arg))))) ) )
   (upd> This (val This)) )

(dm zap> ()
   (for X (getl This)
      (let V (or (atom X) (pop 'X))
         (and (meta This X) (zap> @ This V)) ) ) )

(dm url> (Tab))

(dm upd> (X Old))

(dm has> (Var Val)
   (or
      (nor Val (get This Var))
      (has> (meta This Var) Val (get This Var)) ) )

(dm put> (Var Val)
   (unless (has> This Var Val)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (put> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) )
   Val )

(dm put!> (Var Val)
   (unless (has> This Var Val)
      (dbSync)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (put> (meta This Var) This Old Val)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd) ) )
   Val )

(dm del> (Var Val)
   (when (and Val (has> (meta This Var) Val (get This Var)))
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (del> (meta This Var) This Old @)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) ) )

(dm del!> (Var Val)
   (when (and Val (has> (meta This Var) Val (get This Var)))
      (dbSync)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (put This Var (del> (meta This Var) This Old @)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd) ) ) )

(dm inc> (Var Val)
   (let P (prop This Var)
      (when (num? (car P))
         (let Old @
            (rel> (meta This Var) This Old
               (inc P (or Val 1)) )
            (when (asoq Var (meta This 'Aux))
               (relAux This Var Old (cdr @)) )
            (upd> This Var Old) )
         (car P) ) ) )

(dm inc!> (Var Val)
   (when (num? (get This Var))
      (dbSync)
      (let (P (prop This Var)  Old (car P))
         (rel> (meta This Var) This Old
            (inc P (or Val 1)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd)
         (car P) ) ) )

(dm dec> (Var Val)
   (let P (prop This Var)
      (when (num? (car P))
         (let Old @
            (rel> (meta This Var) This Old
               (dec P (or Val 1)) )
            (when (asoq Var (meta This 'Aux))
               (relAux This Var Old (cdr @)) )
            (upd> This Var Old) )
         (car P) ) ) )

(dm dec!> (Var Val)
   (when (num? (get This Var))
      (dbSync)
      (let (P (prop This Var)  Old (car P))
         (rel> (meta This Var) This Old
            (dec P (or Val 1)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old)
         (commit 'upd)
         (car P) ) ) )

(dm mis> (Var Val)
   (mis> (meta This Var) Val This) )

(dm lose1> (Var)
   (when (meta This Var)
      (lose> @ This (get This Var)) ) )

(dm lose> (Lst)
   (unless (: T)
      (for X (getl This)
         (let V (or (atom X) (pop 'X))
            (and
               (not (memq X Lst))
               (meta This X)
               (lose> @ This V) ) ) )
      (=: T T)
      (upd> This) ) )

(dm lose!> ()
   (dbSync)
   (lose> This)
   (commit 'upd) )

(de lose "Prg"
   (let "Flg" (: T)
      (=: T T)
      (run "Prg")
      (=: T "Flg") ) )

(dm keep1> (Var)
   (when (meta This Var)
      (keep> @ This (get This Var)) ) )

(dm keep> (Lst)
   (when (: T)
      (=: T)
      (for X (getl This)
         (let V (or (atom X) (pop 'X))
            (and
               (not (memq X Lst))
               (meta This X)
               (keep> @ This V) ) ) )
      (upd> This T) ) )

(dm keep?> (Lst)
   (extract
      '((X)
         (with (and (pair X) (meta This (cdr X)))
            (and
               (isa '+Key This)
               (fetch (tree (: var) (: cls) (get (up This) (: hook))) (car X))
               (cons (car X) ,"Not unique") ) ) )
      (getl This) ) )

(dm keep!> ()
   (dbSync)
   (keep> This)
   (commit 'upd) )

(de keep "Prg"
   (let "Flg" (: T)
      (=: T)
      (run "Prg")
      (=: T "Flg") ) )

(dm set> (Val)
   (unless (= Val (val This))
      (let Lst (make (maps '((X) (link (fin X))) This))
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (rel> Rel This V (put> Rel This V NIL)) ) ) ) )
         (xchg This 'Val)
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (rel> Rel This NIL
                     (put> Rel This NIL (get This Var)) ) ) ) ) )
      (upd> This (val This) Val) )
   (val This) )

(dm set!> (Val)
   (unless (= Val (val This))
      (dbSync)
      (let Lst (make (maps '((X) (link (fin X))) This))
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (let V (get This Var)
                     (rel> Rel This V (put> Rel This V NIL)) ) ) ) )
         (xchg This 'Val)
         (for Var Lst
            (let? Rel (meta This Var)
               (unless (== Rel (meta Val Var))
                  (rel> Rel This NIL
                     (put> Rel This NIL (get This Var)) ) ) ) ) )
      (upd> This (val This) Val)
      (commit 'upd) )
   (val This) )

(dm clone> ()
   (let Obj (new (or (var: Dbf 1) 1) (val This))
      (for X
         (by
            '((X)
               (nand
                  (pair X)
                  (isa '+Hook (meta This (cdr X))) ) )
            sort
            (getl This ) )
         (if (atom X)
            (ifn (meta This X)
               (put Obj X T)
               (let Rel @
                  (put> Obj X T)
                  (when (isa '+Blob Rel)
                     (in (blob This X)
                        (out (blob Obj X) (echo)) ) ) ) )
            (ifn (meta This (cdr X))
               (put Obj (cdr X) (car X))
               (let Rel @
                  (cond
                     ((find '((B) (isa '+Key B)) (get Rel 'bag))
                        (let (K @  H (get K 'hook))
                           (put> Obj (cdr X)
                              (mapcar
                                 '((Lst)
                                    (mapcar
                                       '((B Val)
                                          (if (== B K)
                                             (cloneKey B (cdr X) Val
                                                (get (if (sym? H) This Lst) H) )
                                             Val ) )
                                       (get Rel 'bag)
                                       Lst ) )
                                 (car X) ) ) ) )
                     ((isa '+Key Rel)
                        (put> Obj (cdr X)
                           (cloneKey Rel (cdr X) (car X)
                              (get This (get Rel 'hook)) ) ) )
                     ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X))))
                        (put> Obj (cdr X) (car X)) ) ) ) ) ) )
      Obj ) )

(de cloneKey (Rel Var Val Hook)
   (cond
      ((isa '+Number Rel)
         (genKey Var (get Rel 'cls) Hook) )
      ((isa '+String Rel)
         (genStrKey (pack "# " Val) Var (get Rel 'cls) Hook) ) ) )

(dm clone!> ()
   (prog2
      (dbSync)
      (clone> This)
      (commit 'upd) ) )

# Default syncronization function
(de upd Lst
   (wipe Lst) )


### Utilities ###
# Define object variables as relations
(de rel Lst
   (def *Class
      (car Lst)
      (new (cadr Lst) (car Lst) (cddr Lst)) ) )

# Find or create object
(de request (Typ Var . @)
   (let Dbf (or (meta Typ 'Dbf 1) 1)
      (ifn Var
         (new Dbf Typ)
         (with (meta Typ Var)
            (or
               (pass db Var (: cls))
               (if (: hook)
                  (pass new Dbf Typ (: hook) (next) Var)
                  (pass new Dbf Typ Var) ) ) ) ) ) )

# Create or update object
(de obj Lst
   (let Obj (apply request (pop 'Lst))
      (while Lst
         (put> Obj (pop 'Lst) (pop 'Lst)) )
      Obj ) )

# vi:et:ts=3:sw=3