form.l

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

# 30dec07abu
# (c) Software Lab. Alexander Burger

# *Top *Gui *Get *Form *Event *Lock
# "*Cnt" "*Lst" "*App" "*Err" "*Post2" "*Stat" "*Ix" "*Chart" "*Cho"

(allow (path "@img/") T)
(push1 '*JS (allow (path "@lib/form.js")))
(mapc allow '(*Gui *Get *Form *Event "@jsForm"))

(one "*Cnt")
(off "*Lst" "*Post2" "*Cho")

# Define GUI form
(de form ("Attr" . "Prg")
   (inc '*Form)
   (let "App"
      (if *Post
         (get "*Lst" (- "*Cnt" *Get) *Form)
         (with (setq *Top (box))
            (=: able T)
            (=: event 0) )
         (conc (get "*Lst" (- "*Cnt" *Get)) (cons *Top))
         *Top )
      (for ("F" . "L") (get "*Lst" (- "*Cnt" *Get) 1)
         (let *Form (- "F")
            (cond
               ((and (== *Post (car "L")) (memq "App" (get *Post 'top)))
                  (apply "form" "L")
                  (<br>) )
               ((or (== *Post "App") (memq "App" (get *Post 'top)))
                  (unless (get "L" 1 'top)
                     (put (car "L") 'top (cons *Post (get *Post 'top))) )
                  (let *Post NIL (apply "form" "L"))
                  (<br>) ) ) ) )
      ("form" "App" "Attr" "Prg") ) )

(de "form" ("*App" "Attr" "Prg")
   (with "*App"
      (job (: env)
         (<post> "Attr" (urlMT *Url *Menu *Tab *ID)
            (<hidden> '*Get *Get)
            (<hidden> '*Form *Form)
            (<hidden> '*Event (inc (:: event)))
            (zero "*Ix")
            (if *Post
               (let gui
                  '(()
                     (with (get "*App" 'gui (inc '"*Ix"))
                        (for E "*Err"
                           (when (== This (car E))
                              (<p> 'err
                                 (if (atom (cdr E))
                                    (ht:Prin (eval (cdr E) 1))
                                    (eval (cdr E) 1) ) ) ) )
                        (if (: id)
                           (let *Gui (val "*App")
                              (show> This (cons '*Gui @)) )
                           (setq "*Chart" This) )
                        This ) )
                  (and (== *Post "*App") (setq *Top "*App"))
                  (htPrin "Prg") )
               (set "*App")
               (putl "*App"
                  (list
                     (cons (: top) 'top)
                     (cons (: able) 'able)
                     (cons (: event) 'event)
                     (cons (: env) 'env) ) )
               (let gui
                  '(@
                     (inc '"*Ix")
                     (with
                        (cond
                           ((pair (next)) (pass new @))
                           ((not (arg)) (pass new))
                           ((num? (arg))
                              (with "*Chart"
                                 (let (I (arg)  L (last (: gui)))
                                    (when (get L I)
                                       (inc (:: rows))
                                       (conc (: gui)
                                          (list (setq L (need (: cols)))) ) )
                                    (let Fld (pass new)
                                       (set (nth L I) Fld)
                                       (and (get Fld 'chg) (get Fld 'able) (=: lock))
                                       (set> Fld
                                          (get
                                             ((: put)
                                                (get (nth (: data) (: ofs)) (: rows))
                                                (+ (: ofs) (: rows) -1) )
                                             I )
                                          T )
                                       (put Fld 'chart (list This (: rows) I))
                                       Fld ) ) ) )
                           ((get "*App" (arg)) (quit "gui conflict" (arg)))
                           (T (put "*App" (arg) (pass new))) )
                        (=: home gui (conc (: home gui) (cons This)))
                        (unless (: chart) (init> This))
                        (when (: id)
                           (let *Gui (val "*App")
                              (show> This (cons '*Gui (: id))) ) )
                        This ) )
                  (htPrin "Prg") ) ) )
         (eval (: show))
         (=: show) ) ) )

# Disable form
(de disable (Flg)
   (and Flg (=: able)) )

# Click button
(de <click> (N)
   (unless *Post
      (prinl
         "<script type=\"text/javascript\">window.setTimeout(\"document.getElementById(\\\""
         *Form "--" "*Ix"
         "\\\").click()\", "
         N
         ");</script>" ) ) )

# Handle form actions
(de action Prg
   (unless "*Post2" (off "*Err"))
   (catch "stop"
      (if *Post
         (with (postForm) (postGui))
         (push '"*Lst" (cons))
         (and (nth "*Lst" 99) (con @))
         (setq *Get "*Cnt")
         (inc '"*Cnt") )
      (one *Form)
      (run Prg 1)
      (setq "*Stat" (cons "*Err" (copy (get "*Lst" (- "*Cnt" *Get)))))
      (off "*Post2") ) )

(de jsForm (Url)
   (setq *Url Url  Url (chop Url))
   (let action
      '(Prg
         (off "*Err")
         (catch "stop"
            (with (postForm)
               (postGui)
               (httpHead "text/plain; charset=utf-8")
               (if
                  (and
                     (= (car "*Stat") "*Err")
                     (= (cdr "*Stat") (get "*Lst" (- "*Cnt" *Get))) )
                  (ht:Out T
                     (when (: auto)
                        (prin *Form '- (: auto 1 id) ': (: auto -1))
                        (=: auto) )
                     (for This (: gui)
                        (if (: id)
                           (prin '& *Form '- @ '& (js> This))
                           (setq "*Chart" This) ) ) )
                  (setq "*Post2" *Post)
                  (prin "1^M^JT^M^J0^M^J^M^J") ) ) ) )  # 'T'
      (cond
         ((= '@ (car Url))
            ((intern (pack (cdr Url)))) )
         ((tail '("." "l") Url)
            (load *Url) ) ) ) )

(de postForm ()
   (let Lst (get "*Lst" (- "*Cnt" (setq *Get (format *Get))))
      (setq
         *Form (format *Form)
         *Event (format *Event)
         *Post (or
            "*Post2"
            (if (gt0 *Form)
               (get Lst *Form)
               (get Lst 1 (- *Form) 1) ) ) )
      (set Lst
         (filter
            '((L) (not (memq *Post (get L 1 'top))))
            (car Lst) ) )
      *Post ) )

(de postGui ()
   (if (or "*Post2" (<> *Event (: event)))
      (off *Gui)
      (while *Gui
         (con
            (assoc (caar *Gui) (val *Post))
            (cdr (pop '*Gui)) ) )
      (job (: env)
         (for This (: gui)
            (cond
               ((not (: id)) (setq "*Chart" This))
               ((chk> This) (err @))
               ((set> This (val> This) T)) ) )
         (for This (: gui)
            (unless (: id)
               (if (chk> (setq "*Chart" This))
                  (err @)
                  (set> This (val> This)) ) ) )
         (if "*Err"
            (and *Lock (with (caar "*Err") (tryLock *Lock)))
            (finally
               (when *Lock
                  (if (lock @)
                     (=: able (off *Lock))
                     (sync) ) )
               (for This (: gui)
                  (nond
                     ((: id) (setq "*Chart" This))
                     ((ge0 (: id))
                        (let? A (assoc (: id) (val *Post))
                           (when (cdr A)
                              (con A)
                              (and (eval (: able)) (act> This)) ) ) ) ) ) )
            (for This (: gui)
               (or (: id) (setq "*Chart" This))
               (upd> This) ) ) ) ) )

(de err (Exe)
   (queue '"*Err" (cons This Exe)) )

(de url (Url . @)
   (when Url
      (setq *Url Url  Url (chop Url))
      (off *Post)
      (cond
         ((= '@ (car Url))
            (apply (intern (pack (cdr Url)))
               (make
                  (while (args)
                     (if (and (sym? (next)) (= `(char '*) (char (arg))))
                        (set (arg) (next))
                        (link (arg)) ) ) ) ) )
         ((tail '("." "l") Url)
            (while (args)
               (set (next) (next)) )
            (load *Url) )
         ((assoc (stem Url ".") *Mimes)
            (apply httpEcho (cdr @) *Url) )
         (T (httpEcho *Url "application/octet-stream" 1 T)) )
      (throw "stop") ) )

# Return chart property
(de chart @
   (pass get "*Chart") )

(de alternating ()
   (onOff "rowF") )

# Scroll chart
(de "scrl" (N)
   (with "*Chart"
      (get> This)
      (unless (gt0 (inc (:: ofs) N))
         (=: ofs 1) )
      (put> This) ) )


### Dialogs ###
(de _dlg (Attr Env)
   (with (box)
      (push
         (get "*Lst" (- "*Cnt" *Get))
         (list This Attr Prg) )
      (=: able T)
      (=: event 0)
      (=: env Env) ) )

(de dialog (Env . Prg)
   (_dlg 'dialog Env) )

(de alert (Env . Prg)
   (_dlg 'alert Env) )

(de diaform (Lst . Prg)
   (if (and *Post (not (: diaform)))
      (_dlg 'dialog (env Lst))
      (=: env (env Lst))
      (=: diaform T)
      (run Prg 1) ) )

(de dispose (App)
   (let L (get "*Lst" (- "*Cnt" *Get))
      (del (asoq App (car L)) L) ) )

(de closeButton (Lbl Exe)
   (when (get "*App" 'top)
      (gui '(+Close +Button) Lbl Exe) ) )

(de okButton (Exe)
   (when (get "*App" 'top)
      (gui '(+Close +Button) "Ok" Exe) ) )

(de cancelButton ()
   (when (get "*App" 'top)
      (gui '(+Close +Button) ',"Cancel") ) )

(de yesButton (Exe)
   (gui '(+Close +Button) ',"Yes" Exe) )

(de noButton (Exe)
   (gui '(+Close +Button) ',"No" Exe) )

(de choButton (Exe)
   (gui '(+Rid +Button) ',"Select" Exe) )


(class +Close)

(dm act> ()
   (when (eval (: able))
      (dispose (: home))
      (extra)
      (for This (: home top)
         (for This (: gui)
            (or (: id) (setq "*Chart" This))
            (upd> This) ) ) ) )


# Choose a value
(class +ChoButton +Tiny +Button)

(dm T (Exe)
   (super "+" Exe)
   (=: chg T) )


(class +PickButton +Tiny +Button)

(dm T (Exe)
   (super "@" Exe) )


(class +DstButton +Set +Able +Close +PickButton)
# msg obj

(dm T (Dst Msg)
   (=: msg (or Msg 'url>))
   (super
      '((Obj) (=: obj (ext? Obj)))
      '(: obj)
      (unless (flg? Dst)
         (list 'set> (lit Dst) '(: obj)) ) ) )

(dm js> ()
   (cond
      ((: act) (super))
      ((try (: msg) (: obj))
         (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) )
      (T "@") ) )

(dm show> ("Var")
   (cond
      ((: act) (super "Var"))
      ((try (: msg) (: obj))
         (prin
            "<a href="
            (sesId (mkUrl @))
            " class=\"tiny\" id=\"" *Form '- (: id) "\">@</a>" ) )
      (T (prin "<span class=\"tiny\" id=\"" *Form '- (: id) "\">@</span>")) ) )


(class +Hint +ChoButton)
# ttl exe

(dm T (Ttl Exe)
   (=: ttl Ttl)
   (=: exe Exe)
   (super
      '(dialog (env 'Ttl (eval (: ttl))  'Lst (eval (: exe))  'Dst (field 1))
         (<table> 'chart Ttl '((btn) NIL)
            (for X Lst
               (<row> NIL
                  (gui '(+Close +PickButton) (list 'set> 'Dst (lit (fin X))))
                  (ht:Prin (if (atom X) X (car X))) ) ) )
         (cancelButton) ) ) )


### Field Prefix Classes ###
(class +Txt)
# txt

(dm T (Foo . @)
   (=: txt Foo)
   (pass extra) )

(dm txt> (Val)
   ((: txt) Val) )


(class +Set)
# set

(dm T (Foo . @)
   (=: set Foo)
   (pass extra) )

(dm set> (Val Dn)
   (extra ((: set) Val) Dn) )


(class +Val)
# val

(dm T (Foo . @)
   (=: val Foo)
   (pass extra) )

(dm val> ()
   ((: val) (extra)) )


(class +Fmt)
# set val

(dm T (Foo1 Foo2 . @)
   (=: set Foo1)
   (=: val Foo2)
   (pass extra) )

(dm set> (Val Dn)
   (extra ((: set) Val) Dn) )

(dm val> ()
   ((: val) (extra)) )


(class +Upd)
# upd

(dm T (Exe . @)
   (=: upd Exe)
   (pass extra) )

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


(class +Init)
# init

(dm T (Val . @)
   (=: init Val)
   (pass extra) )

(dm init> ()
   (set> This (: init)) )


(class +Cue)
# cue

(dm T (Str . @)
   (=: cue (pack "<" Str ">"))
   (pass extra) )

(dm show> ("Var")
   (<style>
      (list
         (cons 'onfocus (pack "if (this.value=='" (: cue) "') this.value=''"))
         (cons 'onblur (pack "if (this.value=='') this.value='" (: cue) "'")) )
      (extra "Var") ) )

(dm set> (Val Dn)
   (extra (or Val (: cue)) Dn) )

(dm val> ()
   (let Val (extra)
      (unless (= Val (: cue)) Val) ) )


(class +Map)
# map

(dm T (Lst . @)
   (=: map Lst)
   (pass extra) )

(dm set> (Val Dn)
   (extra
      (if
         (find
            '((X) (= Val (cdr X)))
            (: map) )
         (val (car @))
         Val )
      Dn ) )

(dm val> ()
   (let V (extra)
      (if
         (find
            '((X) (= V (val (car X))))
            (: map) )
         (cdr @)
         V ) ) )


# Case conversions
(class +Uppc)

(dm set> (Val Dn)
   (extra (uppc Val) Dn) )

(dm val> ()
   (uppc (extra)) )


(class +Lowc)

(dm set> (Val Dn)
   (extra (lowc Val) Dn) )

(dm val> ()
   (lowc (extra)) )


# Field enable/disable
(de able ()
   (when (or (: rid) (: home able))
      (eval (: able)) ) )

(class +Able)

(dm T (Exe . @)
   (pass extra)
   (=: able Exe) )


(class +Lock +Able)

(dm T @
   (pass super NIL) )


(class +View +Lock +Upd)


# Escape from form lock
(class +Rid)
# rid

(dm T @
   (=: rid T)
   (pass extra) )


(class +Align)