form.l

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

(dm txt> (Val)
   (telStr Val) )

(dm set> (Val Dn)
   (super (telStr Val) Dn) )

(dm val> ()
   (expTel (super)) )

(dm chk> ()
   (and
      (str> This)
      (not (val> This))
      ,"Bad phone number format" ) )


(class +SexField +Map +TextField)

(dm T (Lbl)
   (super
      '((,"male" . T) (,"female" . 0))
      '(NIL ,"male" ,"female")
      Lbl ) )


(class +JsField +gui)
# js str

(dm T (Nm)
   (super)
   (=: js Nm) )

(dm show> ("Var"))

(dm js> ()
   (pack (ht:Fmt (: str) (: js))) )

(dm set> (Val Dn)
   (=: str Val) )


### GUI charts ###
(class +Chart)
# home gui rows cols ofs lock put get data clip

# (cols [put [get]])
(dm T (N Put Get)
   (setq "*Chart" This)
   (put (=: home "*App") 'chart
      (conc (get "*App" 'chart) (cons This)) )
   (=: rows 1)
   (when N
      (=: gui (list (need (=: cols N)))) )
   (=: ofs 1)
   (=: lock T)
   (=: put (or Put prog1))
   (=: get (or Get prog1)) )

(dm put> ()
   (let I (: ofs)
      (mapc
         '((G D)
            (unless (memq NIL G)
               (mapc 'set> G ((: put) D I) '(T .)) )
            (inc 'I) )
         (: gui)
         (nth (: data) I) ) ) )

(dm get> ()
   (unless (: lock)
      (map
         '((G D)
            (set D
               (trim
                  ((: get)
                     (mapcar 'val> (car G))
                     (car D)
                     (car G) ) ) ) )
         (: gui)
         (nth
            (=: data
               (need
                  (- 1 (: ofs) (: rows))
                  (: data) ) )
            (: ofs) ) )
      (=: data (trim (: data))) ) )

(dm txt> ()
   (for (I . L) (: data)
      (map
         '((G D)
            (prin (txt> (car G) (car D)))
            (if (cdr G) (prin "^I") (prinl)) )
         (: gui 1)
         ((: put) L I) ) ) )

(dm set> (Lst)
   (=: ofs
      (max 1
         (min (: ofs) (length (=: data (copy Lst)))) ) )
   (put> This)
   Lst )

(dm log> (Lst)
   (=: ofs (max (: ofs) (- (length (: data)) (: rows) -2)))
   (set> This (conc (: data) (cons Lst))) )

(dm clr> ()
   (set> This) )

(dm val> ()
   (get> This)
   (: data) )

(dm init> ()
   (upd> This) )

(dm upd> ())

(dm chk> ())

(dm cut> ()
   (get> This)
   (=: clip (get (: data) (: ofs)))
   (set> This (remove (: ofs) (: data))) )

(dm paste> (Flg)
   (get> This)
   (set> This (insert (: ofs) (: data) (unless Flg (: clip)))) )


(class +Chart1 +Chart)

# (cols)
(dm T (N)
   (super N cons car) )


### DB GUI ###
(de newUrl @
   (prog1
      (pass new!)
      (lock (setq *Lock @))
      (apply url (url> @)) ) )


# (choDlg Dst Ttl Rel [Hook] [((+XyzField) ..) Exe [Rel2 [Hook2]]])
(de choDlg (Dst Ttl Rel . @)
   (let
      (Hook (and (meta (cdr Rel) (car Rel) 'hook) (next))
         Fld (or (next) '((+TextField) 40))
         Gui
         (if (next)
            (list '(+ObjView +TextField) @)
            (list (list '+ObjView (last (car Fld))) (list ': (car Rel))) ) )
      (nond
         ((next)
            (setq Ttl (list Ttl (car Rel) (cadr Rel) Hook)) )
         ((=T (arg))
            (setq Ttl (list Ttl (car (arg)) (cadr (arg)) (next))) ) )
      (diaform '(Dst Ttl Rel Hook Fld Gui)
         (apply gui
            (cons
               (cons '+Var (car Fld))
               (cdr (or (assoc Rel "*Cho") (push '"*Cho" (list Rel NIL))))
               (cdr Fld) ) )
         (searchButton '(init> (: home query)))
         (gui 'query '(+QueryChart) 6
            '(goal
               (list
                  (list 'db (car Rel) (last Rel) Hook (val> (: home gui 1)) '@@) ) )
            2 '((Obj) (list Obj Obj)) car )
         (<table> 'chart (if (atom Ttl) Ttl (apply choTtl Ttl)) '((btn) NIL)
            (do 6
               (<row> (alternating)
                  (gui 1 '(+DstButton) Dst)
                  (apply gui Gui 2) ) ) )
         (<spread>
            (scroll 6)
            (when (=T Dst)
               (gui '(+Button) ',"New"
                  '(if (meta (cdr Rel) (car Rel) 'hook)
                     (newUrl (cdr Rel) @ Hook)
                     (newUrl (cdr Rel)) ) ) )
            (cancelButton) ) ) ) )

(de choTtl (Ttl Var Cls Hook)
   (with (or (get Cls Var) (meta Cls Var))
      (pack (count (tree (: var) (: cls) Hook)) " " Ttl) ) )


# Able object
(class +AO +Able)
# ao

(dm T (Exe . @)
   (=: ao Exe)
   (pass super
      '(and
         (: home obj)
         (not (: home obj T))
         (eval (: ao)) ) ) )


# Lock/Edit button prefix
(class +Edit +Rid)
# save

(dm T (Exe)
   (=: save Exe)
   (super
      '(if (: home able) ,"Save" ,"Edit")
      '(if (: home able)
         (when (able)
            (eval (: save))
            (unless "*Err"
               (rollback)
               (off *Lock) ) )
         (tryLock (: home obj)) ) ) )

(de tryLock (Obj)
   (if (lock Obj)
      (err (editing @ (cdr (lup *Users @))))
      (sync)
      (setq *Lock Obj) ) )

(de editing (Pid Nm)
   (text ,"Currently edited by '@2' (@1)" Pid Nm) )

(de editButton (Able Exe)
   (<style> (and (: able) 'edit)
      (gui '(+AO +Edit +Button) Able Exe) ) )

(de searchButton (Exe)
   (gui '(+JS +Button) ,"Search" Exe) )

(de resetButton (Lst)
   (gui '(+ClrButton) ,"Reset" Lst) )

# Clone object in form
(de cloneButton (Able)
   (gui '(+Rid +Able +Button) (or Able T) ,"New/Copy"
      '(apply url (url> (clone!> (: home obj)))) ) )

# Delete object in form
(de delButton (Able @Txt)
   (gui '(+Rid +Able +Button) Able '(if (: home obj T) ,"Restore" ,"Delete")
      (fill
         '(if (: home obj T)
            (alert NIL
               (ht:Prin (text ,"Restore @1?" @Txt))
               (----)
               (yesButton '(keep!> (: home top 1 obj)))
               (noButton) )
            (alert NIL
               (ht:Prin (text ,"Delete @1?" @Txt))
               (----)
               (yesButton '(lose!> (: home top 1 obj)))
               (noButton) ) ) ) ) )


# Relations
(class +/R)
# erVar erObj

(dm T (Lst . @)
   (=: erVar (car Lst))
   (=: erObj (cdr Lst))
   (pass extra)
   (when (: able)
      (=: able '(and (eval (: erObj)) (not (get @ T)))) ) )

(dm upd> ()
   (set> This (get (eval (: erObj)) (: erVar))) )


# Symbol/Relation
(class +S/R +/R)

(dm set> (Val Dn)
   (when (eval (: erObj))
      (put! @ (: erVar) Val) )
   (extra Val Dn) )


# Entity/Relation
(class +E/R +/R)

(dm set> (Val Dn)
   (when (eval (: erObj))
      (put!> @ (: erVar) Val) )
   (extra Val Dn) )

(dm chk> ()
   (or
      (extra)
      (and
         (eval (: erObj))
         (mis> @ (: erVar) (val> This)) ) ) )


(class +Blob/R +/R)

(dm set> (Val Dn)
   (extra
      (and
         (eval (: erObj))
         (put!> @ (: erVar) (bool Val))
         (allow (blob (eval (: erObj)) (: erVar))) )
      Dn ) )


(class +BlobField +/R +TextField)
# org

(dm set> (Val Dn)
   (and
      (eval (: erObj))
      (put!> @ (: erVar) (bool Val))
      (<> Val (: org))
      (out (allow (blob (eval (: erObj)) (: erVar)))
         (prinl (=: org Val)) ) )
   (super Val Dn) )

(dm upd> ()
   (set> This
      (and
         (eval (: erObj))
         (get @ (: erVar))
         (in (allow (blob (eval (: erObj)) (: erVar)))
            (=: org (till NIL T)) ) ) ) )


(class +ClassField +Map +TextField)
# erObj

(dm T (Exe Lst)
   (=: erObj Exe)
   (super Lst (mapcar car Lst)) )

(dm upd> ()
   (set> This (val (eval (: erObj)))) )

(dm set> (Val Dn)
   (when (eval (: erObj))
      (set!> @ Val) )
   (super Val Dn) )


(class +obj)
# msg obj

# ([T|msg] ..)
(dm T ()
   (ifn (atom (next))
      (=: msg 'url>)
      (=: msg (arg))
      (next) ) )

(dm js> ()
   (if (=T (: msg))
      (extra)
      (if2 (or (: dx) (: lst)) (try (: msg) (: obj))
         (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/go.png"))) '& (ht:Fmt (sesId (mkUrl @))))
         (pack (extra) "&*" (ht:Fmt (sesId `(path "@img/no.png"))) '&)
         (pack (ht:Fmt (nonblank (str> This))) "&+" (ht:Fmt (sesId (mkUrl @))))
         (extra) ) ) )

(dm show> ("Var")
   (cond
      ((=T (: msg)) (extra "Var"))
      ((or (: dx) (: lst))
         (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>")
         (extra "Var")
         (prin "</td><td>")
         (if (try (: msg) (: obj))
            (<img> `(path "@img/go.png") "obj" (mkUrl @))
            (<img> `(path "@img/no.png")) )
         (prinl "</td></table>") )
      ((try (: msg) (: obj))
         (showFld (<href> (nonblank (str> This)) (mkUrl @))) )
      (T (extra "Var")) ) )


(class +Obj +obj)
# objVar objTyp objHook

# ([T|msg] (var . typ) [hook] [T] ..)
(dm T @
   (super)
   (=: objVar (car (arg)))
   (=: objTyp (cdr (arg)))
   (when (meta (: objTyp) (: objVar) 'hook)
      (=: objHook (next)) )
   (pass extra
      (if (nT (next))
         (arg)
         (cons NIL
            (if (: objHook)
               (collect (: objVar) (last (: objTyp)) (eval @) NIL T (: objVar))
               (collect (: objVar) (last (: objTyp)) NIL T (: objVar)) ) ) ) ) )

(dm txt> (Obj)
   (if (ext? Obj)
      (get Obj (: objVar))
      Obj ) )

(dm set> (Obj Dn)
   (extra
      (if (ext? (=: obj Obj))
         (get Obj (: objVar))
         Obj )
      Dn ) )

(dm val> ()
   (let V (extra)
      (cond
         ((and (: obj) (not (ext? @))) V)
         ((= V (get (: obj) (: objVar)))
            (: obj) )
         ((: objTyp)
            (=: obj
               (if (: objHook)
                  (db (: objVar) (last (: objTyp)) (eval @) V)
                  (db (: objVar) (last (: objTyp)) V) ) ) )
         (T V) ) ) )

(dm chk> ()
   (or
      (extra)
      (let? S (str> This)
         (and
            (: objTyp)
            (not (val> This))
            (<> "-" S)
            ,"Data not found" ) ) ) )


(class +ObjView +obj)
# disp obj

# ([T|msg] exe ..)
(dm T @
   (super)
   (=: disp (arg))
   (pass extra)
   (=: able) )

(dm txt> (Obj)
   (let Exe (: disp)
      (if (ext? Obj)
         (with Obj (eval Exe))
         Obj ) ) )

(dm set> (Obj Dn)
   (let Exe (: disp)
      (extra
         (if (ext? (=: obj Obj))
            (with Obj (eval Exe))
            Obj )
         Dn ) ) )

(dm val> ()
   (: obj) )


# DB query chart
(class +QueryChart +Chart)
# iniR iniq query

# (iniR iniQ cols [put [get]])
(dm T (R Q . @)
   (=: iniR R)
   (=: iniQ Q)
   (pass super) )

(dm init> ()
   (query> This (eval (: iniQ))) )

(dm put> ()
   (while
      (and
         (> (: ofs) (- (length (: data)) (max (: rows) (: iniR))))
         (asoq '@@ (prove (: query))) )
      (=: data (conc (: data) (cons (cdr @)))) )
   (super) )

(dm txt> ()
   (for ((I . Q) (eval (: iniQ)) (prove Q))
      (map
         '((G D)
            (prin (txt> (car G) (car D)))
            (if (cdr G) (prin "^I") (prinl)) )
         (: gui 1)
         ((: put) (cdr (asoq '@@ @)) I) ) ) )

(dm query> (Q)
   (=: query Q)
   (set> This) )

(dm sort> (Exe)
   (set> This
      (goal
         (list
            (list 'lst '@@
               (by '((This) (eval Exe)) sort (: data)) ) ) ) ) )

(dm clr> ()
   (query> This (fail)) )


(====)

# Form object
(de <id> "Lst"
   (with (if *Post (: obj) (=: obj *ID))
      (and (: T) (prin "["))
      (for "X" (if (=T (car "Lst")) (cdr "Lst") "Lst")
         (ht:Prin (eval "X")) )
      (and (: T) (prin "]")) )
   (=: able
      (cond
         ((: obj T))
         ((=T (car "Lst")) T)
         (*Solo)
         ((== *Lock (: obj)) T)
         (*Lock (rollback) (off *Lock)) ) ) )

(de panel (Able Txt Del Dlg Var Cls Hook Msg Exe)
   (<spread>
      (editButton Able Exe)
      (delButton
         (cond
            ((=T Able) Del)
            ((=T Del) Able)
            ((and Able Del) (list 'and Able Del)) )
         (list 'text Txt (list ': 'top 1 'obj Var)) )
      (choButton Dlg)
      (stepBtn Var Cls Hook Msg) )
   (----) )

`*Dbg
(noLint 'gui)
(noLint 'choDlg 'gui)
(noLint 'jsForm 'action)

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