# 29jan24 Software Lab. Alexander Burger
# *PRG *Top *Gui *Btn *Get *Got *Form *FormIx *FormLst *Evt
# *Lock *Spans *AlwaysAsk
(private) (*Chart *App *Ix *Err *Foc *Post2 *Stat *Cho *TZO)
(allow "@img/" T)
(push1 '*JS (allow "@lib/form.js")) #! @lib
(mapc allow
(quote
*Gui *Get *Got *Form "!jsForm" *Evt *Drop
*JsHint "!jsHint" jsUp jsDn *JsArgs "!tzOffs" ) )
(default *FormIx 1)
(de *Go.png . "@img/go.png")
(de *No.png . "@img/no.png")
(de *Throbber
("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) )
(de tzOffs (Min)
(setq *TZO (* Min 60))
(respond) )
(private) (Attr Prg App Lst F L)
# Define GUI form
(de form (Attr . Prg)
(inc '*Form)
(let App
(if *PRG
(get *FormLst (- *FormIx *Get) *Form)
(prog1
(setq *Top (new NIL NIL 'able T 'evt 0))
~(as *Dbg
(when (file)
(put *Top '*Dbg
(list (cons (cddr @) (pack (car @) (cadr @)))) ) ) )
(put *Top 'home *Top)
(and (nth *FormLst (- *FormIx *Get)) (queue @ *Top)) ) )
(let Lst (get *FormLst (- *FormIx *Get) 1)
(for (F . L) Lst
(let *Form (- F (length Lst))
(cond
((and (== *PRG (car L)) (memq App ( (apply "form" L) )
((or (== *PRG App) (memq App ( (if ( (apply "form" L)
(put L 1 'top (cons *PRG ( (let *PRG NIL (apply "form" L)) ) ) ) ) ) )
("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> '*Evt (: evt))
(zero *Ix)
(if *PRG
(let gui
'(()
(with (get *App 'gui (inc '*Ix))
(for E *Err
(when (== This (car E))
(<div> 'error
(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 (== *PRG *App) (setq *Top *App))
(htPrin Prg) )
(set *App)
(let gui
'((X . @)
(inc '*Ix)
(with
(cond
((pair X) (pass new X))
((not X) (pass new))
((num? X)
(ifn *Chart
(quit "no chart" (rest))
(with *Chart
(let L (last (: gui))
(when (get L X)
(inc (:: rows))
(queue (:: gui) (setq L (need (: cols)))) )
(let Fld (pass new)
(set (nth L X) Fld)
(put Fld 'chart (list This (: rows) X))
(and ( (set> Fld
(get
((: put)
(get (nth (: data) (: ofs)) (: rows))
(+ (: ofs) (: rows) -1) )
X )
T )
Fld ) ) ) ) )
((get *App X) (quit "gui conflict" X))
(T (put *App X (pass new))) )
(queue (:: home gui) This)
(unless (: chart) (init> This))
(when (: id)
(let *Gui (val *App)
(show> This (cons '*Gui (: id))) ) )
This ) )
(htPrin Prg) ) ) )
(off *Chart)
(--)
(and
(: show)
(info @)
(in (: show) (echo)) ) ) ) )
# Disable form
(de disable (Flg)
(and Flg (=: able)) )
(private) Prg
# Handle form actions
(de action Prg
(off *Chart *Foc)
(or *PRG *Post2 (off *Err))
(catch 'stop
(nond
(*Post
(unless (and *PRG (= *Form (car *Got)) (= *Get (cadr *Got)))
(pushForm (cons)) )
(if *Port%
(let *JS NIL (_doForm))
(_doForm) )
(off *PRG *Got) )
(*PRG
(with (postForm)
(ifn (= *Evt (: evt))
(noContent)
(postGui)
(redirect
(baseHRef)
*SesId
(urlMT *Url *Menu *Tab *ID)
"&*Evt=+" (inc (:: evt))
"&*Got=_+" *Form "_+" *Get ) ) ) )
(NIL
(off *PRG)
(pushForm (cons))
(_doForm) ) ) ) )
(de pushForm (L)
(push '*FormLst L)
(and (nth *FormLst 99) (con @))
(setq *Get *FormIx)
(inc '*FormIx) )
(de _doForm ()
(one *Form)
(run Prg)
(setq *Stat
(cons
(pair *Err)
(copy (get *FormLst (- *FormIx *Get))) ) ) )
(de jsForm (Url)
(if (or *PRG (not *Post))
(noContent)
(setq *Url Url Url (chop Url))
(let action
'(Prg
(off *Err)
(with (postForm)
(ifn (= *Evt (: evt))
(respond)
(catch 'stop
(postGui)
(httpHead "text/plain; charset=utf-8")
(if
(and
(= (car *Stat) *Err)
(= (cdr *Stat) (get *FormLst (- *FormIx *Get))) )
(ht:Out *Chunked
(prin (setq *Evt (inc (:: evt))) "&")
(when (: auto)
(prin "i" *Form "-" (: auto 1 id) ":" (: auto -1))
(=: auto) )
(for S *Spans
(prin "&" (car S) "&" (run (cdr S))) )
(for This (: gui)
(if (: id)
(prin "&i" *Form "-" @ "&" (js> This))
(setq *Chart This) ) ) )
(setq *Post2 (cons *Get *Form *PRG))
(ht:Out *Chunked (prin T)) ) ) ) )
(off *PRG) )
(use @X
(cond
((match '("-" @X "." "h" "t" "m" "l") Url)
(try 'html> (extern (ht:Pack @X T))) )
((disallowed)
(notAllowed *Url)
(http404) )
((= "!" (car Url))
((intern (cdr Url))) )
((tail '("." "l") Url)
(load *Url) ) ) ) ) ) )
(de postForm ()
(when (num? (format *Get))
(let? Lst (get *FormLst (- *FormIx (setq *Get @)))
(and
(setq *Form (format *Form))
(setq *Evt (format *Evt))
(setq *PRG
(cond
((and
(= *Get (car *Post2))
(= *Form (cadr *Post2)) )
(cddr *Post2) )
((off *Post2))
((gt0 *Form) (get Lst *Form))
(T (get Lst 1 (+ (length (car Lst)) *Form) 1)) ) )
(val *PRG)
*PRG ) ) ) )
(de postGui ()
(if *Post2
(off *Gui *Post2)
(let (*Btn NIL "Fun")
(for G *Gui
(if (=0 (car G))
(setq "Fun" (cdr G))
(and (lt0 (car G)) (setq *Btn (cdr G)))
(con (assoc (car G) (val *PRG)) (cdr G)) ) )
(off *Gui)
(and (: lock) (n== @ *Lock) (=: able))
(job (: env)
(for This (: gui)
(cond
((not (: id)) (setq *Chart This))
((chk> This) (error @))
((or (: rid) (: home able))
(set> This (val> This) T) ) ) )
(unless *Err
(for This (: gui)
(cond
((: id))
((chk> (setq *Chart This)) (error @))
((or (: rid) (: home able))
(set> This (val> This)) ) ) ) )
(if (pair *Err)
(when *Lock
(=: lock (with (caar *Err) (tryLock *Lock))) )
(finally
(when *Lock
(if (lock @)
(=: able (=: lock (off *Lock)))
(let *Run NIL
(sync)
(tell) ) ) )
(when "Fun"
(when (and *Allow (not (idx *Allow "Fun")))
(notAllowed "Fun")
(throw 'stop) )
(apply (intern "Fun")
(mapcar
'((X)
((if (= "+" (car (setq X (chop (cdr X))))) format pack)
(cdr X) ) )
*JsArgs ) ) )
(for This (: gui)
(nond
((: id) (setq *Chart This))
((ge0 (: id))
(let? A (assoc (: id) (val *PRG))
(when (cdr A)
(con A)
(act> This) ) ) ) ) ) )
(for This (: gui)
(or (: id) (setq *Chart This))
(upd> This) ) ) ) ) ) )
(de error (Exe)
(cond
((=T Exe) (on *Err))
((nT *Err) (queue '*Err (cons This Exe))) ) )
(de url (Url . @)
(when Url
(off *PRG)
(when *Timeout
(timeout `(* 3600 1000)) )
(redirect (baseHRef) *SesId Url
(and (args) "?")
(pack
(make
(loop
(let A (next)
(and
(sym? A)
(= `(char '*) (char A))
(link A "=")
(setq A (next)) )
(link (ht:Fmt A)) )
(NIL (args))
(link "&") ) ) ) )
(throw 'stop) ) )
(de post Prg
(run Prg)
(url *Uri) )
# Active <span> elements
(de span Args
(def (car Args)
(list NIL
(list '<span>
(lit (cons 'id (car Args)))
(cons 'ht:Prin (cdr Args)) ) ) )
(push '*Spans Args) )
(span expires
(pack
`(char 8230) # Ellipsis
(let Tim (+ (time T) (/ (cadr (assoc -1 *Run)) 1000))
(if *TZO
(tim$ (% (- Tim -86400 @) 86400))
(<javascript>
"lisp(null, 'tzOffs', (new Date()).getTimezoneOffset())" )
(pack (tim$ (% Tim 86400)) " UTC") ) ) ) )
# Return chart property
(de chart @
(pass get *Chart) )
# Table extension
(daemon '<table>
(with *Chart
(setq ATTR
(make
(link
(cons "chart" (index This (: home chart)))
'("ontouchmove" . "return tblMove(this,event)")
'("ontouchstart" . "return tblTouch(event)")
(and ATTR (link @)) ) ) ) ) )
# REPL form
(private) Str
(de repl (Attr DX DY)
(default DX 80 DY 25)
(form Attr
(=: repl (tmp "repl"))
(gui 'view '(+Able +FileField)
'(<> (: file) (: home repl))
(: repl)
DX DY )
(--)
(gui '(+View +SymField) '(car (symbols)))
(<nbsp>)
(gui 'line '(+Focus +Able +Hint1 +TextField)
'(= (: home view file) (: home repl))
'*ReplH
(*/ DX 4 5) )
(----)
(gui '(+JS +Able +Button) '(= (: home view file) (: home repl)) "Eval"
'(let Str (val> (: home line))
(out (pack "+" (: home repl))
(if (= `(char "!") (char Str))
(err NIL
(prinl Str)
(flush)
(in (list "sh" "-c" (cdr (chop Str)))
(echo) ) )
(err NIL
(prinl (car (symbols)) ": " Str)
(flush)
(catch '(NIL)
(in "/dev/null"
(up 99 @@@ "@3")
(up 99 @@ "@2")
(up 99 @ "@1")
(setq "@3" "@2" "@2" "@1" "@1" (run (str Str) 99)) )
(off *Msg)
(println '-> "@1") ) )
(when *Msg
(prin "!? ")
(println ^)
(prinl *Msg) ) ) )
(push1 '*ReplH Str)
(clr> (: home line)) ) )
(gui '(+JS +Button)
'(if (= (: home view file) (: home repl)) ,"Edit" ,"Done")
'(file> (: home view)
(if (= (: home view file) (: home repl))
(if (val> (: home line))
(setq *ReplF (push1 '*ReplH @))
(set> (: home line) *ReplF)
*ReplF )
(clr> (: home line))
(: home repl) ) ) ) ) )
(private) (dlg Attr Env Lst Prg)
# Dialogs
(de dlg (Attr Env Prg)
(let? L (get *FormLst (- *FormIx *Get))
(while (and (car L) (n== *PRG (caar @)))
(pop L) )
(push L
(list
(new NIL NIL 'btn This 'able T 'evt 0 'env Env)
Attr
Prg ) )
(pushForm L) ) )
(de dialog (Env . Prg)
(dlg 'dialog Env Prg) )
(de alert (Env . Prg)
(dlg 'alert Env Prg) )
(de note (Str Lst)
(alert (env '(Str Lst))
(<span> 'note Str)
(--)
(for S Lst (<br> S))
(okButton) ) )
(de ask (Str . Prg)
(alert (env '(Str Prg))
(<span> 'ask Str)
(--)
(yesButton (cons 'prog Prg))
(noButton) ) )
(de diaform (Lst . Prg)
(cond
((num? (caar Lst)) # Dst
(gui (gt0 (caar Lst)) '(+ChoButton)
(cons 'diaform
(list 'cons
(list 'cons (lit (car Lst)) '(field 1))
(lit (env (cdr Lst))) )
Prg ) ) )
((and *PRG (not (: diaform)))
(dlg 'dialog (env Lst) Prg) )
(T
(=: env (env Lst))
(=: diaform T)
(run Prg 1) ) ) )
(de saveButton (Exe)
(gui '(+Button) ,"Save" Exe) )
(de closeButton (Lbl Exe)
(when ( (gui '(+Rid +Close +Button) Lbl Exe) ) )
(de okButton (Exe)
(when ( (if (=T Exe)
(gui '(+Force +Close +Button) T "OK")
(gui '(+Close +Button) "OK" Exe) ) ) )
(de cancelButton ()
(when ( (gui '(+Force +Close +Button) T ',"Cancel") ) )
(de yesButton (Exe)
(gui '(+Close +Button) ',"Yes" Exe) )
(de noButton (Exe)
(gui '(+Close +Button) ',"No" Exe) )
(de choButton (Exe)
(gui '(+Rid +Tip +Button)
,"Find or create an object of the same type"
',"Select" Exe ) )
(class +Force)
# force
(dm T (Exe . @)
(=: force Exe)
(pass extra) )
(dm chk> ()
(when
(and
(cdr (assoc (: id) (val *PRG)))
(eval (: force)) )
(for A (val *PRG)
(and
(lt0 (car A))
(<> (: id) (car A))
(con A) ) )
T ) )
(class +Close)
(dm act> ()
(when (able)
(and
(get *FormLst (- *FormIx *Get))
(pushForm
(cons
(filter
'((L) (memq (car L) (: home top)))
(car @) )
(cdr @) ) ) )
(extra)
(for This (: home top)
(for This (: gui)
(or (: id) (setq *Chart This))
(upd> This) ) ) ) )
# Choose a value
(class +ChoButton +Tiny +Tip +Button)
(dm T (Exe)
(super ,"Choose a suitable value" "+" Exe)
(=: chg T) )
(class +PickButton +Tiny +Tip +Button)
(dm T (Exe)
(super ,"Adopt this value" "@" Exe) )
(class +DstButton +Set +Able +Close +PickButton)
# msg obj
(dm T (Dst Msg)
(=: msg (or Msg 'url>))
(super
'((Obj) (=: obj Obj))
'(: obj)
(when Dst
(or
(pair Dst)
(list 'chgDst (lit Dst) '(: obj)) ) ) ) )
(de chgDst (This Val)
(set> This (if (: new) (@ Val) Val)) )
(dm js> ()
(cond
((: act) (super))
((try (: msg) (: obj) 1 This)
(pack "@&+" (ht:Fmt (sesId (mkUrl @)))) )
(T "@") ) )
(dm show> (Var)
(if (: act)
(super Var)
(<style> (cons 'id (pack "i" *Form "-" (: id)))
(if (try (: msg) (: obj) 1 This)
(<tip> "-->" (<href> "@" (mkUrl @)))
(<span> *Style "@") ) ) ) )
(class +Choice +ChoButton)
# ttl hint
(dm T (Ttl Exe)
(=: ttl Ttl)
(=: hint Exe)
(super
'(dialog (env 'Ttl (eval (: ttl)) 'Lst (eval (: hint)) 'Dst (field 1))
(<table> 'chart Ttl '((btn) NIL)
(for X Lst
(<row> NIL
(gui '(+Close +PickButton)
(list 'set> 'Dst
(if (get Dst 'dy)
(list 'pack '(str> Dst) (fin X))
(lit (fin X)) ) ) )
(ht:Prin (if (atom X) X (car X))) ) ) )
(cancelButton) ) ) )
(class +Tok)
(dm T @
(=: tok T)
(pass extra) )
(class +Coy)
(dm T @
(=: coy T)
(pass extra) )
(class +hint)
# tok coy
(dm show> (Var)
(<js>
(list
'("autocomplete" . "off")
'("onfocus" . "doHint(this)")
(cons
"onkeyup"
(pack
"return hintKey(this,event"
(if2 (: tok) (: coy) ",true,true" ",true" ",false,true")
")" ) ) )
(extra Var) ) )
(de jsHint (I)
(when I
(httpHead "text/plain; charset=utf-8")
(ht:Out *Chunked
(let? L
(if (sym? I)
(( (let? Lst (get *FormLst (- *FormIx (format *Get)))
(pair
(hint>
(get
(if (gt0 (format *Form))
(get Lst @)
(get Lst 1 (+ (length (car Lst)) (format *Form)) 1) )
'gui
I )
*JsHint ) ) ) )
(prin
(ht:Fmt
(if (atom (car L))
(car L)
(caar L) ) ) )
(for X (cdr L)
(prin "&"
(ht:Fmt (if (atom X) X (car X))) ) ) ) ) ) )
(class +Hint +hint)
# hint
(dm T (Fun . @)
(=: hint Fun)
(pass extra) )
(dm hint> (Str)
((: hint) (extra Str)) )
(de hintQ (Var CL Str)
(make
(for (Q (search Str CL) (search Q))
(when (match> (meta @ Var) Str (get @ Var) @)
(unless (member @ (made))
(link @) ) )
(T (nth (made) 24)) ) ) )
(de dbHint (Str Var Cls Hook)
(hintQ Var (list (list Var Cls Hook)) Str) )
(de queryHint (Var CL Str) #! Will be deprecated (use hintQ instead)
(make
(for (Q (goal CL) (prove Q))
(for V
(fish
'((S) (and (atom S) (sub? (fold Str) (fold S))))
(get @ '@@ Var) )
(unless (member V (made))
(link V) ) )
(T (nth (made) 24)) ) ) )
(class +DbHint +Hint)
(dm T (Rel . @)
(pass super
(list '(Str)
(list 'dbHint 'Str
(lit (car Rel))
(lit (last Rel))
(and (meta (cdr Rel) (car Rel) 'hook) (next)) ) ) ) )
(class +Hint1 +hint)
# hint
(dm T (Exe . @)
(=: hint Exe)
(pass extra) )
(dm hint> (Str)
(setq Str (extra Str))
(extract '((S) (pre? Str S))
(eval (: hint)) ) )
(class +Hint2 +hint)
(dm hint> (Str)
(setq Str (extra Str))
(extract '((X) (pre? Str (if (atom X) X (car X))))
(with (field -1) (eval (: hint))) ) )
(class +Txt)
# txt
(dm T (Fun . @)
(=: txt Fun)
(pass extra) )
(dm txt> (Val)
((: txt) Val) )
(class +Set)
# set
(dm T (Fun . @)
(=: set Fun)
(pass extra) )
(dm set> (Val Dn)
(extra ((: set) Val) Dn) )
(class +Val)
# val
(dm T (Fun . @)
(=: val Fun)
(pass extra) )
(dm val> ()
((: val) (extra)) )
(class +Fmt)
# set val
(dm T (Fun1 Fun2 . @)
(=: set Fun1)
(=: val Fun2)
(pass extra) )
(dm set> (Val Dn)
(extra ((: set) Val) Dn) )
(dm val> ()
((: val) (extra)) )
(class +Chg)
# old new
(dm T (Fun . @)
(=: new Fun)
(pass extra) )
(dm set> (Val Dn)
(extra (=: old Val) Dn) )
(dm val> ()
(let Val (extra)
(if (and (<> (: old) Val) (able))
((: new) (=: old Val))
Val ) ) )
(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 +Dflt)
# dflt
(dm T (Exe . @)
(=: dflt Exe)
(pass extra) )
(dm set> (Val Dn)
(extra (or Val (eval (: dflt))) Dn) )
(dm val> ()
(let Val (extra)
(unless (= Val (eval (: dflt))) Val) ) )
(class +Cue)
# cue
(dm T (Str . @)
(=: cue (pack "<" Str ">"))
(pass extra) )
(dm show> (Var)
(<js>
(cons (cons "placeholder" (: cue)))
(extra Var) ) )
(class +Trim)
(dm val> ()
(pack (trim (chop (extra)))) )
(class +Enum)
# enum
(dm T (Lst . @)
(=: enum Lst)
(pass extra) )
(dm set> (N Dn)
(extra (get (: enum) N) Dn) )
(dm val> ()
(index (extra) (: enum)) )
(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 Val (extra)
(if
(find
'((X) (= Val (val (car X))))
(: map) )
(cdr @)
Val ) ) )
# Case conversions
(class +Uppc)
(dm set> (Val Dn)
(extra (uppc Val) Dn) )
(dm val> ()
(uppc (extra)) )
(dm hint> (Str)
(extra (uppc Str)) )
(class +Lowc)
(dm set> (Val Dn)
(extra (lowc Val) Dn) )
(dm val> ()
(lowc (extra)) )
(dm hint> (Str)
(extra (lowc Str)) )
# Field enable/disable
(de able ()
(when (or (: rid) (: home able))
(eval (: able)) ) )
(class +Able)
(dm T (Exe . @)
(pass extra)
(when (: able)
(=: able
(cond
((=T (: able)) Exe)
((and (pair (: able)) (== 'and (car @)))
(cons 'and Exe (cdr (: able))) )
(T (list 'and Exe (: able))) ) ) ) )
(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)
(dm T @
(=: align T)
(pass extra) )
(class +Limit)
# lim
(dm T (Exe . @)
(=: lim Exe)
(pass extra) )
(class +Clr0)
(dm val> ()
(let N (extra)
(unless (=0 N) N) ) )
(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 . @)
(unless (: tip)
(=: tip Exe) )
(pass extra) )
(dm show> (Var)
(<tip> (eval (: tip)) (extra Var)) )
(dm js> ()
(pack (extra) "&?" (ht:Fmt (glue "\n" (eval (: tip))))) )
(class +Tiny)
(dm show> (Var)
(<style> 'tiny (extra Var)) )
(class +Click)
# clk
(dm T (Exe . @)
(=: clk Exe)
(pass extra) )
(dm show> (Var)
(extra Var)
(and
(atom *Err)
(eval (: clk))
(<javascript>
"window.setTimeout(\"document.getElementById('"
"i" *Form "-" (: id)
"').click()\","
@
")" ) ) )
(class +Focus)
(dm show> (Var)
(extra Var)
(when (and (able) (not *Foc))
(on *Foc)
(<javascript> "idFocus('" "i" *Form "-" (: id) "')") ) )
### Styles ###
(class +Style)
# style
(dm T (Exe . @)
(=: style Exe)
(pass extra) )
(dm show> (Var)
(<style> (pack (eval (: style)) " ") (extra Var)) )
(dm js> ()
(pack (extra) "&#" (eval (: style))) )
# Monospace font
(class +Mono)
(dm show> (Var)
(<style> "mono" (extra Var)) )
(dm js> ()
(pack (extra) "&#mono") )
# Signum field
(class +Sgn)
(dm show> (Var)
(<style> (and (lt0 (val> This)) "red") (extra Var)) )
(dm js> ()
(pack (extra) "&#" (and (lt0 (val> This)) "red")) )
### Form field classes ###
(de showFld Prg
(when (: lbl)
(ht:Prin (eval @))
(<nbsp>) )
(let *Style (style (cons 'id (pack "i" *Form "-" (: id))) *Style)
(run Prg 1) ) )
(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 hint> (Str)
Str )
(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 *PRG))))
(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 @
(let A (next)
(=: lbl
(if (=: img (=T A)) (next) A) ) )
(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 "i" *Form "-" (: id)))
(if (able)
((if (: img) <image> <submit>)
(eval (: lbl))
Var NIL (: js) )
((if (: img) <image> <submit>)
(or (eval (: alt)) (eval (: lbl)))
Var T (: js) ) ) ) )
(dm act> ()
(and (able) (eval (: act))) )
(class +OnClick)
# onclick
(dm T (Exe . @)
(=: onclick Exe)
(pass extra) )
(dm show> (Var)
(<js> (list (cons 'onclick (eval (: onclick))))
(extra Var) ) )
(class +Drop)
# "drop" drop
(dm T (Fld . @)
(=: "drop" Fld)
(pass extra) )
(dm show> (Var)
(<js>
(quote
("ondragenter" . "doDrag(event)")
("ondragover" . "doDrag(event)")
("ondrop" . "doDrop(this,event)") )
(extra Var) ) )
(dm act> ()
(when (able)
(=: drop
(and
(or *Drop (val> (eval (: "drop"))))
(tmp @) ) )
(extra)
(off *Drop) ) )
(class +JS)
(dm T @
(=: js T)
(pass extra) )
(class +Auto +JS)
# auto
(dm T (Fld Exe . @)
(=: auto (cons Fld Exe))
(pass super) )
(dm act> ()
(when (able)
(=: home auto
(cons
(eval (car (: auto)))
(eval (cdr (: auto))) ) )
(extra) ) )
# Chart prefix
(class +Stop)
(dm scroll> (N)
(when (find '((F) (isa '+Auto F)) (: home gui))
(=: home auto (cons @)) )
(extra N) )
(class +DnButton +Tiny +Rid +JS +Able +Button)
(dm T (Exe Lbl)
(super
'(> (length (chart 'data)) (chart 'ofs))
(or Lbl ">")
(list 'scroll> (lit *Chart) Exe) ) )
(de jsDn (I)
(with (get (: chart) I)
(and
(: data)
(> (length @) (: ofs))
(scroll> This 1) ) ) )
(class +UpButton +Tiny +Rid +JS +Able +Button)
(dm T (Exe Lbl)
(super
'(> (chart 'ofs) 1)
(or Lbl "<")
(list 'scroll> (lit *Chart) (list '- Exe)) ) )
(de jsUp (I)
(with (get (: chart) I)
(when (> (: ofs) 1)
(scroll> This -1) ) ) )
(class +GoButton +Tiny +Rid +JS +Able +Button)
(dm T (Exe Lbl)
(super
(list 'and
(list '>= '(length (chart 'data)) Exe)
(list '<> '(chart 'ofs) Exe) )
Lbl
(list 'goto> (lit *Chart) Exe) ) )
(de scroll (N Flg)
(when Flg
(gui '(+Tip +GoButton) ,"Go to first line" 1 "|<") )
(gui '(+Tip +UpButton) ,"Scroll up one page" N "<<")
(gui '(+Tip +UpButton) ,"Scroll up one line" 1)
(gui '(+Tip +DnButton) ,"Scroll down one line" 1)
(gui '(+Tip +DnButton) ,"Scroll down one page" N ">>")
(when Flg
(gui '(+Tip +GoButton) ,"Go to last line"
(list '- '(length (chart 'data)) (dec N))
">|" )
(<nbsp>)
(gui '(+View +TextField)
'(let? Len (gt0 (length (chart 'data)))
(pack
(chart 'ofs)
"-"
(min Len (dec (+ (chart 'ofs) (chart 'rows))))
" / "
Len ) ) ) ) )
# Insert empty row
(class +InsRowButton +Tiny +JS +Able +Tip +Button)
(dm T ()
(super '(nth (: chart 1 data) (row)) ,"Insert empty row" "<"
'(set> (: chart 1)
(insert (row) (val> (: chart 1))) ) )
(=: chg T) )
# Delete row
(class +DelRowButton +Tiny +JS +Able +Tip +Button)
# exe del
(dm T (Exe Txt)
(=: exe Exe)
(=: del Txt)
(super '(nth (: chart 1 data) (row)) ,"Delete row" "x"
'(if (or (: home del) (not (curr)))
(_delRow (: exe))
(ask (if (: del) (eval @) ,"Delete row?")
(with (: home btn)
(or *AlwaysAsk (=: home del T))
(_delRow (: exe)) ) ) ) )
(=: chg T) )
(de _delRow (Exe)
(eval Exe)
(set> (: chart 1)
(remove (row) (val> (: chart 1))) ) )
# Move row up
(class +BubbleButton +Tiny +JS +Able +Tip +Button)
# exe
(dm T (Exe)
(=: exe Exe)
(super
'(>= (length (: chart 1 data)) (row) 2)
,"Shift row up"
"\^"
'(let L (val> (: chart 1))
(eval (: exe))
(set> (: chart 1)
(conc
(cut (row -2) 'L)
(and (cadr L) (cons @))
(and (car L) (cons @))
(cddr L) ) ) ) )
(=: chg T) )
(class +ClrButton +JS +Tip +Button)
# clr
(dm T (Lbl Lst . @)
(=: clr Lst)
(pass super ,"Clear all input fields" Lbl
'(for X (: clr)
(if (atom X)
(clr> (field X))
(set> (field (car X)) (eval (cdr X))) ) ) ) )
(class +ShowButton +Button)
(dm T (Flg Exe)
(let F (tmp (basename *Url) "=")
(super ,"Show" (list 'out F Exe))
(=: home show F)
(and Flg (out F (eval 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 +Radio +field) # Inited by Tomas Hlavaty <kvietaag@seznam.cz>
# grp rad lbl
# (grp rad [lbl])
(dm T (Grp Rad Lbl)
(super)
(=: grp (if Grp (field @) This))
(=: rad Rad)
(=: lbl Lbl) )
(dm show> (Var)
(showFld
(<radio>
(cons '*Gui (: grp id))
(: rad)
(not (able)) ) ) )
(dm js> ()
(pack
(ht:Fmt (: rad))
"&" (= (: rad) (str> (: grp)))
(unless (able) "&=") ) )
(dm set> (Val Dn)
(when (== This (: grp))
(super Val Dn) ) )
(class +TextField +field)
# dx dy lst lbl lim align
# ([dx [dy] [lbl]])
# ([lst [lbl]])
(dm T (X Y Z)
(nond
((num? X)
(=: lst X)
(=: lbl Y) )
((num? Y)
(=: dx X)
(=: lbl Y) )
(NIL
(=: dx X)
(=: dy Y)
(=: lbl Z) ) )
(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
'(("X")
(cond
((atom "X") (eval "X"))
((pair (cdr "X"))
(cons
(val (car "X"))
(cadr "X")
(val (cdr @)) ) )
(T (cons (val (car "X")) (val (cdr "X")))) ) )
@ )
S (str> This) )
(<select>
(if (or (member S L) (assoc S L))
L
(cons S L) )
Var
(not (able)) ) ) )
(T
(<style> (cons 'id (pack "i" *Form "-" (: id)))
(<span> *Style
(if (str> This) (ht:Prin @) (<nbsp>)) ) ) ) ) ) )
(class +LinesField +TextField)
(dm set> (Val Dn)
(super (glue "\n" Val) Dn) )
(dm val> ()
(split (chop (super)) "\n") )
(class +ListTextField +TextField)
# split
(dm T (Lst . @)
(=: split (or Lst '(" " "\t" "\n")))
(pass super) )
(dm set> (Val Dn)
(super (glue (car (: split)) Val) Dn) )
(dm val> ()
(extract
'((L) (pack (clip L)))
(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))) ) )
# Color picker
(class +RgbPicker +field)
(dm show> (Var)
(showFld
(<rgb> Var (not (able))) ) )
# Symbol fields
(class +SymField +TextField)
(dm val> ()
(let S (super)
(and (<> "-" S) (intern S)) ) )
(dm set> (Val Dn)
(super (and Val (name @)) 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)
(format
(or (sub? *Sep0 S) (pack S *Sep0))
(: scl)
*Sep0
*Sep3 ) ) )
(class +AtomField +Mono +TextField)
(dm set> (Val Dn)
(super
(if (num? Val)
(align (: dx) (format Val))
Val )
Dn ) )
(dm val> ()
(let S (super)
(or (format S) S) ) )
(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 (expDat @))
,"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 ($tim @))
,"Bad time format" ) )
(class +Img +gui)
# img alt url dx dy
(dm T (Alt Url DX DY)
(=: alt Alt)
(=: url Url)
(=: dx DX)
(=: dy DY)
(super) )
(dm js> ()
(pack
(ht:Fmt (sesId (or (: img) *No.png))) "&"
(eval (: alt)) "&"
(and (eval (: url)) (ht:Fmt (sesId @))) ) )
(dm show> (Var)
(showFld
(<img>
(or (: img) *No.png)
(eval (: alt))
(eval (: url))
(: dx)
(: dy) ) ) )
(dm set> (Val Dn)
(=: img Val) )
(dm val> ()
(: img) )
(class +Icon)
# icon url
(dm T (Exe Url . @)
(=: icon Exe)
(=: url Url)
(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 (eval (: url)))
(prinl "</td></table>") )
(class +FileField +TextField)
# file org
(dm T (Exe . @)
(=: file Exe)
(pass super) )
(dm set> (Val Dn)
(and
(<> Val (: org))
(eval (: file))
(ctl @ (out @ (prin (=: org Val)))) )
(super Val Dn) )
(dm upd> ()
(set> This
(=: org
(let? F (eval (: file))
(and
(info F)
(ctl (pack "+" F)
(in F (till NIL T)) ) ) ) ) ) )
(dm file> (Exe)
(=: file Exe)
(upd> This) )
(class +Url)
# url
(dm T (Fun . @)
(=: url Fun)
(pass extra) )
(dm js> ()
(if2 (or (: dx) (: lst)) (txt> This (val> This))
(pack (extra) "&*" (ht:Fmt (sesId *Go.png)) "&" (ht:Fmt (sesId ((: url) @))))
(pack (extra) "&*" (ht:Fmt (sesId *No.png)) "&")
(pack (ht:Fmt @) "&+" (ht:Fmt (sesId ((: url) @))))
(extra) ) )
(dm show> (Var)
(cond
((or (: dx) (: lst))
(prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>")
(extra Var)
(prin "</td><td title=\"-->\">")
(if (txt> This (val> This))
(<img> *Go.png 'url ((: url) @))
(<img> *No.png) )
(prinl "</td></table>") )
((txt> This (val> This))
(showFld (<href> @ ((: url) @))) )
(T (extra Var)) ) )
(class +HttpField +Url +TextField)
(dm T @
(pass super
'((S) (or (sub? "://" S) (pack "https://" S))) ) )
(class +MailField +Url +TextField)
(dm T @
(pass super '((S) (pack "mailto:" S))) )
(class +TelField +Url +TextField)
(dm T @
(pass super '((S) (pack "tel:" S))) )
(dm txt> (Val)
(telStr Val) )
(dm set> (Val Dn)
(super (telStr Val) Dn) )
(dm val> ()
(expTel (super)) )
(dm chk> ()
(and
(str> This)
(not (expTel @))
,"Bad phone number format" ) )
(class +SexField +Map +TextField)
(dm T (Lbl)
(super
'((,"male" . T) (,"female" . 0))
'(NIL ,"male" ,"female")
Lbl ) )
### GUI charts ###
(class +Chart)
# home gui rows cols ofs lock put get data
# (cols [put [get]])
(dm T (N Put Get)
(setq *Chart This)
(queue (prop (=: home *App) 'chart) 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> ()
(and
(or (: rid) (: home able))
(not (: lock))
(let I (: ofs)
(map
'((G D)
(set D
(trim
((: get)
(mapcar 'val> (car G))
(car D)
(car G)
I ) ) )
(mapc 'set>
(car G)
((: put) (car D) I)
T )
(inc 'I) )
(: gui)
(nth
(=: data
(need (- 1 I (: rows)) (: data)) )
I ) )
(=: data (trim (: data))) ) ) )
(dm scroll> (N)
(get> This)
(unless (gt0 (inc (:: ofs) N))
(=: ofs 1) )
(put> This) )
(dm goto> (N)
(get> This)
(=: ofs (max 1 N))
(put> This) )
(dm find> ("Fun")
(get> This)
(let "D" (cdr (nth (: data) (: ofs)))
(=: ofs
(if (find "Fun" "D")
(index @ (: data))
1 ) ) )
(put> This) )
(dm txt1> (I Lst)
(map
'((G D)
(prin
(txt> (car G) (car D))
(if (cdr G) "\t" "\n") ) )
(: gui 1)
((: put) Lst I) ) )
(dm txt> ()
(for (I . L) (: data)
(txt1> This I L) ) )
(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 (val> This) (cons Lst))) )
(dm clr> ()
(set> This) )
(dm val> ()
(get> This)
(: data) )
(dm init> ()
(upd> This) )
(dm upd> ())
(dm chk> ())
(class +Chart1 +Chart)
# (cols)
(dm T (N)
(super N list car) )
### DB GUI ###
(de newUrl @
(prog1
(pass new!)
(lock (setq *Lock @))
(apply url (url> @ 1)) ) )
(de sortButton (@Var . @Fun)
(gui '(+Tiny +JS +Button) "v"
(fill
'(put!> (: home obj) '@Var
(by '@Fun sort (: home obj @Var)) ) ) )
(gui '(+Tiny +JS +Button) "\^"
(fill
'(put!> (: home obj) '@Var
(flip (by '@Fun sort (: home obj @Var))) ) ) ) )
# (choDlg Dst Ttl Rel [Hook] [((+XyzField) ..) Exe Able])
(de choDlg (Dst Ttl Rel . @)
(let
(Hook (and (meta (cdr Rel) (car Rel) 'hook) (next))
Fld
(or (next)
(if Hook
(list '(+DbHint +TextField) Rel (lit Hook) 40)
(list '(+DbHint +TextField) Rel 40) ) )
Gui
(if (next)
(list '(+ObjView +TextField) @)
(list (list '+ObjView (last (car Fld))) (list ': (car Rel))) )
Able (if (args) (next) T) )
(diaform '(Dst Ttl Rel Hook Fld Gui Able)
(apply gui
(cons
(cons '+Focus '+Var (car Fld))
(cdr (or (assoc Rel *Cho) (push '*Cho (list Rel NIL))))
(cdr Fld) ) )
(searchButton '(init> (: home query)))
(gui 'query '(+DbChart) (cho)
'(search
(val> (: home gui 1))
(list (list (car Rel) (last Rel) Hook)) )
2 '((Obj) (list Obj Obj)) )
(<table> 'chart
(pack
(format
(or (get (or Hook *DB) (last Rel) 0) 0)
NIL NIL *Sep3 )
" "
Ttl )
'((btn) NIL)
(do (cho)
(<row> (alternating)
(gui 1 '(+DstButton) Dst)
(apply gui Gui 2) ) ) )
(<spread>
(scroll (cho))
(if (meta (cdr Rel) (car Rel) 'hook)
(newButton Able Dst (cdr Rel)
(meta (cdr Rel) (car Rel) 'hook)
Hook
(car Rel)
(let? Val (val> (: home gui 1))
(unless (db (car Rel) (last Rel) Hook Val)
Val ) ) )
(newButton Able Dst (cdr Rel)
(car Rel)
(let? Val (val> (: home gui 1))
(unless (db (car Rel) (last Rel) Val)
Val ) ) ) )
(cancelButton) ) ) ) )
(de choTtl (Ttl X . @)
(pack
(format
(if (next)
(with (or (get @ X) (meta @ X))
(count (tree (: var) (: cls) (next))) )
(or (get *DB X 0) 0) )
NIL NIL *Sep3 )
" "
Ttl ) )
(de cho ()
(if (: diaform) 16 8) )
# 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 +Force +Tip)
# save
(dm T (Exe)
(super
'(nor (: home able) (lock (: home obj)))
'(if (: home able)
,"Release exclusive write access for this object"
,"Gain exclusive write access for this object" )
'(if (: home able) ,"Done" ,"Edit")
'(if (: home able)
(when (able)
(eval (: save))
(unless (pair *Err)
(rollback)
(=: home lock (off *Lock)) ) )
(=: home lock (tryLock (: home obj))) ) )
(=: save Exe) )
(de tryLock (Obj)
(if (lock Obj)
(nil
(error (text ,"Currently edited by '@2' (@1)" @ (cdr (lup *Users @)))) )
(let *Run NIL
(sync)
(tell) )
(setq *Lock Obj) ) )
(de onDone (Exe)
(for This (: gui)
(and (isa '+Edit This) (=: save Exe)) ) )
(de editButton (Able Exe)
(<style> (and (: able) "edit")
(gui '(+AO +Focus +Edit +Button) Able Exe) ) )
(de searchButton (Exe)
(gui '(+Rid +JS +Tip +Button) ,"Start search" ,"Search" Exe) )
(de resetButton (Lst)
(gui '(+Rid +Force +ClrButton) T ,"Reset" Lst) )
(de newButton (Able Dst . Args)
(gui '(+Rid +Able +Close +Tip +Button) Able ,"Create new object" ',"New"
(nond
(Dst (cons 'newUrl Args))
((pair Dst)
(list 'set> (lit Dst) (cons 'new! Args)) )
(NIL
(list 'prog (list '=: 'obj (cons 'new! Args)) Dst) ) ) ) )
# Clone object in form
(de cloneButton (Able)
(gui '(+Rid +Able +Tip +Button) (or Able T)
,"Create a new copy of this object"
,"New/Copy"
'(apply url
(url>
(prog1
(clone!> (: home obj))
(lock (setq *Lock @)) )
1 ) ) ) )
# Delete object in form
(de delButton (Able @Txt)
(gui '(+Force +Rid +Able +Tip +Button) T
(list 'and '(or (: home able) (: home obj T)) Able)
'(if (: home obj T)
,"Mark this object as \"not deleted\""
,"Mark this object as \"deleted\"" )
'(if (: home obj T) ,"Restore" ,"Delete")
(fill
'(nond
((: home obj T)
(ask (text ,"Delete @1?" @Txt)
(lose!> (: home top 1 obj))
(rollback)
(=: home lock (off *Lock)) ) )
((keep?> (: home obj))
(ask (text ,"Restore @1?" @Txt)
(keep!> (: home top 1 obj)) ) )
(NIL
(note ,"Restore"
(mapcar
'((X) (text "'@1' -- @2" (car X) (cdr X)))
@ ) ) ) ) ) ) )
# Relations
(class +/R +Able)
# erVar erObj
(dm T (Lst . @)
(=: erVar (car Lst))
(=: erObj (cdr Lst))
(pass super
'(and (eval (: erObj)) (not (get @ T))) ) )
(dm upd> ()
(set> This (get (eval (: erObj)) (: erVar))) )
# Entity/Relation
(class +E/R +/R)
# er
(dm set> (Val Dn)
(=: er Val)
(and
(not (: lock))
(eval (: erObj))
(put!> @ (: erVar) Val) )
(extra Val Dn) )
(dm val> ()
(let Val (extra)
(if (= Val (: er))
(get (eval (: erObj)) (: erVar))
Val ) ) )
(dm chk> ()
(or
(extra)
(and
(eval (: erObj))
(mis> @ (: erVar) (val> This)) ) ) )
# Runtime relations
(de erVar (Var Exe . @)
(let *Class (last (type (eval Exe)))
(unless (get *Class Var)
(put *Class Var (new (next) Cur (rest))) ) ) # rel
(cons Var Exe) )
# +Swap relations
(class +Swp)
(dm set> (Val Dn)
(extra
(if (ext? Val) (val Val) Val)
Dn ) )
(dm val> ()
(let Val (extra)
(if (ext? Val) (val Val) Val) ) )
(class +Swap/R +Swp +E/R)
# Subobject relation
(class +SubE/R +E/R)
# sub
(dm T (Lst . @)
(pass super
(cons
(++ Lst)
(append '(: home obj) (cons (car Lst))) ) )
(=: sub Lst)
(=: able (bool (: able))) )
(dm set> (Val Dn)
(when (and Val (not (eval (: erObj))))
(dbSync)
(put> (: home obj)
(: sub 1)
(new (or (meta (: sub -1) 'Dbf 1) 1) (: sub -1)) )
(commit 'upd) )
(super Val Dn) )
(class +BlobField +/R +TextField)
# org
(dm set> (Val Dn)
(and
(not (: lock))
(<> Val (: org))
(let? Obj (eval (: erObj))
(protect
(when (put!> Obj (: erVar) (bool Val))
(out (blob Obj (: erVar))
(prin (=: org Val)) )
(blob+ Obj (: erVar)) ) ) ) )
(super Val Dn) )
(dm upd> ()
(set> This
(=: org
(let? Obj (eval (: erObj))
(when (get Obj (: erVar))
(in (blob Obj (: erVar))
(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)
(and
(eval (: erObj))
(set!> @ Val) )
(super Val Dn) )
(class +obj)
# msg obj
# ([T|msg] ..)
(dm T ()
(let A (next)
(if (atom A)
(prog (=: msg A) (next))
(=: msg 'url>)
A ) ) )
(dm js> ()
(if (=T (: msg))
(extra)
(if2 (or (: dx) (: lst)) (try (: msg) (: obj) 1 This)
(pack (extra) "&*" (ht:Fmt (sesId *Go.png)) "&" (ht:Fmt (sesId (mkUrl @))))
(pack (extra) "&*" (ht:Fmt (sesId *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 title=\"-->\">")
(if (try (: msg) (: obj) 1 This)
(<img> *Go.png 'obj (mkUrl @))
(<img> *No.png) )
(prinl "</td></table>") )
((try (: msg) (: obj) 1 This)
(showFld (<href> (nonblank (str> This)) (mkUrl @))) )
(T (extra Var)) ) )
(class +hintObj +hint +obj)
# objVar objTyp objHook
(dm hint> (Str)
(dbHint (extra Str)
(: objVar)
(last (: objTyp))
(eval (: objHook)) ) )
(class +Obj +hintObj)
# objVar objTyp objHook
# ([T|msg] (var . typ) [hook] [T] ..)
(dm T @
(let A (super)
(=: objVar (car A))
(=: objTyp (cdr A)) )
(when (meta (: objTyp) (: objVar) 'hook)
(=: objHook (next)) )
(let A (next)
(pass extra
(if (=T A)
(cons NIL
(if (meta (: objTyp) (: objVar) 'hook)
(collect (: objVar) (last (: objTyp)) (eval (: objHook)) NIL T (: objVar))
(collect (: objVar) (last (: objTyp)) NIL T (: objVar)) ) )
A ) ) ) )
(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 Val (extra)
(cond
((and (: obj) (not (ext? @))) Val)
((= Val (get (: obj) (: objVar)))
(: obj) )
((: objTyp)
(=: obj
(if (meta (: objTyp) (: objVar) 'hook)
(db (: objVar) (last (: objTyp)) (eval (: objHook)) Val)
(db (: objVar) (last (: objTyp)) Val) ) ) )
(T Val) ) ) )
(dm chk> ()
(or
(extra)
(let? S (str> This)
(and
(: objTyp)
(not (val> This))
(<> "-" S)
,"Data not found" ) ) ) )
(class +Obj2 +Obj)
# objVar2
(dm T @
(=: objVar2 (next))
(pass super) )
(dm hint> (Str)
(let L
(make
(for S (dbHint Str (: objVar2) (last (: objTyp)))
(for Obj (collect (: objVar2) (last (: objTyp)) S)
(link (pack (get Obj (: objVar)) " — " S)) )
(T (nth (made) 36)) ) )
(if
(if (meta (: objTyp) (: objVar) 'hook)
(db (: objVar) (last (: objTyp)) (eval (: objHook)) (format Str))
(db (: objVar) (last (: objTyp)) (format Str)) )
(cons (pack Str " — " (get @ (: objVar2))) L) # Dash
L ) ) )
(dm str> ()
(let? S (extra)
(let (L (split (chop S) " ") N (format (car L)))
(format
(nond
(N # Text
(get
(db (: objVar2) (last (: objTyp)) S)
(: objVar) ) )
((cdr L) N) # Nr
((= '("—") (cadr L)) # Nr Text
(get
(db (: objVar2) (last (: objTyp)) S)
(: objVar) ) )
((<> # Nr — Text
(glue " " (cddr L))
(get
(if (meta (: objTyp) (: objVar) 'hook)
(db (: objVar) (last (: objTyp)) (eval (: objHook)) N)
(db (: objVar) (last (: objTyp)) N) )
(: objVar2) ) )
N ) ) ) ) ) )
(class +ObjVal +hintObj)
# objVar objTyp hook objHook
# ([T|msg] (var . typ) [hook] ..)
(dm T @
(let A (super)
(=: objVar (car A))
(=: objTyp (cdr A)) )
(when (=: hook (meta (: objTyp) (: objVar) 'hook))
(=: objHook (next)) )
(pass extra) )
(dm txt> (Obj)
(if (ext? Obj)
(get Obj (: objVar))
Obj ) )
(dm set> (Obj Dn)
(extra
(get (=: obj Obj) (: objVar))
Dn ) )
(dm val> ()
(when (able)
(let Val (extra)
(nond
(Val
(and (: obj) (put!> @ (: objVar) NIL))
(=: obj NIL) )
((: obj)
(dbSync)
(=: obj (new (or (meta (: objTyp) 'Dbf 1) 1) (: objTyp)))
(and
(: hook)
(nT @)
(put> (: obj) (: hook) (eval (: objHook))) )
(put> (: obj) (: objVar) Val)
(commit 'upd) )
(NIL (put!> @ (: objVar) Val)) ) ) )
(: obj) )
(class +ObjVar +obj)
# objVar
(dm T (Var . @)
(=: objVar Var)
(=: msg 'url>)
(pass extra) )
(dm set> (Obj Dn)
(extra
(get (=: obj Obj) (: objVar))
Dn ) )
(dm val> ()
(let? Obj (: obj)
(and (able) (put!> Obj (: objVar) (extra)))
Obj ) )
(class +ObjView +obj)
# disp obj
# ([T|msg] exe ..)
(dm T @
(=: disp (super))
(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) )
### Incremental charts ###
(class +stepChart +Chart)
# iniR iniQ query
# (iniR iniQ cols [put [get]])
(dm T (R Q . @)
(=: iniR R)
(=: iniQ Q)
(pass super) )
(dm query> (Q)
(=: query Q)
(set> This) )
(dm init> ()
(query> This (eval (: iniQ))) )
(dm put> ()
(while
(and
(> (: ofs) (- (length (: data)) (max (: rows) (: iniR))))
(step> This) )
(queue (:: data) @) )
(super) )
# DB search chart
(class +DbChart +stepChart)
(dm step> ()
(search (: query)) )
(dm txt> ()
(for ((I . Q) (eval (: iniQ)) (search Q))
(txt1> This I @) ) )
(dm all> ()
(make
(for (Q (eval (: iniQ)) (search Q))
(link @) ) ) )
(dm clr> ()
(query> This NIL) )
# DB query chart
(class +QueryChart +stepChart)
(dm step> ()
(
(dm txt> ()
(for ((I . Q) (eval (: iniQ)) (prove Q))
(txt1> This I (
(dm all> ()
(make
(for (Q (eval (: iniQ)) (prove Q))
(link (
(dm clr> ()
(query> This (fail)) )
# Tree traversal chart
(class +TreeChart +stepChart)
(dm step> ()
(and (step (: query)) (cons @@ @)) )
(dm txt> ()
(for ((I . Q) (eval (: iniQ)) (step Q))
(txt1> This I (cons @@ @)) ) )
(dm all> ()
(make
(for (Q (eval (: iniQ)) (step Q))
(link (cons @@ @)) ) ) )
(dm clr> ()
(query> This NIL) )
(private) (Attr Var H1 Rows Gui Sep H2 Cols Put Get Prg Len R)
# 3D-Chart (list of bags with list of bags)
(de bagBag (Attr Var H1 Rows Gui Sep H2 Cols Put Get . Prg)
(let Len (length Gui)
(<grid> 3
(prog
(put
(gui '(+E/R +Chart) (cons Var '(: home obj)) (+ 2 Len)
'((L I)
(when (= I (+ (format (: home radio)) (: ofs)))
(unless (= I (: radio))
(=: radio I)
(set> (cadr (memq This (: home chart)))
(get L (inc (: gf 1))) ) ) )
(mapcar
'((F) (if F (++ L) (car L)))
(: gf -1) ) )
'((L D)
(conc
(filter prog2 L (: gf -1))
(nth D (inc (: gf 1))) ) ) )
'gf (cons (cnt car Gui) (mapcar car Gui)) )
(<table> Attr NIL H1
(macro
(for R (range 0 (dec Rows))
(<row> NIL
^ (mapcar cdr Gui)
(gui (inc Len) '(+Able +DelRowButton)
'(nor
(= (row) (: chart 1 radio))
(>= (: chart 1 radio) (length (: chart 1 data))) )
'(=: chart 1 radio NIL) )
(gui (+ 2 Len) '(+BubbleButton) '(=: chart 1 radio NIL))
(if (=0 R)
(gui '(+Rid +Init +Var +Radio) "0" (:: radio) NIL "0")
(gui '(+Rid +Radio) (* R (- -3 Len)) (format R)) ) ) ) )
(<row> NIL (scroll Rows T) - -) ) )
(run Sep)
(prog
(gui '(+Init +Set +Chart)
(get (: obj) Var 1
(length (meta (: obj) Var 'bag)) )
'((Lst)
(=: ctl
(car (prior (memq This (: home chart)) (: home chart))) )
(=: pos
(or
(+ (format (: home radio)) (: ctl ofs))
1 ) )
(when (: home able)
(put!> (: home obj) (: ctl erVar)
(let L (get (: home obj) (: ctl erVar))
(conc
(cut (dec (: pos)) 'L)
(list
(conc
(need (- (: ctl gf 1))
(head (: ctl gf 1) (++ L)) )
(list Lst) ) )
L ) ) ) )
Lst )
Cols
Put
Get )
(<table> Attr NIL H2 (run Prg)) ) ) ) )
(private) (Lst X)
# Form object
(de <id> Lst
(idObj Lst) )
(de idObj (Lst)
(with (if *PRG (: obj) (=: obj *ID))
(and (: T) (prin "["))
(for X (if (=T (car Lst)) (cdr Lst) Lst)
(if (pair (setq X (eval X)))
(<$> (cdr X) (car X))
(ht:Prin X) ) )
(and (: T) (prin "]")) )
(=: able
(cond
((: obj T))
((not (: obj)))
((=T (car Lst)) T)
((== *Lock (: obj)) (=: lock (: obj)) T)
(*Lock (rollback) (=: lock (off *Lock))) ) ) )
(private) (Able Txt Del Dlg Var X Hook Msg Exe Prg)
(de panel (Able Txt Del Dlg Var X Hook Msg Exe . Prg)
(unless (eval Able)
(when *Lock
(rollback)
(=: lock (off *Lock)) )
(=: able) )
(<spread>
(editButton Able Exe)
(run Prg 1)
(delButton
(cond
((=T Able) Del)
((=T Del) Able)
((and Able Del) (list 'and Able Del)) )
(list 'text Txt
(if (pair Var)
(list 'with '(: home obj) (car Var))
(list ': 'home 'obj Var) ) ) )
(choButton Dlg)
(when X
(if (pair X)
(stepBtn X Msg)
(stepBtn (fin Var) X Hook Msg) ) ) )
(--) )
(private) (Entity Cho Var X Able Del Lst Prg)
# Standard ID form
(de idForm (Entity Cho Var X Able Del Lst . Prg)
(ifn *ID
(prog
(<h3> NIL ,"Select" " " Entity)
(form 'dialog
(if (pair Cho)
(eval @)
(choDlg NIL Cho (list (fin Var) X)) ) ) )
(form NIL
(<h3> NIL Entity ": " (idObj Lst))
(panel Able (pack Entity " '@1'") Del
(or
(pair Cho)
(list 'choDlg NIL (lit Cho) (lit (list (fin Var) X))) )
Var X
(and
(atom X)
(or (get X (fin Var) 'hook) (meta X (fin Var) 'hook))
(get (: obj) @) ) )
(run Prg) ) ) )
(private) (Msg Env X)
### Undo / Redo ###
(de change (Msg Env . X)
(set> (: home undo)
(cons
(cons Msg Env X)
(val> (: home undo)) ) )
(set> (: home redo))
(bind Env (run (cdr X))) )
(class +todoButton +Able +Tip +Button)
# todo
(dm T (Tip Lbl Exe)
(super '(val> This)
(list 'and '(val> This) (list 'text Tip '(caar @)))
Lbl
Exe ) )
(dm set> (Val Dn)
(=: todo Val) )
(dm val> ()
(: todo) )
(class +UndoButton +todoButton)
(dm T ()
(super ,"Undo: '@1'" ,"Undo"
'(let U (val> This)
(set> (: home redo)
(cons (car U) (val> (: home redo))) )
(set> This (cdr U))
(bind (cadar U)
(eval (caddar U)) ) ) )
(=: home undo This) )
(class +RedoButton +todoButton)
(dm T ()
(super ,"Redo: '@1'" ,"Redo"
'(let R (val> This)
(set> (: home undo)
(cons (car R) (val> (: home undo))) )
(set> This (cdr R))
(bind (cadar R)
(run (cdddar R)) ) ) )
(=: home redo This) )
### Debug ###
`*Dbg
(allow "!console")
(de console @ # JS: lisp(null, "console", "Message") (msg (cons 'console (rest)))
(respond) )
(noLint 'gui)
(noLint 'choDlg 'gui)
(noLint 'choDlg 'btn)
(noLint 'jsForm 'action)