db.l

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

# 10oct07abu
# (c) Software Lab. Alexander Burger

# *Dbs 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)
                     (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 ) ) )

# (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym
(de db (Var Cls . @)
   (with (or (get Cls Var) (meta Cls Var))
      (when (find '((B) (isa '+Index B)) (: bag))
         (setq This @) )
      (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)
                   (for (L (rest) (and L (== (pop 'A) (pop 'L))) (cdr L))
                     (conc Key (cons (car L))) ) )
               (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 (or (get Cls Var) (meta Cls Var))
      (when (find '((B) (isa '+Index B)) (: bag))
         (setq This @) )
      (step
         (init (tree (: var) (: cls) (and (: hook) (next)))
            (rest)
            (conc (rest) T) ) ) ) )


# (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst
(de collect (Var Cls . @)
   (with (or (get Cls Var) (meta Cls Var))
      (when (find '((B) (isa '+Index B)) (: bag))
         (setq This @) )
      (let
         (Tree (tree (: var) (: cls) (and (: hook) (next)))
            X1 (next)
            X2 (if (args) (next) (or X1 T)) )
         (make
            (if (isa '+Key This)
               (iter Tree
                  '((X) (and (isa Cls X) (link (pass get X))))
                  X1 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)
                        (not (memq (setq X (pass get X)) (made)))
                        (link X) ) )
                  X1 X2 T ) ) ) ) ) )


(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 ) )


### 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)
         (car (member 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) [num]
(class +String +Symbol)
# len

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

(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
      (mapcan
         '((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) ) )
               (cons 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) )


# (+Blob)
(class +Blob +Relation)

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

(dm put> (Obj Old New)
   (and New (call 'mkdir "-p" (dirname (blob Obj))))
   (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) 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) hook
(class +Ref +Index)
# aux

(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) )
      (when Old
         (store Tree (cons Old Aux) NIL (: dbf)) )
      (and New
         (not (get Obj T))
         (store Tree (cons New Aux) 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) )
   (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) )
   (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) cnt hook
(class +Idx +Ref)
# min

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

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