db.l

A very small LISP implementation with several packages and demo programs.

      (for S (split (cdr (chop Val)) " " "^J")
         (while (nth S (: min))
            (store Tree (list (pack S) Obj) Obj (: dbf))
            (pop 'S) ) ) )
   (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) )


# (+Aux) lst
(class +Aux)

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

(de relAux (Obj Var Old Lst)
   (for A Lst
      (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) ) ) ) ) ) )


### 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)
         (del> Obj Var (get Obj Var)) ) )
   (extra Obj Old New Hook) )

(dm lose> (Obj Val Hook)
   (for Var (: dep)
      (del> Obj Var (get Obj Var)) )
   (extra Obj Val 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)) )


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

(var dbf)
(var aux)

(de dbSync ()
   (let *Run NIL
      (while (lock *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)
      (touch Obj)
      (inc (prop Obj Var) (or Val 1))
      (commit 'upd) ) )

(de blob! (Obj Var File Flg)
   (put!> Obj Var File)
   (when Flg
      (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 dlg> ())
(dm url> ())

(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)
   (when (num? (get This Var))
      (touch This)
      (let Old (get This Var)
         (rel> (meta This Var) This Old
            (inc (prop This Var) (or Val 1)) )
         (when (asoq Var (meta This 'aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) ) )

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

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

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

(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!> ()
   (dbSync)
   (keep> This)
   (commit 'upd) )

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

(dm set> (Val)
   (unless (= Val (val This))
      (let
         (L
            (mapcan
               '((X)
                  (pop 'X)
                  (unless (== (meta Val X) (meta (val This) X))
                     (cons X) ) )
               (getl This) )
            V (mapcar
               '((X)
                  (prog1
                     (get This X)
                     (if (meta This X)
                        (put> This X)
                        (put This X) ) ) )
               L ) )
         (xchg This 'Val)
         (mapc
            '((X V)
               (if (meta This X)
                  (put> This X V)
                  (put This X V) ) )
            L V ) )
      (upd> This (val This) Val) )
   (val This) )

(dm set!> (Val)
   (unless (= Val (val This))
      (dbSync)
      (let
         (L
            (mapcan
               '((X)
                  (pop 'X)
                  (unless (== (meta Val X) (meta (val This) X))
                     (cons X) ) )
               (getl This) )
            V (mapcar
               '((X)
                  (prog1
                     (get This X)
                     (if (meta This X)
                        (put> This X)
                        (put This X) ) ) )
               L ) )
         (xchg This 'Val)
         (mapc
            '((X V)
               (if (meta This X)
                  (put> This X V)
                  (put This X V) ) )
            L V ) )
      (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)
         (let S (pack "# " Val)
            (while (fetch (tree Var (get Rel 'cls) Hook) S)
               (setq S (pack "# " S)) )
            S ) ) ) )

(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 . @)
   (with (meta Typ Var)
      (or
         (pass db Var (: cls))
         (if (: hook)
            (pass new
               (or (meta Typ 'dbf 1) 1)
               Typ
               (: hook)
               (next)
               Var )
            (pass new
               (or (meta Typ 'dbf 1) 1)
               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