form.l

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

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


(class +Limit)
# lim

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


(class +Var)
# var

(dm T (Var . @)
   (=: var Var)
   (pass extra) )

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

(dm upd> ()
   (set> This (val (: var))) )


(class +Chk)
# chk

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

(dm chk> ()
   (eval (: chk)) )


(class +Tip)
# tip

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

(dm show> ("Var")
   (<tip> (eval (: tip)) (extra "Var")) )

(dm js> ()
   (pack (extra) "&?" (ht:Fmt (eval (: tip)))) )


(class +Tiny)

(dm show> ("Var")
   (<style> 'tiny (extra "Var")) )


### Styles ###
(class +Style)
# style

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

(dm show> ("Var")
   (<style> (eval (: style)) (extra "Var")) )

(dm js> ()
   (pack (extra) "&#" (eval (: style))) )


# Signum field
(class +Sgn +Style)

(dm T @
   (pass super '(if (lt0 (val> This)) 'red 'black)) )


### Form field classes ###
(de showFld "Prg"
   (when (: lbl)
      (prin "<label>")
      (ht:Prin (eval @))
      (<nbsp>) )
   (style (cons 'id (pack *Form '- (: id))) "Prg")
   (and (: lbl) (prinl "</label>")) )


(class +gui)
# home id chg able chart

(dm T ()
   (push (=: home "*App") (cons (=: id "*Ix")))
   (=: able T) )

(dm txt> (Val))

(dm set> (Val Dn))

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

(dm val> ())

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

(dm upd> ())

(dm chk> ())


(class +field +gui)

(dm T ()
   (super)
   (=: chg T) )

(dm txt> (Val)
   Val )

(dm js> ()
   (let S (ht:Fmt (cdr (assoc (: id) (val *Post))))
      (if (able) S (pack S "&=")) ) )

(dm set> (Str Dn)
   (con (assoc (: id) (val (: home))) Str)
   (and (not Dn) (: chart) (set> (car @) (val> (car @)))) )

(dm str> ()
   (cdr (assoc (: id) (val (: home)))) )

(dm val> ()
   (str> This) )


# Get field
(de field (X . @)
   (if (sym? X)
      (pass get (: home) X)
      (pass get (: home gui) (+ X (abs (: id)))) ) )

# Get current chart data row
(de row (D)
   (+ (: chart 1 ofs) (: chart 2) -1 (or D 0)) )

(de curr @
   (pass get (: chart 1 data) (row)) )

(de prev @
   (pass get (: chart 1 data) (row -1)) )


(class +Button +gui)
# img lbl alt act js

# ([T] lbl [alt] act)
(dm T @
   (and (=: img (=T (next))) (next))
   (=: lbl (arg))
   (let X (next)
      (ifn (args)
         (=: act X)
         (=: alt X)
         (=: act (next)) ) )
   (super)
   (set
      (car (val "*App"))
      (=: id (- (: id))) ) )

(dm js> ()
   (if (able)
      (let Str (ht:Fmt (eval (: lbl)))
         (if (: img) (sesId Str) Str) )
      (let Str (ht:Fmt (or (eval (: alt)) (eval (: lbl))))
         (pack (if (: img) (sesId Str) Str) "&=") ) ) )

(dm show> ("Var")
   (<style> (cons 'id (pack *Form '- (: id)))
      (if (able)
         (let Str (eval (: lbl))
            ((if (: img) <image> <submit>) Str "Var" NIL (: js)) )
         (let Str (or (eval (: alt)) (eval (: lbl)))
            ((if (: img) <image> <submit>) Str "Var" T (: js)) ) ) ) )

(dm act> ()
   (and (able) (eval (: act))) )


(class +JS)

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


(class +Auto +JS)
# auto

(dm T (Fld Exe . @)
   (=: auto (cons Fld Exe))
   (pass super) )

(dm act> ()
   (=: home auto
      (cons
         (eval (car (: auto)))
         (eval (cdr (: auto))) ) )
   (extra) )


(class +DnButton +Tiny +Rid +JS +Able +Button)

(dm T (Exe Lbl)
   (super
      (list '>= '(length (chart 'data)) (list '+ Exe '(chart 'ofs)))
      (or Lbl ">")
      (list '"scrl" Exe) ) )


(class +UpButton +Tiny +Rid +JS +Able +Button)

(dm T (Exe Lbl)
   (super
      '(> (chart 'ofs) 1)
      (or Lbl "<")
      (list '"scrl" (list '- Exe)) ) )

(de scroll (N)
   (gui '(+UpButton) N "<<")
   (gui '(+UpButton) 1 "<")
   (gui '(+DnButton) 1 ">")
   (gui '(+DnButton) N ">>") )


# Delete row
(class +DelRowButton +Tiny +JS +Able +Button)
# exe del

(dm T (Exe Txt)
   (=: exe Exe)
   (=: del Txt)
   (super '(nth (: chart 1 data) (row)) "x"
      '(if (curr)
         (alert (env 'Fld This 'Exe (: exe))
            (ht:Prin
               (if (get Fld 'del)
                  (with Fld (eval @))
                  ,"Delete row?" ) )
            (----)
            (yesButton '(with Fld (_delRow)))
            (noButton) )
         (_delRow) ) ) )

(de _delRow ()
   (eval Exe)
   (set> (: chart 1) (remove (row) (: chart 1 data))) )

# Move row up
(class +BubbleButton +Tiny +JS +Able +Button)

(dm T ()
   (super
      '(and
         (> (: chart 2) 1)
         (nth (: chart 1 data) (row)) )
      "\^"
      '(let L (: chart 1 data)
         (set> (: chart 1)
            (conc
               (cut (row -2) 'L)
               (cons (cadr L))
               (cons (car L))
               (cddr L) ) ) ) ) )


(class +ClrButton +JS +Button)
# clr

(dm T (Lbl Lst . @)
   (=: clr Lst)
   (pass super Lbl
      '(for X (: clr)
         (if (atom X)
            (clr> (field X))
            (set> (field (car X)) (eval (cdr X))) ) ) ) )


(class +ShowButton +Button)

(dm T (Exe)
   (super ,"Show"
      (list '=: 'home 'show (lit Exe)) ) )


(class +Checkbox +field)
# lbl

# ([lbl])
(dm T (Lbl)
   (=: lbl Lbl)
   (super) )

(dm txt> (Val)
   (if Val ,"Yes" ,"No") )

(dm show> ("Var")
   (showFld (<check> "Var" (not (able)))) )

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

(dm val> ()
   (bool (super)) )


(class +TextField +field)
# dx|lst lbl lim align

# (dx [dy] [lbl])
# (lst [lbl])
(dm T (X . @)
   (nond
      ((num? X)
         (=: lst X)
         (=: lbl (next)) )
      ((num? (next))
         (=: dx X)
         (=: lbl (arg)) )
      (NIL
         (=: dx X)
         (=: dy (arg))
         (=: lbl (next)) ) )
   (super)
   (or (: dx) (: lst) (=: chg)) )

(dm show> ("Var")
   (showFld
      (cond
         ((: dy)
            (<area>
               (: dx)
               (: dy)
               "Var"
               (not (able)) ) )
         ((: dx)
            (<field>
               (if (: align) (- (: dx)) (: dx))
               "Var"
               (eval (: lim))
               (not (able)) ) )
         ((: lst)
            (let (L (mapcar val @)  S (str> This))
               (<select>
                  (if (member S L) L (cons S L))
                  "Var"
                  (not (able)) ) ) )
         (T
            (prin "<span id=\"" *Form '- (: id) "\">")
            (if (str> This) (ht:Prin @) (<nbsp>))
            (prin "</span>") ) ) ) )


(class +ListTextField +TextField)
# split

(dm T (Lst . @)
   (=: split Lst)
   (pass super) )

(dm set> (Val Dn)
   (super (glue (car (: split)) Val) Dn) )

(dm val> ()
   (mapcan
      '((S) (and (pack S) (cons @)))
      (apply split (: split) (chop (super))) ) )


# Password field
(class +PwField +TextField)

(dm show> ("Var")
   (showFld
      (<passwd> (: dx) "Var" (eval (: lim)) (not (able))) ) )


# Upload field
(class +UpField +TextField)

(dm show> ("Var")
   (showFld
      (<upload> (: dx) "Var" (not (able))) ) )


# Symbol fields
(class +SymField +TextField)

(dm val> ()
   (let S (super)
      (and (<> "-" S) (intern S)) ) )

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


(class +numField +Align +TextField)
# scl

(dm chk> ()
   (and
      (str> This)
      (not (format @ (: scl) *Sep0 *Sep3))
      ,"Numeric input expected" ) )


(class +NumField +numField)

(dm txt> (Val)
   (format Val) )

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

(dm val> ()
   (format (super) NIL *Sep0 *Sep3) )


(class +FixField +numField)

(dm T (N . @)
   (=: scl N)
   (pass super) )

(dm txt> (Val)
   (format Val (: scl) *Sep0 *Sep3) )

(dm set> (Val Dn)
   (super (format Val (: scl) *Sep0 *Sep3) Dn) )

(dm val> ()
   (let (S (super)  L (chop S))
      (unless (member *Sep0 L)
         (setq S (pack S *Sep0)) )
      (format S (: scl) *Sep0 *Sep3) ) )


(class +DateField +TextField)

(dm txt> (Val)
   (datStr Val) )

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

(dm val> ()
   (expDat (super)) )

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


(class +TimeField +TextField)

(dm txt> (Val)
   (tim$ Val (> (: dx) 6)) )

(dm set> (Val Dn)
   (super (tim$ Val (> (: dx) 6)) Dn) )

(dm val> ()
   ($tim (super)) )

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


(class +Icon)
# icon url

(dm T (Exe1 Exe2 . @)
   (=: icon Exe1)
   (=: url Exe2)
   (pass extra) )

(dm js> ()
   (pack (extra) "&*"
      (ht:Fmt (sesId (eval (: icon)))) '&
      (and (eval (: url)) (ht:Fmt (sesId @))) ) )

(dm show> ("Var")
   (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>")
   (extra "Var")
   (prin "</td><td>")
   (<img> (eval (: icon)) 'icon (: url))
   (prinl "</td></table>") )


(class +UrlField +TextField)
# url

(dm T (Foo . @)
   (=: url Foo)
   (pass super) )

(dm js> ()
   (if2 (or (: dx) (: lst)) (val> This)
      (pack (super) "&*" (ht:Fmt (sesId `(path "@img/go.png"))) '& (ht:Fmt (sesId ((: url) @))))
      (pack (super) "&*" (ht:Fmt (sesId `(path "@img/no.png"))) '&)
      (pack @ "&+" (ht:Fmt (sesId ((: url) @))))
      (super) ) )

(dm show> ("Var")
   (cond
      ((or (: dx) (: lst))
         (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>")
         (super "Var")
         (prin "</td><td>")
         (if (val> This)
            (<img> `(path "@img/go.png") 'url ((: url) @))
            (<img> `(path "@img/no.png")) )
         (prinl "</td></table>") )
      ((val> This)
         (showFld (<href> @ ((: url) @))) )
      (T (super "Var")) ) )


(class +HttpField +UrlField)

(dm T @
   (pass super '((S) (pack (or *Gate "http") "://" S))) )


(class +MailField +UrlField)

(dm T @
   (pass super '((S) (pack "mailto:" S))) )


(class +TelField +TextField)