picoLisp/COPYING0000644000175000017500000000206611430515775012007 0ustar abuabuPicoLisp Copyright (c) Software Lab. Alexander Burger Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. picoLisp/pil0000755000175000017500000000007610476737204011467 0ustar abuabu#!/bin/sh exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @ext.l "$@" picoLisp/lib.l0000644000175000017500000003003512576240641011673 0ustar abuabu# 16sep15abu # (c) Software Lab. Alexander Burger (de task (Key . Prg) (nond (Prg (del (assoc Key *Run) '*Run)) ((num? Key) (quit "Bad Key" Key)) ((assoc Key *Run) (push '*Run (conc (make (when (lt0 (link Key)) (link (+ (eval (pop 'Prg) 1))) ) ) (ifn (sym? (car Prg)) Prg (cons (cons 'job (cons (lit (make (while (atom (car Prg)) (link (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) Prg ) ) ) ) ) ) ) (NIL (quit "Key conflict" Key)) ) ) (de forked () (let N (caar *Run) (when (gt0 N) (push '*Fork (list 'close N)) ) (push '*Fork (list 'task N)) ) ) (de timeout (N) (if2 N (assoc -1 *Run) (set (cdr @) (+ N)) (push '*Run (list -1 (+ N) '(bye))) (del @ '*Run) ) ) (de abort ("N" . "Prg") (catch 'abort (alarm "N" (throw 'abort)) (finally (alarm 0) (run "Prg")) ) ) (de macro "Prg" (run (fill "Prg")) ) (de later ("@Var" . "@Prg") (macro (task (pipe (pr (prog . "@Prg"))) (setq "@Var" (in @ (rd))) (task (close @)) ) ) "@Var" ) (de recur recurse (run (cdr recurse)) ) (de curry "Z" (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) (if2 "P" (diff "X" "P") (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) (cons "Y" (fill "Z" "P")) (list "Y" (cons 'job (lit (env @)) "Z")) (cons "Y" "Z") ) ) ) (====) ### Definitions ### (de expr ("F") (set "F" (list '@ (list 'pass (box (getd "F")))) ) ) (de subr ("F") (set "F" (getd (cadr (cadr (getd "F")))) ) ) (de undef ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (ifn "C" (prog1 (val "X") (set "X")) (prog1 (cdr (asoq "X" (val "C"))) (set "C" (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) (de redef "Lst" (let ("Old" (car "Lst") "New" (name "Old")) (set "New" (getd "Old") "Old" "New" "Old" (fill (cdr "Lst") "Old") ) "New" ) ) (de daemon ("X" . Prg) (prog1 (nond ((pair "X") (or (pair (getd "X")) (expr "X")) ) ((pair (cdr "X")) (method (car "X") (cdr "X")) ) (NIL (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) (con @ (append Prg (cdr @))) ) ) (de patch ("Lst" "Pat" . "Prg") (bind (fish pat? "Pat") (recur ("Lst") (loop (cond ((match "Pat" (car "Lst")) (set "Lst" (run "Prg")) ) ((pair (car "Lst")) (recurse @) ) ) (NIL (cdr "Lst")) (T (atom (cdr "Lst")) (when (match "Pat" (cdr "Lst")) (con "Lst" (run "Prg")) ) ) (setq "Lst" (cdr "Lst")) ) ) ) ) (====) (de cache ("Var" X . Prg) (let K (cons (char (hash X)) X) (nond (Prg (caar (idx "Var" K))) ((setq "Var" (caar (idx "Var" K T))) (set (car K) (run Prg 1)) ) ((n== "Var" (val "Var")) (set "Var" (run Prg 1)) ) (NIL (val "Var")) ) ) ) (====) ### I/O ### (de tab (Lst . @) (for N Lst (let V (next) (and (gt0 N) (space (- N (length V)))) (prin V) (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) (prinl) ) (de beep () (prin "^G") ) (de msg (X . @) (out 2 (print X) (pass prinl) (flush) ) X ) (de script (File . @) (load File) ) (de once Prg (unless (idx '*Once (file) T) (run Prg 1) ) ) (de pil @ (when (== "Pil" '"Pil") (call 'mkdir "-p" (setq "Pil" `(pack (sys "HOME") "/.pil/"))) ) (pass pack "Pil") ) (de rc (File Key . @) (ctl File (let Lst (in File (read)) (ifn (args) (cdr (assoc Key Lst)) (let Val (next) (if (assoc Key Lst) (con @ Val) (push 'Lst (cons Key Val)) ) (protect (out File (println Lst)) ) Val ) ) ) ) ) (de acquire (File) (ctl File (let P (in File (rd)) (or (= P *Pid) (unless (and P (kill P 0)) (out File (pr *Pid)) ) ) ) ) ) (de release (File) (ctl File (out File)) ) # Temporary Files (de tmp @ (unless *Tmp (push '*Bye '(call 'rm "-r" *Tmp)) (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) (call 'mkdir "-p" (setq *Tmp (pil "tmp/" *Pid "/"))) ) (pass pack *Tmp) ) ### List ### (de insert (N Lst X) (conc (cut (dec N) 'Lst) (cons X) Lst ) ) (de remove (N Lst) (conc (cut (dec N) 'Lst) (cdr Lst) ) ) (de place (N Lst X) (conc (cut (dec N) 'Lst) (cons X) (cdr Lst) ) ) (de uniq (Lst) (let R NIL (filter '((X) (not (idx 'R (cons (hash X) X) T)) ) Lst ) ) ) (de group (Lst) (make (for X Lst (if (assoc (car X) (made)) (conc @ (cons (cdr X))) (link (list (car X) (cdr X))) ) ) ) ) ### Symbol ### (de qsym "Sym" (cons (val "Sym") (getl "Sym")) ) (de loc (S X) (if (and (str? X) (= S X)) X (and (pair X) (or (loc S (car X)) (loc S (cdr X)) ) ) ) ) (de local Lst (mapc zap Lst) ) (de import Lst (for Sym Lst (unless (== Sym (intern Sym)) (quit "Import conflict" Sym) ) ) ) ### OOP ### (de class Lst (let L (val (setq *Class (car Lst))) (def *Class (recur (L) (if (atom (car L)) (cdr Lst) (cons (car L) (recurse (cdr L))) ) ) ) ) ) (de object ("Sym" "Val" . @) (putl "Sym") (def "Sym" "Val") (while (args) (put "Sym" (next) (next)) ) "Sym" ) (de extend X (setq *Class (car X)) ) # Class variables (de var X (if (pair (car X)) (put (cdar X) (caar X) (cdr X)) (put *Class (car X) (cdr X)) ) ) (de var: X (apply meta X This) ) ### Math ### (de scl ("N" . "Prg") (if "Prg" (let *Scl "N" (run "Prg")) (setq *Scl "N") ) ) # (Knuth Vol.2, p.442) (de ** (X N) # N th power of X (if (ge0 N) (let Y 1 (loop (when (bit? 1 N) (setq Y (* Y X)) ) (T (=0 (setq N (>> 1 N))) Y ) (setq X (* X X)) ) ) 0 ) ) (de accu (Var Key Val) (when Val (if (assoc Key (val Var)) (con @ (+ Val (cdr @))) (push Var (cons Key Val)) ) ) ) ### Pretty Printing ### (de pretty (X N) (setq N (abs (space (or N 0)))) (while (and (pair X) (== 'quote (car X))) (prin "'") (pop 'X) ) (cond ((atom X) (print X)) ((memq (car X) '(de dm redef)) (_pretty (spPrt (pop 'X)) (spPrt (pop 'X)) (prtty1 X N Z) ) ) ((memq (car X) '(let let?)) (_pretty (cond ((atom (car X)) (spPrt (pop 'X)) (prtty? (pop 'X) N) ) ((>= 12 (size (car X))) (prin " (") (let Z (pop 'X) (prtty2 Z NIL Z) ) (prin ")") ) (T (nlPrt N) (prin "(") (let Z (pop 'X) (prtty2 Z (+ N 3) Z) ) (prin " )") ) ) (prtty1 X N Z) ) ) ((== 'for (car X)) (_pretty (cond ((or (atom (car X)) (atom (cdar X))) (spPrt (pop 'X)) (prtty? (pop 'X) N) ) ((>= 12 (size (car X))) (spPrt (pop 'X)) ) (T (nlPrt N) (prtty0 (pop 'X) (+ 3 N)) ) ) (prtty1 X N Z) ) ) ((== 'if2 (car X)) (_pretty (when (>= 12 (size (head 2 X))) (spPrt (pop 'X)) (spPrt (pop 'X)) ) (prtty1 X N Z) ) ) ((memq (car X) '(while until do state finally co)) (prtty3 X N) ) ((>= 12 (size X)) (ifn (memq (car X) '(set setq default)) (print X) (prin "(") (let Z X (printsp (pop 'X)) (prtty2 X NIL Z) ) (prin ")") ) ) ((memq (car X) '(=: use later recur tab new)) (_pretty (space) (print (pop 'X)) (prtty1 X N Z) ) ) ((memq (car X) '(set setq default)) (_pretty (if (cdddr X) (prog (nlPrt N) (prtty2 X N Z) ) (spPrt (pop 'X)) (nlPrt1 (pop 'X) N) ) ) ) ((memq (car X) '(T NIL ! if ifn when unless case casq with catch push bind job in out ctl)) (prtty3 X N) ) (T (prtty0 X N)) ) ) (de _pretty "Prg" (prin "(") (let Z X (print (pop 'X)) (run "Prg") ) (prin " )") ) (de prtty0 (X N) (prin "(") (let Z X (pretty (pop 'X) (- -3 N)) (prtty1 X N Z) ) (prin " )") ) (de prtty1 (X N Z) (loop (NIL X) (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (nlPrt1 (pop 'X) N) ) ) (de prtty2 (X N Z) (loop (print (pop 'X)) (NIL X) (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (if N (prtty? (pop 'X) N) (space) (print (pop 'X)) ) (NIL X) (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (if N (nlPrt N) (space 2) ) ) ) (de prtty3 (X N) (prin "(") (let Z X (print (pop 'X)) (when (or (atom (car X)) (>= 12 (size (car X)))) (spPrt (pop 'X)) ) (when X (prtty1 X N Z) (space) ) ) (prin ")") ) (de prtty? (X N) (ifn (or (atom X) (>= 12 (size X))) (nlPrt1 X N) (spPrt X) ) ) (de spPrt (X) (space) (print X) ) (de nlPrt (N) (prinl) (space (+ 3 N)) ) (de nlPrt1 (X N) (prinl) (pretty X (+ 3 N)) ) (de pp ("X" C) (let *Dbg NIL (pretty (if (or C (pair "X")) (cons 'dm "X" (if (pair "X") (method (car "X") (cdr "X")) (method "X" C) ) ) (cons 'de "X" (val "X")) ) ) (prinl) "X" ) ) (de show ("X" . @) (let *Dbg NIL (setq "X" (pass get "X")) (when (sym? "X") (print "X" (val "X")) (prinl) (maps '((X) (space 3) (if (atom X) (println X) (println (cdr X) (car X)) ) ) "X" ) ) "X" ) ) (de view (X Y) (let *Dbg NIL (if (=T Y) (let N 0 (recur (N X) (when X (recurse (+ 3 N) (cddr X)) (space N) (println (car X)) (recurse (+ 3 N) (cadr X)) ) ) ) (let Z X (loop (T (atom X) (println X)) (if (atom (car X)) (println '+-- (pop 'X)) (print '+---) (view (pop 'X) (append Y (cons (if X "| " " "))) ) ) (NIL X) (mapc prin Y) (T (== Z X) (println '*)) (println '|) (mapc prin Y) ) ) ) ) ) ### Check ### # Assertions (de assert Prg (when *Dbg (cons (list 'unless (if (cdr Prg) (cons 'and Prg) (car Prg)) (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) # Unit tests (de test (Pat . Prg) (bind (fish pat? Pat) (unless (match Pat (run Prg 1)) (msg Prg) (quit "'test' failed" Pat) ) ) ) ### Debug ### `*Dbg (if (info (pil "editor")) (load (pil "editor")) (load "@lib/led.l" "@lib/edit.l") ) (load "@lib/debug.l" "@lib/lint.l") (noLint 'pretty 'Z) (noLint '_pretty 'Z) # vi:et:ts=3:sw=3 picoLisp/ext.l0000644000175000017500000000020511361351465011717 0ustar abuabu# 14apr10abu # (c) Software Lab. Alexander Burger (load "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") # vi:et:ts=3:sw=3 picoLisp/dbg.l0000644000175000017500000000040012113425011011631 0ustar abuabu# 27feb13abu # (c) Software Lab. Alexander Burger (on *Dbg) (if (info (pil "editor")) (load (pil "editor")) (load "@lib/led.l" "@lib/edit.l") ) (load "@lib/debug.l" "@lib/lint.l" "@lib/sq.l") (noLint 'later (loc "@Prg" later)) # vi:et:ts=3:sw=3 picoLisp/lib.css0000644000175000017500000001216212446314171012225 0ustar abuabu/* 23dec14abu * 17nov12jk * (c) Software Lab. Alexander Burger */ /* Lib */ .left {float: left} .right {float: right} .nofloat {float: none} .clr {clear: both} .norm {text-align: left} .align {text-align: right} .center {text-align: center} .black {color: black} .red {color: red} .green {color: green} .blue {color: blue} .yellow {color: yellow} .bold {font-weight: bold} .mono {font-family: monospace} .hidden {display: none} .em1 {width: 1em} .em2 {width: 2em} .em3 {width: 3em} .em5 {width: 5em} .em7 {width: 7em} .em10 {width: 10em} .em15 {width: 15em} .em20 {width: 20em} .em25 {width: 25em} .em30 {width: 30em} .em40 {width: 40em} .em50 {width: 50em} .em60 {width: 60em} .em70 {width: 70em} /* Defaults */ body { font-family: Arial, Helvetica, sans-serif; background-color: #f0f0f0; font-size: small; margin: 0; } img { border: 0; } fieldset { border-style: none; } input, textarea, select { font-size: small; background-color: white; } caption { padding: 0 1em; text-align: left; margin-top: 2ex; background-color: #d0d0d0; } td { white-space: nowrap; } a { text-decoration: none; } .step a { border-radius: 6px; background-color: #d0d0d0; padding: 2px 3px; } a:hover { background-color: white; } /* Navigation */ .menu { padding-top: 2ex; background-color: #d0d0d0; } .menu ul { list-style: none; padding: 0; margin: 0; } .menu .cmd1, .act1, .cmd2, .act2, .cmd3, .act3, .cmd4, .act4 { list-style-position: inside; list-style-type: circle; padding: 0 0 0 2em; } .menu .act1, .act2, .act3, .act4 { list-style-type: disc; } .menu .sub1, .top1, .sub2, .top2, .sub3, .top3, .sub4, .top4 { list-style-position: inside; padding: 0 0 0 1em; } .bar { white-space: nowrap; } .bar ul { list-style: none; padding: 0; margin: 0; } .bar li { float: left; position: relative; background-color: #d0d0d0; } .bar li ul { position: absolute; } .bar li ul li { clear: both; width: 100%; border-left: 1px solid; border-right: 1px solid; border-bottom: 1px solid; } .bar .cmd, .act, .sub, .top { z-index: 9999; padding: 6px; } .bar .act { list-style-position: inside; list-style-type: disc; } #expires { position: absolute; top: 0; right: 3px; color: red; } /* Tabulators */ .tab { margin-bottom: 1ex; } .tab td { padding: 3px 1em; border-radius: 6px 6px 0 0; } .tab .top { font-weight: bold; border-top: 1px solid; border-left: 1px solid; border-right: 1px solid; } .tab .sub { background-color: #d0d0d0; border-bottom: 1px solid; } /* Main area */ .main { padding: 1ex 0 0 2ex; } /* Charts */ .chart { width: 100%; white-space: nowrap; } .chart td { background-color: #e0e0e0; } .chart td.T, th.T { background-color: #d0d0d0; } .chart td.nil, th.nil { background-color: white; } .chart td.body, th.body { background-color: #f0f0f0; } .btn { width: 1em; } /* Buttons */ .submit { font-weight: bold; background-color: #eee; background-image: -moz-linear-gradient(top, #eee, #ccc); background-image: -o-linear-gradient(top, #eee, #ccc); background-image: -webkit-linear-gradient(top, #eee, #ccc); background-image: linear-gradient(top, #eee, #ccc); border: 1px solid #707070; border-radius: 3px; box-shadow: 0 0 1px 1px rgba(255,255,255,.8) inset, 0 1px 0 rgba(0,0,0,.3); } .submit:hover { background-image: -moz-linear-gradient(top, #fafafa, #ddd); background-image: -o-linear-gradient(top, #fafafa, #ddd); background-image: -webkit-linear-gradient(top, #fafafa, #ddd); background-image: linear-gradient(top, #fafafa, #ddd); } .submit[disabled='disabled'] { background-image: -moz-linear-gradient(top, #eee, #ccc); background-image: -o-linear-gradient(top, #eee, #ccc); background-image: -webkit-linear-gradient(top, #eee, #ccc); background-image: linear-gradient(top, #eee, #ccc); } .edit { background-color: #66ff66; background-image: -moz-linear-gradient(top, #8f8, #6f6); background-image: -o-linear-gradient(top, #8f8, #6f6); background-image: -webkit-linear-gradient(top, #8f8, #6f6); background-image: linear-gradient(top, #8f8, #6f6); } .edit:hover { background-color: #88ff88; background-image: -moz-linear-gradient(top, #cfc, #afa); background-image: -o-linear-gradient(top, #cfc, #afa); background-image: -webkit-linear-gradient(top, #cfc, #afa); background-image: linear-gradient(top, #cfc, #afa); } /* Errors */ .error { color: red; background-color: yellow; } /* Fonts */ .tiny { font-size: smaller; padding: 0; } .note, .ask { font-weight: bold; } /* Alerts */ .alert { display: inline; padding: 1ex; margin: 1ex 0 1ex 5em; background-color: yellow; border: 1px solid #888; border-radius: 6px; } .alert input { margin-top: 1ex; } /* Dialogs */ .dialog { padding: 1ex; margin: 1ex 5em 1ex 1em; border: 1px solid #888; border-radius: 6px; } /* Hints */ .hint { font-size: small; background-color: #777; } .hints { font-size: small; color: black; padding-left: 3px; padding-top: 3px; border: 1px solid; background-color: white; } picoLisp/img/go.png0000644000175000017500000000024010523275701012625 0ustar abuabuPNG  IHDR |lbKGD̿ pHYs  DIDATmA07z ̻JBrV ܪع9ThAckƠ VIENDB`picoLisp/img/no.png0000644000175000017500000000015110523275366012644 0ustar abuabuPNG  IHDR |lbKGD̿ pHYs   IDATc`,K4IENDB`picoLisp/lib/adm.l0000644000175000017500000000726612522147105012436 0ustar abuabu# 05may15abu # (c) Software Lab. Alexander Burger # *Salt *Login *Users *Perms # crypt(3) algorithm, e.g. (setq *Salt (16 . "$6$@1$")) (de passwd (Str Salt) (if *Salt `(if (== 64 64) '(native "libcrypt.so" "crypt" 'S Str (or Salt (salt))) '(ext:Crypt Str (or Salt (salt))) ) Str ) ) (de salt () (text (cdr *Salt) (randpw (car *Salt))) ) (de randpw (Len) (make (in "/dev/urandom" (do Len (link (get '`(mapcar char (conc (range (char ".") (char "9")) (range (char "A") (char "Z")) (range (char "a") (char "z")) ) ) (inc (& 63 (rd 1))) ) ) ) ) ) ) (de auth (Nm Pw Cls) (with (db 'nm (or Cls '+User) Nm) (and (: pw 0) (= @ (passwd Pw @)) This ) ) ) ### Login ### (de login (Nm Pw Cls) (ifn (setq *Login (auth Nm Pw Cls)) (msg *Pid " ? " Nm) (msg *Pid " * " (stamp) " " Nm) (tell 'hi *Pid Nm *Adr) (push1 '*Bye '(logout)) (push1 '*Fork '(del '(logout) '*Bye)) (timeout (setq *Timeout `(* 3600 1000))) ) *Login ) (de logout () (when *Login (rollback) (off *Login) (tell 'hi *Pid) (msg *Pid " / " (stamp)) (timeout (setq *Timeout `(* 300 1000))) ) ) (de hi (Pid Nm Adr) (if (and Nm (= Nm (; *Login nm)) (= Adr *Adr)) (bye) (hi2 Pid Nm) (tell 'hi2 *Pid (; *Login nm)) ) ) (de hi2 (Pid Nm) (if2 Nm (lup *Users Pid) (con @ Nm) (idx '*Users (cons Pid Nm) T) (idx '*Users @ NIL) ) ) ### Role ### (class +Role +Entity) (rel nm (+Need +Key +String)) # Role name (rel perm (+List +Symbol)) # Permission list (rel usr (+List +Joint) role (+User)) # Associated users (allow "@lib/role.l") (dm url> (Tab) (and (may RoleAdmin) (list "@lib/role.l" '*ID This)) ) ### User ### (class +User +Entity) (rel nm (+Need +Key +String)) # User name (rel pw (+Swap +String)) # Password (rel role (+Joint) usr (+Role)) # User role (rel nam (+String)) # Full Name (rel tel (+String)) # Phone (rel em (+String)) # EMail (allow "@lib/user.l") (dm url> (Tab) (and (may UserAdmin) (list "@lib/user.l" '*ID This)) ) ### Permission management ### (de permission Lst (while Lst (queue '*Perms (car Lst)) (def (pop 'Lst) (pop 'Lst)) ) ) (de may Args (mmeq Args (; *Login role perm)) ) (de must Args (unless (if (cdr Args) (mmeq @ (; *Login role perm)) *Login ) (msg *Pid " No permission: " (car Args)) (forbidden) ) ) ### GUI ### (de choUser (Dst) (choDlg Dst ,"Users" '(nm +User)) ) (de loginForm "Opt" (form NIL (when "Opt" (eval (car "Opt")) (----) ) ( 2 ,"Name" (gui 'nm '(+Focus +Able +TextField) '(not *Login) 20) ,"Password" (gui 'pw '(+Able +PwField) '(not *Login) 20) ) (--) (gui '(+Button) '(if *Login ,"logout" ,"login") '(cond (*Login (logout)) ((login (val> (: home nm)) (val> (: home pw))) (clr> (: home pw)) ) (T (error ,"Permission denied")) ) ) (when *Login ( 4) ( "bold green" (ht:Prin "'" (; *Login nm) ,"' logged in") ) ) (when "Opt" (----) (htPrin (cdr "Opt")) ) ) ) (class +PasswdField +E/R +Fmt +TextField) (dm T @ (pass super '(pw : home obj) '((V) (and V "****")) '((V) (if (= V "****") (: home obj pw 0) (passwd V (: home obj pw 0)) ) ) ) ) # vi:et:ts=3:sw=3 picoLisp/lib/app.l0000644000175000017500000000215112500754011012435 0ustar abuabu# 14mar15abu # (c) Software Lab. Alexander Burger # Exit on error (de *Err ~(as trail (for (L (trail T) L) (if (pair (car L)) (println (pop 'L)) (space 3) (println (pop 'L) (pop 'L)) ) ) (println '=======) ) (prinl *Pid " ! " (stamp) " [" *Adr " " (host *Adr) "] " *Agent) (show This) (for "X" '(*Agent *Host *Port *Url *SesId *ConId *Tab *Gui *Btn *Get *ID) (println "X" (val "X")) ) (println '*PRG *PRG (val *PRG)) (for "X" (env) (unless (== (car "X") (cdr "X")) (println (car "X") (cdr "X")) ) ) (rollback) ) # User identification (de user (Pid1 Pid2 Nm To) (nond (Pid1 (tell 'user *Pid)) (Pid2 (tell 'user Pid1 *Pid (get *Login 'nm) (/ (- *Timeout (cadr (assoc -1 *Run))) 60000) ) ) ((<> *Pid Pid1) (println Pid2 Nm To)) ) ) # Timestamp (msg *Pid " + " (stamp)) (flush) # Extend 'app' function (conc (last app) '((msg *Pid " + " (stamp) " [" *Adr " " (host *Adr) (and *Cipher (pack " / " @)) "] " *Agent)) ) # Bye message (push1 '*Bye '(and *SesId (msg *Pid " - " (stamp)))) picoLisp/lib/boss.l0000644000175000017500000000050011642573621012633 0ustar abuabu# 04oct11abu # (c) Software Lab. Alexander Burger # "boss" *Boss (unless (info (tmp "+")) (call 'mkfifo (setq "boss" (tmp "+"))) (call 'mkfifo (setq *Boss (tmp "-"))) ) (hear (open "boss")) # (boss 'sym ['any ..]) (de boss @ (out "boss" (pr (rest))) ) (de reply Exe #> any (out *Boss (pr (eval Exe))) ) picoLisp/lib/btree.l0000644000175000017500000003771712377057346013021 0ustar abuabu# 26aug14abu # (c) Software Lab. Alexander Burger # *Prune (de root (Tree) (cond ((not Tree) (val *DB)) ((atom Tree) (val Tree)) ((ext? (cdr Tree)) (get @ (car Tree))) ((atom (cdr Tree)) (get *DB (cdr Tree) (car Tree)) ) (T (get (cddr Tree) (cadr Tree) (car Tree))) ) ) # Fetch (de fetch (Tree Key) (let? Node (cdr (root Tree)) (and *Prune (idx '*Prune Node T)) (use R (loop (and *Prune (set (prop Node NIL) 0)) (T (and (setq R (rank Key (cdr (val Node)))) (= Key (car R)) ) (or (cddr R) (fin (car R))) ) (NIL (setq Node (if R (cadr R) (car (val Node)))) ) ) ) ) ) # Store (de store (Tree Key Val Dbf) (default Dbf (1 . 256)) (if (atom Tree) (let Base (or Tree *DB) (_store (or (val Base) (set Base (cons 0)))) ) (let Base (if (atom (cdr Tree)) (or (ext? (cdr Tree)) (get *DB (cdr Tree)) (put *DB (cdr Tree) (new T 0)) ) (or (get (cddr Tree) (cadr Tree)) (put (cddr Tree) (cadr Tree) (new T)) ) ) (_store (or (get Base (car Tree)) (put Base (car Tree) (cons 0)) ) ) ) ) ) (de _store (Root) (and *Prune (cdr Root) (idx '*Prune @ T)) (ifn Val (when (and (cdr Root) (_del @)) (touch Base) (cond (*Solo (zap (cdr Root))) (*Zap (push @ (cdr Root))) ) (con Root) ) (and (= Val (fin Key)) (off Val)) (if (cdr Root) (when (_put @) (touch Base) (con Root (def (new (car Dbf)) (list (car @) (cdr @)))) ) (touch Base) (con Root (def (new (car Dbf)) (list NIL (cons Key NIL Val)) ) ) (and *Prune (set (prop (cdr Root) NIL) 0)) (inc Root) ) ) ) (de _put (Top) (and *Prune (set (prop Top NIL) 0)) (let (V (val Top) R (rank Key (cdr V))) (cond (R (if (= Key (car R)) (nil (touch Top) (con (cdr R) Val)) (let X (memq R V) (if (cadr R) (when (_put @) (touch Top) (set (cdr R) (car @)) (con X (cons (cdr @) (cdr X))) (_splitBt) ) (touch Top) (con X (cons (cons Key (cons NIL Val)) (cdr X)) ) (touch Base) (inc Root) (_splitBt) ) ) ) ) ((car V) (when (_put @) (touch Top) (set V (car @)) (con V (cons (cdr @) (cdr V))) (_splitBt) ) ) (T (touch Top) (con V (cons (cons Key (cons NIL Val)) (cdr V)) ) (touch Base) (inc Root) (_splitBt) ) ) ) ) (de _splitBt () (when (and (cddddr V) (> (size Top) (cdr Dbf))) (let (N (>> 1 (length V)) X (get V (inc N))) (set (cdr X) (def (new (car Dbf)) (cons (cadr X) (nth V (+ 2 N))) ) ) (cons (if *Solo (prog (set Top (head N V)) Top) (and *Zap (push @ Top)) (def (new (car Dbf)) (head N V)) ) X ) ) ) ) # Del (de _del (Top) (and *Prune (set (prop Top NIL) 0)) (let (V (val Top) R (rank Key (cdr V))) (cond ((not R) (when (and (car V) (_del @)) (touch Top) (cond (*Solo (zap (car V))) (*Zap (push @ (car V))) ) (set V) (not (cdr V)) ) ) ((= Key (car R)) (if (cadr R) (let X (val @) (while (car X) (setq X (val @))) (touch Top) (xchg R (cadr X)) (con (cdr R) (cddr (cadr X))) (when (_del (cadr R)) (cond (*Solo (zap (cadr R))) (*Zap (push @ (cadr R))) ) (set (cdr R)) ) ) (touch Base) (dec Root) (nand (or (con V (delq R (cdr V))) (car V) ) (touch Top) ) ) ) ((cadr R) (when (_del @) (touch Top) (cond (*Solo (zap (cadr R))) (*Zap (push @ (cadr R))) ) (set (cdr R)) ) ) ) ) ) # Delayed deletion (de zap_ () (let (F (cdr *Zap) Z (pack F "_")) (cond ((info Z) (in Z (while (rd) (zap @))) (if (info F) (call 'mv F Z) (call 'rm Z) ) ) ((info F) (call 'mv F Z)) ) ) ) # Tree node count (de count (Tree) (or (car (root Tree)) 0) ) # Return first leaf (de leaf (Tree) (let (Node (cdr (root Tree)) X) (while (val Node) (setq X (cadr @) Node (car @)) ) (cddr X) ) ) # Reverse node (de revNode (Node) (let? Lst (val Node) (let (L (car Lst) R) (for X (cdr Lst) (push 'R (cons (car X) L (cddr X))) (setq L (cadr X)) ) (cons L R) ) ) ) # Key management (de minKey (Tree Min Max) (default Max T) (let (Node (cdr (root Tree)) K) (use (V R X) (loop (NIL (setq V (val Node)) K) (T (and (setq R (rank Min (cdr V))) (= Min (car R)) ) Min ) (if R (prog (and (setq X (cdr (memq R V))) (>= Max (caar X)) (setq K (caar X)) ) (setq Node (cadr R)) ) (when (>= Max (caadr V)) (setq K (caadr V)) ) (setq Node (car V)) ) ) ) ) ) (de maxKey (Tree Min Max) (default Max T) (let (Node (cdr (root Tree)) K) (use (V R X) (loop (NIL (setq V (revNode Node)) K) (T (and (setq R (rank Max (cdr V) T)) (= Max (car R)) ) Max ) (if R (prog (and (setq X (cdr (memq R V))) (>= (caar X) Min) (setq K (caar X)) ) (setq Node (cadr R)) ) (when (>= (caadr V) Min) (setq K (caadr V)) ) (setq Node (car V)) ) ) ) ) ) # Step (de init (Tree Beg End) (or Beg End (on End)) (let (Node (cdr (root Tree)) Q) (use (V R X) (if (>= End Beg) (loop (NIL (setq V (val Node))) (T (and (setq R (rank Beg (cdr V))) (= Beg (car R)) ) (push 'Q (memq R V)) ) (if R (prog (and (setq X (cdr (memq R V))) (>= End (caar X)) (push 'Q X) ) (setq Node (cadr R)) ) (and (cdr V) (>= End (caadr V)) (push 'Q (cdr V)) ) (setq Node (car V)) ) ) (loop (NIL (setq V (revNode Node))) (T (and (setq R (rank Beg (cdr V) T)) (= Beg (car R)) ) (push 'Q (memq R V)) ) (if R (prog (and (setq X (cdr (memq R V))) (>= (caar X) End) (push 'Q X) ) (setq Node (cadr R)) ) (and (cdr V) (>= (caadr V) End) (push 'Q (cdr V)) ) (setq Node (car V)) ) ) ) ) (cons (cons (cons Beg End) Q)) ) ) (de step (Q Flg) (use (L F X) (catch NIL (loop (until (cdar Q) (or (cdr Q) (throw)) (set Q (cadr Q)) (con Q (cddr Q)) ) (setq L (car Q) F (>= (cdar L) (caar L)) X (pop (cdr L)) ) (or (cadr L) (con L (cddr L))) (if ((if F > <) (car X) (cdar L)) (con (car Q)) (for (V (cadr X) ((if F val revNode) V) (car @)) (con L (cons (cdr @) (cdr L))) ) (unless (and Flg (flg? (fin (car X)))) (throw NIL (or (cddr X) (fin (car X))) ) ) ) ) ) ) ) (====) # Scan tree nodes (de scan ("Tree" "Fun" "Beg" "End" "Flg") (default "Fun" println) (or "Beg" "End" (on "End")) (let "Node" (cdr (root "Tree")) ((if (>= "End" "Beg") _scan _nacs) "Node") ) ) (de _scan ("Node") (let? "V" (val "Node") (for "X" (if (rank "Beg" (cdr "V")) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_scan (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_scan (car "V")) (cdr "V") ) (T (> (car "X") "End")) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (car "X") (or (cddr "X") (fin (car "X"))) ) ) (_scan (cadr "X")) ) ) ) (de _nacs ("Node") (let? "V" (revNode "Node") (for "X" (if (rank "Beg" (cdr "V") T) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_nacs (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_nacs (car "V")) (cdr "V") ) (T (> "End" (car "X"))) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (car "X") (or (cddr "X") (fin (car "X"))) ) ) (_nacs (cadr "X")) ) ) ) (====) # Iterate tree values (de iter ("Tree" "Fun" "Beg" "End" "Flg") (default "Fun" println) (or "Beg" "End" (on "End")) (let "Node" (cdr (root "Tree")) ((if (>= "End" "Beg") _iter _reti) "Node") ) ) (de _iter ("Node") (let? "V" (val "Node") (for "X" (if (rank "Beg" (cdr "V")) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_iter (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_iter (car "V")) (cdr "V") ) (T (> (car "X") "End")) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (or (cddr "X") (fin (car "X")))) ) (_iter (cadr "X")) ) ) ) (de _reti ("Node") (let? "V" (revNode "Node") (for "X" (if (rank "Beg" (cdr "V") T) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_reti (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_reti (car "V")) (cdr "V") ) (T (> "End" (car "X"))) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (or (cddr "X") (fin (car "X")))) ) (_reti (cadr "X")) ) ) ) # UB-Trees (de ub>= (Dim End Val Beg) (let (D (>> (- 1 Dim) 1) Pat D) (while (> End Pat) (setq Pat (| D (>> (- Dim) Pat))) ) (do Dim (NIL (>= (& Pat End) (& Pat Val) (& Pat Beg) ) ) (setq Pat (>> 1 Pat)) ) ) ) (de ubIter ("Tree" "Dim" "Fun" "X1" "X2") (let ("Node" (cdr (root "Tree")) "Lst" (val "Node") "Left" (pop '"Lst") "Beg" (ubZval (copy "X1")) "End" (ubZval (copy "X2") T) "B" (car "Beg") "E" (car "End") ) (recur ("Left" "Lst" "Beg" "End" "X") (while (setq "X" (pop '"Lst")) (cond ((> (car "X") "End") (setq "Lst" (; "Left" 0 -1) "Left" (; "Left" 0 1)) ) ((> "Beg" (car "X")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) ((ub>= "Dim" "E" (caar "X") "B") ("Fun" (cdar "X")) (recurse (; "Left" 0 1) (; "Left" 0 -1) "Beg" (car "X")) (setq "Beg" (car "X")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) (T (let ("Msb" 1 "Pat" 0 "N" 0 "Min" "B" "Max" "E" "Lo" (caar "X") "Hi" "Lo") (while (>= "Max" "Msb") (setq "Msb" (>> -1 "Msb") "Pat" (>> -1 "Pat")) # Msb 100000000 (when (= "Dim" (inc '"N")) # Pat 000100100 (inc '"Pat") (zero "N") ) ) (catch "ub" # Clr 111..111011011 (let (Top "Msb" Clr (| Top (x| "Pat" (dec "Msb")))) (loop (T (=0 (setq "Msb" (>> 1 "Msb")))) (setq "Pat" (>> 1 "Pat") Clr (| Top (>> 1 Clr)) ) (ifn (bit? "Msb" (caar "X")) (when (bit? "Msb" "Max") (ifn (bit? "Msb" "Min") # 001 (setq "Max" (- (| "Pat" "Max") "Msb") # 0111(Max) "Lo" (| "Msb" (& "Min" Clr)) ) # 1000(Min) (setq "Lo" "Min") # 011 (throw "ub") ) ) (unless (bit? "Msb" "Min") (if (bit? "Msb" "Max") # 101 (setq "Hi" (- (| "Pat" "Max") "Msb") # 0111(Max) "Min" (| "Msb" (& "Min" Clr)) ) # 1000(Min) (setq "Hi" "Max") # 100 (throw "ub") ) ) ) ) ) ) (recurse (; "Left" 0 1) (; "Left" 0 -1) "Beg" (cons "Hi" T)) (setq "Beg" (cons "Lo")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) ) ) ) ) ) ) (====) (de prune (N) (for Node (idx '*Prune) (recur (Node) (let? V (val (lieu Node)) (if (>= (inc (prop Node NIL)) N) (wipe Node) (recurse (car V)) (for X (cdr V) (recurse (cadr X)) ) ) ) ) ) (or (gt0 N) (setq *Prune N)) ) # Delete Tree (de zapTree (Node) (let? V (val Node) (zapTree (car V)) (for L (cdr V) (zapTree (cadr L)) ) (zap Node) ) ) # Check tree structure (de chkTree ("Node" "Fun") (let ("N" 0 "X") (when "Node" (recur ("Node") (let "V" (val "Node") (let "L" (car "V") (for "Y" (cdr "V") (when "L" (unless (ext? "L") (quit "Bad node link" "Node") ) (recurse "L") ) (when (>= "X" (car "Y")) (quit "Bad sequence" "Node") ) (setq "X" (car "Y")) (inc '"N") (and "Fun" (not ("Fun" (car "Y") (cddr "Y"))) (quit "Check fail" "Node") ) (setq "L" (cadr "Y")) ) (and "L" (recurse "L")) ) ) (wipe "Node") ) ) "N" ) ) # vi:et:ts=3:sw=3 picoLisp/lib/canvas.js0000644000175000017500000001710412520124411013312 0ustar abuabu/* 29apr15abu * (c) Software Lab. Alexander Burger */ var CvsReq = new XMLHttpRequest(); function renderCanvas(cvs, lst) { var ctx = cvs.getContext("2d"); var cmd, i, j; for (i = 0; i < lst.length; ++i) { switch ((cmd = lst[i])[0]) { // Sync with "@lib/canvas.l" /*** Functions ***/ case 1: // (csFillText Str X Y) ctx.fillText(cmd[1], cmd[2], cmd[3]); break; case 2: // (csStrokeLine X1 Y1 X2 Y2) ctx.beginPath(); ctx.moveTo(cmd[1], cmd[2]); ctx.lineTo(cmd[3], cmd[4]); ctx.closePath(); ctx.stroke(); break; case 3: // (csClearRect X Y DX DY) ctx.clearRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 4: // (csStrokeRect X Y DX DY) ctx.strokeRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 5: // (csFillRect X Y DX DY) ctx.fillRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 6: // (csBeginPath) ctx.beginPath(); break; case 7: // (csClosePath) ctx.closePath(); break; case 8: // (csMoveTo X Y) ctx.moveTo(cmd[1], cmd[2]); break; case 9: // (csLineTo X Y) ctx.lineTo(cmd[1], cmd[2]); break; case 10: // (csBezierCurveTo X1 Y1 X2 Y2 X Y) ctx.bezierCurveTo(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 11: // (csLine X1 Y1 X2 Y2) ctx.moveTo(cmd[1], cmd[2]); ctx.lineTo(cmd[3], cmd[4]); break; case 12: // (csRect X Y DX DY) ctx.rect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 13: // (csArc X Y R A B F) ctx.arc(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 14: // (csStroke) ctx.stroke(); break; case 15: // (csFill) ctx.fill(); break; case 16: // (csClip) ctx.clip(); break; case 17: // (csDef Key DX DY Lst), (csDef Key) if (!cvs.pre) cvs.pre = new Array(); var buf = cvs.pre[cmd[1]] = document.createElement('canvas'); if (cmd[2]) { buf.width = cmd[2]; buf.height = cmd[3]; renderCanvas(buf, cmd[4]); } else { buf.width = cvs.width; buf.height = cvs.height; buf.getContext("2d").drawImage(cvs, 0, 0); } break; case 18: // (csDraw Key X Y) var buf = cvs.pre[cmd[1]]; ctx.clearRect(cmd[2], cmd[3], buf.width, buf.height); ctx.drawImage(buf, cmd[2], cmd[3]); break; case 19: // (csDrawDots DX DY Lst) if (cmd[3]) for (j = 0; j < cmd[3].length; j += 2) ctx.fillRect(cmd[3][j], cmd[3][j+1], cmd[1], cmd[2]); break; case 20: // (csDrawImage Img X Y Lst DX DY) var img = new Image(); img.src = cmd[1]; (function (img, cmd) { img.onload = function() { if (cmd[5]) { ctx.clearRect(cmd[2], cmd[3], cmd[5], cmd[6]); ctx.drawImage(img, cmd[2], cmd[3], cmd[5], cmd[6]); } else { ctx.clearRect(cmd[2], cmd[3], img.width, img.height); ctx.drawImage(img, cmd[2], cmd[3]); } if (cmd[4]) renderCanvas(cvs, cmd[4]); } } )(img, cmd); break; case 21: // (csTranslate X Y) ctx.translate(cmd[1], cmd[2]); break; case 22: // (csRotate A) ctx.rotate(cmd[1]); break; case 23: // (csScale X Y) ctx.scale(cmd[1], cmd[2]); break; case 24: // (csSave) ctx.save(); break; case 25: // (csRestore) ctx.restore(); break; /*** Variables ***/ case 26: // (csCursor Lst) cvs.curs = cmd[1]; break; case 27: // (csFillStyle V) ctx.fillStyle = cmd[1]; break; case 28: // (csStrokeStyle V) ctx.strokeStyle = cmd[1]; break; case 29: // (csGlobalAlpha V) ctx.globalAlpha = cmd[1]; break; case 30: // (csLineWidth V) ctx.lineWidth = cmd[1]; break; case 31: // (csLineCap V) ctx.lineCap = cmd[1]; break; case 32: // (csLineJoin V) ctx.lineJoin = cmd[1]; break; case 33: // (csMiterLimit V) ctx.miterLimit = cmd[1]; break; case 34: // (csGlobalCompositeOperation V) ctx.globalCompositeOperation = cmd[1]; break; case 35: // (csPost) cvs.post = true; break; } } } function drawCanvas(id, dly) { if (CvsReq.readyState > 0 && CvsReq.readyState < 4) return true; var url = document.getElementsByTagName("BASE")[0].href + SesId + "!jsDraw?" + id + "&+" + dly; var len = arguments.length; CvsDly = dly; for (var i = 2; i < len; ++i) { if (typeof arguments[i] == "undefined") return true; if (typeof arguments[i] === "number") url += "&+" + arguments[i]; else url += "&" + arguments[i]; } try {CvsReq.open("POST", url);} catch (e) {return true;} CvsReq.responseType = "arraybuffer"; CvsReq.onload = function() { var ele = document.getElementById(id); ele.dly = dly; renderCanvas(ele, plio(new Uint8Array(CvsReq.response))); if (ele.post) { ele.post = false; while (ele = ele.parentNode) { if (ele.tagName == "FORM") { post(ele, false, null, null); break; } } } if (dly == 0) requestAnimationFrame(function() {drawCanvas(id, 0)}); else if (dly > 0) setTimeout(function() {drawCanvas(id, dly)}, dly); } try {CvsReq.send(null);} catch (e) { CvsReq.abort(); return true; } return false; } function csMouseDn(cvs, event) { var r = cvs.getBoundingClientRect(); cvs.csDn = true; cvs.csDnX = event.clientX - r.left; cvs.csDnY = event.clientY - r.top; cvs.csMv = false; return false; } function csMouseMv(cvs, event) { var r = cvs.getBoundingClientRect(); if (cvs.curs) csCursor(cvs, event.clientX - r.left, event.clientY - r.top); if (!cvs.csDn) return true; if (drawCanvas(cvs.id, cvs.dly, cvs.csMv? -1 : 0, cvs.csDnX, cvs.csDnY, event.clientX - r.left, event.clientY - r.top ) ) return true; cvs.csMv = true; return false; } function csMouseOut(cvs) { cvs.style.cursor = ""; cvs.csDn = cvs.csMv = false; if (cvs.clicked) { clearTimeout(cvs.clicked); cvs.clicked = false; } return drawCanvas(cvs.id, cvs.dly); } function csMouseUp(cvs) { cvs.csDn = false; if (cvs.clicked) { clearTimeout(cvs.clicked); cvs.clicked = false; return drawCanvas(cvs.id, cvs.dly, 2, cvs.csDnX, cvs.csDnY); } if (cvs.csMv) return drawCanvas(cvs.id, cvs.dly); cvs.clicked = setTimeout( function() { cvs.clicked = false; drawCanvas(cvs.id, cvs.dly, 1, cvs.csDnX, cvs.csDnY); }, 200 ); return false; } function csCursor(cvs, x, y) { var a; for (var i = 0; i < cvs.curs.length; ++i) { if (typeof (a = cvs.curs[i]) === "string") { cvs.style.cursor = a; return; } for (var j = 1; j < a.length; j += 4) { if (a[j] <= x && x <= a[j+2] && a[j+1] <= y && y <= a[j+3]) { cvs.style.cursor = a[0]; return; } } } cvs.style.cursor = ""; } picoLisp/lib/canvas.l0000644000175000017500000000371312507737061013152 0ustar abuabu# 04apr15abu # (c) Software Lab. Alexander Burger (allow "!jsDraw" ) (push1 '*JS (allow "@lib/plio.js") (allow "@lib/canvas.js")) # Draw (drawCanvas Id Dly) # Click (drawCanvas Id Dly 1 X Y) # Double (drawCanvas Id Dly 2 X Y) # Start (drawCanvas Id Dly 0 X Y X2 Y2) # Move (drawCanvas Id Dly -1 X Y X2 Y2) (de jsDraw (Id Dly F X Y X2 Y2) (http1 "application/octet-stream" 0) (let Lst (drawCanvas Id Dly F X Y X2 Y2) (prinl "Content-Length: " (bytes Lst) "^M^J^M") (pr Lst) ) ) # Canvas Commands (for (Opc . L) (quote # In sync with "@lib/canvas.js" ### Functions ### (csFillText Str X Y) (csStrokeLine X1 Y1 X2 Y2) (csClearRect X Y DX DY) (csStrokeRect X Y DX DY) (csFillRect X Y DX DY) (csBeginPath) (csClosePath) (csMoveTo X Y) (csLineTo X Y) (csBezierCurveTo X1 Y1 X2 Y2 X Y) (csLine X1 Y1 X2 Y2) (csRect X Y DX DY) (csArc X Y R A B F) (csStroke) (csFill) (csClip) (csDef Key DX DY Lst) (csDraw Key X Y) (csDrawDots DX DY Lst) (csDrawImage Img X Y Lst DX DY) (csTranslate X Y) (csRotate A) (csScale X Y) (csSave) (csRestore) ### Variables ### (csCursor Lst) (csFillStyle V) (csStrokeStyle V) (csGlobalAlpha V) (csLineWidth V) (csLineCap V) (csLineJoin V) (csMiterLimit V) (csGlobalCompositeOperation V) (csPost) ) (def (car L) (list (cdr L) (list 'link (if (cdr L) (cons 'list Opc @) (list Opc) ) ) ) ) ) (de (Id DX DY Alt) (prin "" Alt "" ) ) # vi:et:ts=3:sw=3 picoLisp/lib/conDbgc.l0000644000175000017500000000361711470243761013236 0ustar abuabu# 15nov10abu # (c) Software Lab. Alexander Burger ### Concurrent DB Garbage Collector ### # *DbgcDly *DbgcPid (default *DbgcDly 64) (if (fork) (setq *DbgcPid @) (wait 60000) (undef 'upd) (de upd Lst (wipe Lst) (let *DbgcDly (>> 1 *DbgcDly) (for S Lst (when (ext? S) (mark S T) (markData (val S)) (maps markData S) ) (wipe S) ) ) ) (de markExt (S) (unless (mark S T) (wait *DbgcDly) (markData (val S)) (maps markData S) (wipe S) ) ) (de markData (X) (while (pair X) (markData (pop 'X)) ) (and (ext? X) (markExt X)) ) (loop (let MS (+ (/ (usec) 1000) 86400000) (markExt *DB) (while (> MS (/ (usec) 1000)) (wait 60000) ) ) (let Cnt 0 (for (F . @) (or *Dbs (2)) (for (S (seq F) S (seq S)) (wait *DbgcDly) (unless (mark S) (sync) (if (mark S) (tell) (and (isa '+Entity S) (zap> S)) (zap S) (commit) (inc 'Cnt) ) ) ) ) (when *Blob (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (wait *DbgcDly) (when (match Pat F) (unless (and (setq S (extern (pack (replace @S '/)))) (get S (intern (pack @R))) ) (inc 'Cnt) (call 'rm (pack F)) ) (wipe S) ) ) ) ) ) ) (msg Cnt " conDbgc") ) (mark 0) ) ) # vi:et:ts=3:sw=3 picoLisp/lib/db.l0000644000175000017500000010077612620310626012261 0ustar abuabu# 10nov15abu # (c) Software Lab. Alexander Burger # *Dbs *Jnl *Blob 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) (let Rel (get Cls 1 Var) (unless Rel (quit "Bad relation" (cons Var (car Cls))) ) (when (or (isa '+index Rel) (isa '+Swap Rel)) (put @ 'dbf Dbf) ) (for B (; Rel bag) (when (or (isa '+index B) (isa '+Swap B)) (put @ '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 ) ) ) (de treeRel (Var Cls) (with (or (get Cls Var) (meta Cls Var)) (or (find '((B) (isa '+index B)) (: bag)) This ) ) ) # (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym (de db (Var Cls . @) (with (treeRel Var Cls) (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) (while (and (args) (== (pop 'A) (arg 1))) (next) (queue 'Key (next)) ) (and (: ub) (setq Key (ubZval Key))) ) (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 (treeRel Var Cls) (let Key (if (: ub) (ubZval (rest)) (rest)) (step (init (tree (: var) (: cls) (and (: hook) (next))) Key (append Key T) ) ) ) ) ) # (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst (de collect (Var Cls . @) (with (treeRel Var Cls) (let (Tree (tree (: var) (: cls) (and (: hook) (next))) X1 (next) X2 (if (args) (next) (or X1 T)) ) (make (cond ((isa '+Key This) (iter Tree '((X) (and (isa Cls X) (link (pass get X)))) X1 X2 ) ) ((: ub) (if X1 (ubIter Tree (inc (length (: aux))) '((X) (and (isa Cls X) (link (pass get X)))) X1 X2 ) (iter Tree '((X) (and (isa Cls X) (link (pass get X)))) ) ) ) (T (when (isa '+Fold This) (setq X1 (fold X1) X2 (or (=T X2) (fold 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) (link (pass get X))) ) X1 X2 (or (isa '+Idx This) (isa '+IdxFold This)) ) ) ) ) ) ) ) (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 ) ) (de genStrKey (Str Var Cls Hook) (while (fetch (tree Var Cls Hook) Str) (setq Str (pack "# " Str)) ) Str ) ### 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 rel?> (Obj Val) T ) (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 (when (: hook) (get (if (sym? @) 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) (and (pair X) (pick 'has> (: bag) (circ 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 (when (: hook) (get (if (sym? @) Obj Old) (: hook)) ) ) ) (: bag) Old ) ) (when New (mapc '((This N) (rel> This Obj NIL N (when (: hook) (get (if (sym? @) Obj New) (: hook)) ) ) ) (: bag) New ) ) ) (dm rel?> (Obj Val) (fully '((This V) (or (not V) (rel?> This Obj V (when (: hook) (get (if (sym? @) Obj Val) (: hook)) ) ) ) ) (: bag) Val ) ) (dm lose> (Obj Val) (mapc '((This V) (lose> This Obj V (when (: hook) (get (if (sym? @) Obj Val) (: hook)) ) ) ) (: bag) Val ) ) (dm keep> (Obj Val) (mapc '((This V) (keep> This Obj V (when (: hook) (get (if (sym? @) 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) (class +String +Symbol) (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)) (fully '((L) (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 rel?> (Obj Val) (let X (get Val (: slot)) (or (== Obj X) (memq Obj X)) ) ) (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 (extract '((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) ) ) 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) ) # +Index prefix (class +Hook2) (dm rel> (Obj Old New Hook) (extra Obj Old New *DB) (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @))) (extra Obj Old New Hook) ) ) (dm lose> (Obj Val Hook) (extra Obj Val *DB) (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @))) (extra Obj Val Hook) ) ) (dm keep> (Obj Val Hook) (extra Obj Val *DB) (when (or (and Hook (n== Hook *DB)) (and (: hook) (get Obj @))) (extra Obj Val Hook) ) ) # (+Blob) (class +Blob +relation) (de blob (Obj Var) (pack *Blob (glue "/" (chop Obj)) "." Var) ) (dm put> (Obj Old New) (and New (dirname (blob Obj)) (call 'mkdir "-p" @) ) (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)) ) (dm rel?> (Obj Val Hook)) # (+Key +relation) [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 (and (: hook) (get Obj @)))) Val ) ,"Not unique" ) ) ) (dm rel> (Obj Old New Hook) (let Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (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 rel?> (Obj Val Hook) (== Obj (fetch (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Val ) ) ) (dm lose> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Val NIL (: dbf) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Val Obj (: dbf) ) (extra Obj Val Hook) ) # (+Ref +relation) [hook] (class +Ref +index) # aux ub (dm rel> (Obj Old New Hook) (let (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Aux (mapcar '((S) (get Obj S)) (: aux)) ) (when Old (let Key (cons Old Aux) (store Tree (if (: ub) (ubZval Key Obj) (append Key Obj) ) NIL (: dbf) ) ) ) (and New (not (get Obj T)) (let Key (cons New Aux) (store Tree (if (: ub) (ubZval Key Obj) (conc Key Obj) ) Obj (: dbf) ) ) ) ) (extra Obj Old New Hook) ) (dm rel?> (Obj Val Hook) (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) (== Obj (fetch (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (if (: ub) (ubZval Key Obj) (append Key Obj) ) ) ) ) ) (dm lose> (Obj Val Hook) (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (if (: ub) (ubZval Key Obj) (conc Key Obj) ) NIL (: dbf) ) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (if (: ub) (ubZval Key Obj) (conc Key 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 rel?> (Obj Val Hook) (and (with (meta (: cls) (: var)) (== Obj (fetch (tree (: var) (: cls)) (cons Val Obj) ) ) ) (extra Obj Val 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 +relation) [cnt [hook]] (class +Idx +Ref) # min (dm T (Var Lst) (=: min (or (car Lst) 3)) (super Var (cdr Lst)) ) (de idxRel (Obj Old Old2 Olds New New2 News Hook) (let (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Aux (mapcar '((S) (get Obj S)) (: aux)) Aux2 (append Aux (cons Obj)) ) (setq Aux (conc Aux Obj)) (and Old (store Tree (cons @ Aux) NIL (: dbf))) (and Old2 (store Tree (cons @ Aux2) NIL (: dbf))) (for S Olds (while (nth S (: min)) (store Tree (cons (pack S) Aux2) NIL (: dbf)) (pop 'S) ) ) (unless (get Obj T) (and New (store Tree (cons @ Aux) Obj (: dbf))) (and New2 (store Tree (cons @ Aux2) Obj (: dbf))) (for S News (while (nth S (: min)) (store Tree (cons (pack S) Aux2) Obj (: dbf)) (pop 'S) ) ) ) ) ) (de idxRel? (Obj Val Val2 Vals Hook) (let (Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) Aux (mapcar '((S) (get Obj S)) (: aux)) Aux2 (append Aux (cons Obj)) ) (setq Aux (conc Aux Obj)) (and (== Obj (fetch Tree (cons Val Aux))) (or (not Val2) (== Obj (fetch Tree (cons Val2 Aux2)))) (fully '((S) (loop (NIL (nth S (: min)) T) (NIL (== Obj (fetch Tree (cons (pack S) Aux2)))) (pop 'S) ) ) Vals ) ) ) ) (dm rel> (Obj Old New Hook) (idxRel Obj Old NIL (split (cdr (chop Old)) " " "^J") New NIL (split (cdr (chop New)) " " "^J") Hook ) (extra Obj Old New Hook) ) (dm rel?> (Obj Val Hook) (and (idxRel? Obj Val NIL (split (cdr (chop Val)) " " "^J") Hook ) (extra Obj Val Hook) ) ) (dm lose> (Obj Val Hook) (idxRel Obj Val NIL (split (cdr (chop Val)) " " "^J") NIL NIL NIL Hook ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (idxRel Obj NIL NIL NIL Val NIL (split (cdr (chop Val)) " " "^J") Hook ) (extra Obj Val Hook) ) # (+Sn +index) [hook] (class +Sn) (dm rel> (Obj Old New Hook) (let Tree (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (and Old (ext:Snx Old) (store Tree (cons @ Obj T) NIL (: dbf)) ) (and New (not (get Obj T)) (ext:Snx New) (store Tree (cons @ Obj T) Obj (: dbf)) ) ) (extra Obj Old New Hook) ) (dm rel?> (Obj Val Hook) (and (let S (ext:Snx Val) (or (not S) (== Obj (fetch (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (cons S Obj T) ) ) ) ) (extra Obj Val Hook) ) ) (dm lose> (Obj Val Hook) (let? S (ext:Snx Val) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (cons S Obj T) NIL (: dbf) ) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (let? S (ext:Snx Val) (store (tree (: var) (: cls) (or Hook (and (: hook) (get Obj @)))) (cons S Obj T) Obj (: dbf) ) ) (extra Obj Val Hook) ) # (+Fold +index) [hook] (class +Fold) (dm has> (Val X) (extra Val (if (= Val (fold Val)) (fold X) X) ) ) (dm rel> (Obj Old New Hook) (extra Obj (fold Old) (fold New) Hook) ) (dm rel?> (Obj Val Hook) (let V (fold Val) (or (not V) (extra Obj V Hook)) ) ) (dm lose> (Obj Val Hook) (extra Obj (fold Val) Hook) ) (dm keep> (Obj Val Hook) (extra Obj (fold Val) Hook) ) # (+IdxFold +relation) [cnt [hook]] (class +IdxFold +Ref) (dm T (Var Lst) (=: min (or (car Lst) 3)) (super Var (cdr Lst)) ) (dm rel> (Obj Old New Hook) (idxRel Obj Old (fold Old) (extract '((L) (extract fold L)) (split (cdr (chop Old)) " " "^J") ) New (fold New) (extract '((L) (extract fold L)) (split (cdr (chop New)) " " "^J") ) Hook ) (extra Obj Old New Hook) ) (dm rel?> (Obj Val Hook) (and (let V (fold Val) (or (not V) (idxRel? Obj Val V (extract '((L) (extract fold L)) (split (cdr (chop Val)) " " "^J") ) Hook ) ) ) (extra Obj Val Hook) ) ) (dm lose> (Obj Val Hook) (idxRel Obj Val (fold Val) (extract '((L) (extract fold L)) (split (cdr (chop Val)) " " "^J") ) NIL NIL NIL Hook ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (idxRel Obj NIL NIL NIL Val (fold Val) (extract '((L) (extract fold L)) (split (cdr (chop Val)) " " "^J") ) Hook ) (extra Obj Val Hook) ) # (+Aux) lst (class +Aux) (dm T (Var Lst) (=: aux (car Lst)) (with *Class (for A (car Lst) (if (asoq A (: Aux)) (queue '@ Var) (queue (:: Aux) (list A Var)) ) ) ) (extra Var (cdr Lst)) ) (de relAux (Obj Var Old Lst) (let New (get Obj Var) (put Obj Var Old) (for A Lst (rel> (meta Obj A) Obj (get Obj A) NIL) ) (put Obj Var New) (for A Lst (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) ) # UB-Tree (+Aux prefix) (class +UB) (dm T (Var Lst) (=: ub T) (extra Var Lst) ) (de ubZval (Lst X) (let (Res 0 P 1) (while (find n0 Lst) (map '((L) (and (bit? 1 (car L)) (setq Res (| Res P))) (setq P (>> -1 P)) (set L (>> 1 (car L))) ) Lst ) ) (cons Res X) ) ) (dm has> (Val X) (and Val (or (extra Val X) (extra (let (N (inc (length (: aux))) M 1 V 0) (until (=0 Val) (and (bit? 1 Val) (inc 'V M)) (setq M (>> -1 M) Val (>> N Val)) ) V ) X ) ) ) ) ### Relation prefix classes ### (class +Dep) # dep (dm T (Var Lst) (=: dep (car Lst)) (extra Var (cdr Lst)) ) (dm rel> (Obj Old New Hook) (unless New (for Var (: dep) (let? V (get Obj Var) (rel> (meta Obj Var) Obj V (put> (meta Obj Var) Obj V NIL) ) ) ) ) (extra Obj Old New Hook) ) (class +List) (dm mis> (Val Obj) (or (ifn (lst? Val) "Not a List") (pick '((V) (extra V Obj)) Val) ) ) (dm ele> (Val) (and Val (or (atom Val) (find extra Val))) ) (dm has> (Val X) (and Val (or (extra Val X) (find '((X) (extra Val X)) X) ) ) ) (dm put> (Obj Old New) (if (ele> This New) (cons (extra Obj Old New) Old) (mapcar '((N O) (extra Obj O N)) New Old ) ) ) (dm del> (Obj Old Val) (and (<> Old Val) (delete Val Old) ) ) (dm rel> (Obj Old New Hook) (if (or (ele> This Old) (ele> This New)) (extra Obj Old New Hook) (for O (diff Old New) (extra Obj O NIL Hook) ) (for N (diff New Old) (extra Obj NIL N Hook) ) ) ) (dm rel?> (Obj Val Hook) (for V Val (NIL (or (not V) (extra Obj V Hook))) T ) ) (dm lose> (Obj Val Hook) (if (ele> This Val) (extra Obj Val Hook) (for V Val (extra Obj V Hook) ) ) ) (dm keep> (Obj Val Hook) (if (ele> This Val) (extra Obj Val Hook) (for V Val (extra Obj V Hook) ) ) ) (class +Need) (dm mis> (Val Obj) (ifn Val ,"Input required" (extra Val Obj) ) ) (class +Mis) # mis (dm T (Var Lst) (=: mis (car Lst)) (extra Var (cdr Lst)) ) (dm mis> (Val Obj) (or ((: mis) Val Obj) (extra Val Obj)) ) (class +Alt) (dm T (Var Lst) (extra Var (cdr Lst)) (=: cls (car Lst)) ) (class +Swap) # dbf (dm has> (Val X) (or (extra Val X) (extra Val (val X))) ) (dm put> (Obj Old New) (prog1 (or (ext? (get Obj (: var))) (new (or (: dbf 1) 1)) ) (set @ (extra Obj (val Old) New)) ) ) (dm del> (Obj Old Val) (ifn (ext? (get Obj (: var))) (extra Obj Old Val) (set @ (extra Obj (val Old) Val)) @ ) ) (dm rel> (Obj Old New Hook) (extra Obj (if (ext? Old) (val @) Old) (if (ext? New) (val @) New) Hook ) ) (dm rel?> (Obj Val Hook) (extra Obj (if (ext? Val) (val @) Val) Hook) ) (dm lose> (Obj Val Hook) (extra Obj (if (ext? Val) (val @) Val) Hook) ) (dm keep> (Obj Val Hook) (extra Obj (if (ext? Val) (val @) Val) Hook) ) ### Entities ### (class +Entity) (var Dbf) (var Aux) (de dbSync (Obj) (let *Run NIL (while (lock (or Obj *DB)) (wait 40) ) (sync) ) ) (de new! ("Typ" . @) (prog2 (dbSync) (pass new (or (meta "Typ" 'Dbf 1) 1) "Typ") (commit 'upd) ) ) (de set! (Obj Val) (unless (= Val (val Obj)) (dbSync) (set Obj Val) (commit 'upd) ) Val ) (de put! (Obj Var Val) (unless (= Val (get Obj Var)) (dbSync) (put Obj Var Val) (commit 'upd) ) Val ) (de inc! (Obj Var Val) (when (num? (get Obj Var)) (dbSync) (prog1 (inc (prop Obj Var) (or Val 1)) (commit 'upd) ) ) ) (de blob! (Obj Var File) (put!> Obj Var File) (blob+ Obj Var) File ) (de blob+ (Obj Var) (when *Jnl (chdir *Blob (call 'ln "-sf" (pack (glue "/" (chop Obj)) "." Var) (pack (name Obj) "." Var) ) ) ) ) (de incECnt (Obj) (for Cls (type Obj) (recur (Cls) (or (== '+Entity Cls) (for C (type Cls) (T (recurse C) (if (get *DB Cls) (inc @) (put *DB Cls (new T 1)) ) ) ) ) ) ) ) (de decECnt (Obj) (for Cls (type Obj) (recur (Cls) (or (== '+Entity Cls) (for C (type Cls) (T (recurse C) (and (get *DB Cls) (dec @)) ) ) ) ) ) ) (dm T @ (incECnt This) (while (args) (cond ((=T (next)) (put This T T)) ((atom (arg)) (put> This (arg) (next))) (T (put> This (car (arg)) (eval (cdr (arg))))) ) ) (upd> This (val This)) ) (dm zap> () (for X (getl This) (let V (or (atom X) (pop 'X)) (and (meta This X) (zap> @ This V)) ) ) (unless (: T) (decECnt This)) ) (dm url> (Tab)) (dm url2> () (url> This 2)) (dm url3> () (url> This 3)) (dm url4> () (url> This 4)) (dm upd> (X Old)) (dm has> (Var Val) (or (nor Val (if2 (get This Var) (ext? @) (val @) @) ) (has> (meta This Var) Val (get This Var)) ) ) (dm rel?> (Var Val) (nond (Val T) ((meta This Var) T) (NIL (rel?> @ This Val)) ) ) (dm put> (Var Val) (unless (has> This Var Val) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (put> (meta This Var) This Old Val)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) ) Val ) (dm put!> (Var Val) (unless (has> This Var Val) (dbSync) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (put> (meta This Var) This Old Val)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) ) ) Val ) (dm del> (Var Val) (when (and Val (has> (meta This Var) Val (get This Var))) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (del> (meta This Var) This Old @)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) ) ) (dm del!> (Var Val) (when (and Val (has> (meta This Var) Val (get This Var))) (dbSync) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (del> (meta This Var) This Old @)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) ) ) ) (dm inc> (Var Val) (let P (prop This Var) (when (num? (car P)) (let Old @ (rel> (meta This Var) This Old (inc P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) (car P) ) ) ) (dm inc!> (Var Val) (when (num? (get This Var)) (dbSync) (let (P (prop This Var) Old (car P)) (rel> (meta This Var) This Old (inc P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) (car P) ) ) ) (dm dec> (Var Val) (let P (prop This Var) (when (num? (car P)) (let Old @ (rel> (meta This Var) This Old (dec P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) (car P) ) ) ) (dm dec!> (Var Val) (when (num? (get This Var)) (dbSync) (let (P (prop This Var) Old (car P)) (rel> (meta This Var) This Old (dec P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) (car P) ) ) ) (dm mis> (Var Val) (mis> (meta This Var) Val This) ) (dm lose1> (Var) (when (meta This Var) (lose> @ This (get This Var)) ) ) (dm lose> (Lst) (unless (: T) (for X (getl This) (let V (or (atom X) (pop 'X)) (and (not (memq X Lst)) (meta This X) (lose> @ This V) ) ) ) (decECnt This) (=: T T) (upd> This) ) ) (dm lose!> () (dbSync) (lose> This) (commit 'upd) ) (de lose "Prg" (let "Flg" (: T) (=: T T) (run "Prg") (=: T "Flg") ) ) (dm keep1> (Var) (when (meta This Var) (keep> @ This (get This Var)) ) ) (dm keep> (Lst) (when (: T) (=: T) (incECnt This) (for X (getl This) (let V (or (atom X) (pop 'X)) (and (not (memq X Lst)) (meta This X) (keep> @ This V) ) ) ) (upd> This T) ) ) (dm keep?> (Lst) (extract '((X) (with (and (pair X) (meta This (cdr X))) (and (isa '+Key This) (fetch (tree (: var) (: cls) (and (: hook) (get (up This) @))) (car X)) (cons (car X) ,"Not unique") ) ) ) (getl This) ) ) (dm keep!> () (dbSync) (keep> This) (commit 'upd) ) (de keep "Prg" (let "Flg" (: T) (=: T) (run "Prg") (=: T "Flg") ) ) (dm set> (Val) (unless (= Val (val This)) (decECnt This) (let Lst (make (maps '((X) (link (fin X))) This)) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (let V (get This Var) (rel> Rel This V (put> Rel This V NIL)) ) ) ) ) (xchg This 'Val) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (rel> Rel This NIL (put> Rel This NIL (get This Var)) ) ) ) ) ) (incECnt This) (upd> This (val This) Val) ) (val This) ) (dm set!> (Val) (unless (= Val (val This)) (dbSync) (decECnt This) (let Lst (make (maps '((X) (link (fin X))) This)) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (let V (get This Var) (rel> Rel This V (put> Rel This V NIL)) ) ) ) ) (xchg This 'Val) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (rel> Rel This NIL (put> Rel This NIL (get This Var)) ) ) ) ) ) (incECnt This) (upd> This (val This) Val) (commit 'upd) ) (val This) ) (dm clone> () (let Obj (new (or (var: Dbf 1) 1) (val This)) (for X (by '((X) (nand (pair X) (isa '+Hook (meta This (cdr X))) ) ) sort (getl This) ) (if (atom X) (ifn (meta This X) (put Obj X T) (let Rel @ (put> Obj X T) (when (isa '+Blob Rel) (in (blob This X) (out (blob Obj X) (echo)) ) ) ) ) (ifn (meta This (cdr X)) (put Obj (cdr X) (car X)) (let Rel @ (cond ((find '((B) (isa '+Key B)) (get Rel 'bag)) (let (K @ H (get K 'hook)) (put> Obj (cdr X) (mapcar '((Lst) (mapcar '((B Val) (if (== B K) (cloneKey B (cdr X) Val (and H (get (if (sym? H) This Lst) H)) ) Val ) ) (get Rel 'bag) Lst ) ) (car X) ) ) ) ) ((isa '+Key Rel) (put> Obj (cdr X) (cloneKey Rel (cdr X) (car X) (and (get Rel 'hook) (get This @)) ) ) ) ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X)))) (put> Obj (cdr X) (car X)) ) ) ) ) ) ) Obj ) ) (de cloneKey (Rel Var Val Hook) (cond ((isa '+Number Rel) (genKey Var (get Rel 'cls) Hook) ) ((isa '+String Rel) (genStrKey (pack "# " Val) Var (get Rel 'cls) Hook) ) ) ) (dm clone!> () (prog2 (dbSync) (clone> This) (commit 'upd) ) ) # Default syncronization function (de upd Lst (wipe Lst) ) ### Utilities ### # Define object variables as relations (de rel Lst (def *Class (car Lst) (new (cadr Lst) (car Lst) (cddr Lst)) ) ) # Find or create object (de request (Typ Var . @) (let Dbf (or (meta Typ 'Dbf 1) 1) (ifn Var (new Dbf Typ) (with (meta Typ Var) (or (pass db Var (: cls)) (if (: hook) (pass new Dbf Typ @ (next) Var) (pass new Dbf Typ Var) ) ) ) ) ) ) # Create or update object # *ObjIdx (de obj Lst (let Obj (let L (pop 'Lst) (if (pair (car L)) (apply request L) (cache '*ObjIdx (pop 'Lst) (new (or (meta L 'Dbf 1) 1) L) ) ) ) (while Lst (let (K (pop 'Lst) V (pop 'Lst)) (if (=T K) (lose> Obj) (put> Obj K V) ) ) ) Obj ) ) # vi:et:ts=3:sw=3 picoLisp/lib/debug.l0000644000175000017500000003031412507436274012764 0ustar abuabu# 03apr15abu # (c) Software Lab. Alexander Burger # Prompt (when symbols (de *Prompt (unless (== (symbols) 'pico) (symbols)) ) ) # Browsing (de doc (Sym Browser) (call (or Browser (sys "BROWSER") 'w3m) (pack "file:" (and (= `(char '/) (char (path "@"))) "//") (path "@doc/ref") (if Sym (let (L (chop Sym) C (car L)) (and (member C '("*" "+")) (cadr L) (setq C @) ) (cond ((>= "Z" C "A")) ((>= "z" C "a") (setq C (uppc C))) (T (setq C "_")) ) (pack C ".html#" Sym) ) ".html" ) ) ) ) (de more ("M" "Fun") (let *Dbg NIL (if (pair "M") ((default "Fun" print) (pop '"M")) (println (type "M")) (setq "Fun" (list '(X) (list 'pp 'X (lit "M"))) "M" (mapcar car (filter pair (val "M"))) ) ) (loop (flush) (T (atom "M") (prinl)) (T (line) T) ("Fun" (pop '"M")) ) ) ) (de less (X) (if (atom X) X (cons (less (pop 'X)) (if (atom X) X (cons (less (pop 'X)) (and X '(..)) ) ) ) ) ) (de what (S) (let *Dbg NIL (setq S (chop S)) (filter '(("X") (match S (chop "X"))) (all) ) ) ) (de who ("X" . "*Prg") (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) (make (mapc "who" (all))) ) ) (de "who" ("Y") (unless (or (ext? "Y") (memq "Y" "Who")) (push '"Who" "Y") (ifn (= `(char "+") (char "Y")) (and (pair (val "Y")) ("nest" @) (link "Y")) (for "Z" (pair (val "Y")) (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (cdr "Z")) (link (cons (car "Z") "Y")) ) ) ) (maps '(("Z") (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (car "Z")) (link (cons (cdr "Z") "Y")) ) ) ) "Y" ) ) ) ) (de "nest" ("Y") ("nst1" "Y") ("nst2" "Y") ) (de "nst1" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") (and (sym? "Y") ("who" "Y"))) (and (sym? (car "Y")) ("who" (car "Y"))) (and (pair (car "Y")) ("nst1" @)) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "nst2" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") ("match" "Y")) (T (or ("match" (car "Y")) ("nst2" (car "Y"))) T ) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "match" ("D") (and (cond ((str? "X") (and (str? "D") (= "X" "D"))) ((sym? "X") (== "X" "D")) (T (match "X" "D")) ) (or (not "*Prg") (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) (de has ("X") (let *Dbg NIL (filter '(("S") (= "X" (val "S"))) (all) ) ) ) (de can (X) (let *Dbg NIL (extract '(("Y") (and (= `(char "+") (char "Y")) (asoq X (val "Y")) (cons X "Y") ) ) (all) ) ) ) # Class dependencies (de dep ("C") (let *Dbg NIL (dep1 0 "C") (dep2 3 "C") "C" ) ) (de dep1 (N "C") (for "X" (type "C") (dep1 (+ 3 N) "X") ) (space N) (println "C") ) (de dep2 (N "C") (for "X" (all) (when (and (= `(char "+") (char "X")) (memq "C" (type "X")) ) (space N) (println "X") (dep2 (+ 3 N) "X") ) ) ) # Inherited methods (de methods (Obj) (make (let Mark NIL (recur (Obj) (for X (val Obj) (nond ((pair X) (recurse X)) ((memq (car X) Mark) (link (cons (car X) Obj)) (push 'Mark (car X)) ) ) ) ) ) ) ) # Source code (off "*Ed") (in "@lib/map" (while (read) (let Sym @ (if (get Sym '*Dbg) (set @ (read)) (put Sym '*Dbg (cons (read))) ) ) ) ) (de _ed ("Ed" . "Prg") (ifn "X" (eval (out (pil "editor") (println (cons 'load "Ed")) ) ) (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (when (setq "*Ed" (if C (get C '*Dbg -1 "X") (get "X" '*Dbg 1) ) ) (out (tmp "tags") (let D (pack (pwd) "/") (for Lst (group # (file (line . sym) (line . sym) ..) (extract '((This) (when (: *Dbg) (cons (path (cdar @)) (caar @) This) ) ) (all) ) ) (let Tags (in (car Lst) (let (Line 1 Ofs 0) (mapcar '((X) (do (- (car X) Line) (inc 'Ofs (inc (size (line T)))) ) (pack `(pack "^J" (char 127)) (cdr X) (char 1) (setq Line (car X)) "," Ofs ) ) (sort (cdr Lst)) ) ) ) (prinl "^L^J" (unless (= `(char "/") (char (car Lst))) D) (car Lst) "," (sum size Tags) Tags ) ) ) ) ) (run "Prg") ) ) "X" ) (de vi ("X" C) (_ed '("@lib/led.l" "@lib/edit.l") (call "vim" (pack "+set tags=" (tmp "tags") ",./tags") "+set isk=33-34,36-38,42-90,92,94-95,97-125" (pack "+" (car "*Ed")) (path (cdr "*Ed")) ) ) ) # Emacs interface (Thorsten Jolitz) # Note: # As 'tags-table-list' is set here, do not also set `tags-file-name' # make sure, tsm.el and picolisp.el are loaded (in that order) and put # the edited .l file in picolisp mode (M-x picolisp-mode) (de em ("X" C) (_ed '("@lib/eled.l" "@lib/eedit.l") (call "emacsclient" "-a" NIL "-e" (pack "(let ((tmp-tags \"" (tmp "tags") "\")" "(src-tags (expand-file-name \"" (path "@src64/tags") "\")))" "(setq tags-table-list " "(append `(,tmp-tags) `(,src-tags) tags-table-list))" "(mapc (lambda (F)" "(unless (file-exists-p (expand-file-name F))" "(setq tags-table-list (delete F tags-table-list))))" "tags-table-list)" "(delete-dups tags-table-list)" "(setq tags-table-list (delete \"\" tags-table-list))" "(setq tags-file-name nil)" " )" ) ) (call "emacsclient" "-c" (pack "+" (car "*Ed")) (path (cdr "*Ed")) ) ) ) (de ld () (and "*Ed" (load (cdr "*Ed"))) ) # Single-Stepping (de _dbg (Lst) (or (atom (car Lst)) (num? (caar Lst)) (flg? (caar Lst)) (== '! (caar Lst)) (set Lst (cons '! (car Lst))) ) ) (de _dbg2 (Lst) (map '((L) (if (and (pair (car L)) (flg? (caar L))) (map _dbg (cdar L)) (_dbg L) ) ) Lst ) ) (de dbg (Lst) (when (pair Lst) (casq (pop 'Lst) ((case casq state) (_dbg Lst) (for L (cdr Lst) (map _dbg (cdr L)) ) ) ((cond nond) (for L Lst (map _dbg L) ) ) (quote (when (fun? Lst) (map _dbg (cdr Lst)) ) ) ((job use let let? recur) (map _dbg (cdr Lst)) ) (loop (_dbg2 Lst) ) ((bind do) (_dbg Lst) (_dbg2 (cdr Lst)) ) (for (and (pair (car Lst)) (map _dbg (cdar Lst))) (_dbg2 (cdr Lst)) ) (T (map _dbg Lst)) ) T ) ) (de d () (let *Dbg NIL (dbg ^))) (de debug ("X" C) (ifn (traced? "X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (dbg (if C (method "X" C) (getd "X"))) (quit "Can't debug" "X") ) ) (untrace "X" C) (debug "X" C) (trace "X" C) ) ) (de ubg (Lst) (when (pair Lst) (map '((L) (when (pair (car L)) (when (== '! (caar L)) (set L (cdar L)) ) (ubg (car L)) ) ) Lst ) T ) ) (de u () (let *Dbg NIL (ubg ^))) (de unbug ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (ubg (if C (method "X" C) (getd "X"))) (quit "Can't unbug" "X") ) ) ) # Tracing (de traced? ("X" C) (setq "X" (if C (method "X" C) (getd "X") ) ) (and (pair "X") (pair (cadr "X")) (== '$ (caadr "X")) ) ) # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) (de trace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (unless (traced? "X" C) (or (method "X" C) (quit "Can't trace" "X")) (con @ (cons (conc (list '$ (cons "X" C) (car @)) (cdr @) ) ) ) ) (unless (traced? "X") (and (sym? (getd "X")) (quit "Can't trace" "X")) (and (num? (getd "X")) (expr "X")) (set "X" (list (car (getd "X")) (conc (list '$ "X") (getd "X")) ) ) ) ) "X" ) ) # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) (de untrace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (when (traced? "X" C) (con (method "X" C) (cdddr (cadr (method "X" C))) ) ) (when (traced? "X") (let X (set "X" (cddr (cadr (getd "X")))) (and (== '@ (pop 'X)) (= 1 (length X)) (= 2 (length (car X))) (== 'pass (caar X)) (sym? (cdadr X)) (subr "X") ) ) ) ) "X" ) ) (de *NoTrace @ @@ @@@ pp show more led what who can dep d e debug u unbug trace untrace ) (de traceAll (Excl) (let *Dbg NIL (for "X" (all) (or (memq "X" Excl) (memq "X" *NoTrace) (= `(char "*") (char "X")) (cond ((= `(char "+") (char "X")) (mapc trace (extract '(("Y") (and (pair "Y") (fun? (cdr "Y")) (cons (car "Y") "X") ) ) (val "X") ) ) ) ((pair (getd "X")) (trace "X") ) ) ) ) ) ) # Process Listing (when (= *OS "Linux") (de proc @ (apply call (make (while (args) (link "-C" (next)))) 'ps "-H" "-o" "pid,ppid,start,size,pcpu,time,cmd" ) ) ) # Benchmarking (de bench Prg (let U (usec) (prog1 (run Prg 1) (out 2 (prinl (format (*/ (- (usec) U) 1000) 3) " sec" ) ) ) ) ) `(== 64 64) # Only in the 64-bit version # Backtrace (de bt (Flg) (let (S NIL *Dbg) (for (L (trail T) L) (if (pair (car L)) (push 'S (cons (pop 'L))) (conc (car (default S (cons (cons)))) (cons (cons (pop 'L) (pop 'L))) ) ) (T (== '^ (car L))) (T (and (pair (car L)) (== 'bt (caar L)) ) ) ) (for L S (let? X (pop 'L) (pretty (cons (or (and (sym? (car X)) (car X)) (less (has (car X))) (car X) ) (less (cdr X)) ) ) ) (prinl) (while L (space 3) (println (caar L) (less (cdr (pop 'L)))) ) (T (and (not Flg) (line)) T) ) ) ) # vi:et:ts=3:sw=3 picoLisp/lib/ed.l0000644000175000017500000000266311342226237012264 0ustar abuabu# 27feb10abu # (c) Software Lab. Alexander Burger # Structure Editor (setq *Clip) (de ed ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (catch NIL (let (*Dbg NIL "Done") (ifn "C" (set "X" (_ed (val "X"))) (and (asoq "X" (val "C")) (con @ (_ed (cdr @))) ) ) (pp "X" "C") ) ) ) (de _ed (X) (use C (loop (T "Done" X) (pretty (car X)) (prinl) (T (member (setq C (key)) '("^H" "^?")) X) (T (= C "^I") (on "Done") X) (setq X (if (>= "9" C "1") (cons (head (setq C (format C)) X) (nth X (inc C)) ) (case (uppc C) (("^M" "^J") (cons (_ed (car X)) (cdr X))) ("^[" (throw)) (" " (cons (car X) (_ed (cdr X)))) ("D" (cdr X)) ("I" (prin "Insert:") (cons (read) X)) ("R" (prin "Replace:") (cons (read) (cdr X))) ("X" (setq *Clip (car X)) (cdr X)) ("C" (setq *Clip (car X)) X) ("V" (cons *Clip X)) ("0" (append (car X) (cdr X))) ("B" (if (== '! (caar X)) (cons (cdar X) (cdr X)) (cons (cons '! (car X)) (cdr X)) ) ) (T X) ) ) ) ) ) ) picoLisp/lib/edit.l0000644000175000017500000000411512404752151012612 0ustar abuabu# 13sep14abu # (c) Software Lab. Alexander Burger # "*F" "*Lst" "*X" "*K" (de edit @ (let *Dbg NIL (setq "*F" (tmp '"edit.l")) (catch NIL ("edit" (rest)) ) ) ) (de "edit" ("Lst") (let "N" 1 (loop (out "*F" (setq "*Lst" (make (for "S" "Lst" ("loc" (printsp "S")) ("loc" (val "S")) (pretty (val "S")) (prinl) (for "X" (sort (getl "S")) ("loc" "X") (space 3) (if (atom "X") (println "X" T) (printsp (cdr "X")) (pretty (setq "X" (car "X")) -3) (cond ((type "X") (prin " # ") (print @) ) ((>= 799999 "X" 700000) (prin " # " (datStr "X")) ) ) (prinl) ) ) (prinl) (println '(=======)) (prinl) ) ) ) ) (call 'vim "+set isk=33-34,36-38,42-90,92,94-95,97-125" "+map K yiw:call setline(line(\"$\"), \"(\" . line(\".\") . \" \" . @@ . \")\")^MZZ" "+map Q GC(0)^[ZZ" (pack "+" "N") "*F" ) (apply ==== "*Lst") (in "*F" (while (and (setq "*X" (read)) (atom "*X")) (def "*X" (read)) (until (= '(=======) (setq "*K" (read))) (def "*X" "*K" (read)) ) ) ) (====) (NIL "*X" (throw)) (T (=0 (car "*X"))) (setq "N" (car "*X")) ("edit" (conc (cdr "*X") "Lst")) ) ) ) (de "loc" ("X" "Lst") (cond ((memq "X" "Lst")) ((and (str? "X") (not (memq "X" (made)))) (link "X") ) ((pair "X") (push '"Lst" "X") ("loc" (car "X") "Lst") ("loc" (cdr "X") "Lst") ) ) ) # vi:et:ts=3:sw=3 picoLisp/lib/form.js0000644000175000017500000004174512454753652013037 0ustar abuabu/* 12jan15abu * (c) Software Lab. Alexander Burger */ var FormReq = new XMLHttpRequest(); FormReq.upload.addEventListener("progress", dropProgress, false); FormReq.upload.addEventListener("load", dropLoad, false); var Btn = []; var Queue = []; var SesId, Key, InBtn, Auto, Chg, Drop, Hint, Hints, Item, Beg, End; function inBtn(btn,flg) {InBtn = flg;} function formKey(event) { Key = event.keyCode; if (Hint && Hint.style.visibility == "visible") { if ((Item >= 0 && Key == 13) || Key == 38 || Key == 40) return false; if (Key == 13) { Hint.style.visibility = "hidden"; return true; } if (Key == 27) { Hint.style.visibility = "hidden"; return false; } } if (event.charCode || event.keyCode == 8) Chg = true; return true; } function fldChg(field) { Chg = true; if (!InBtn && Key != 13) post(field.form, false, null, null); return true; } function doBtn(btn) { Btn.push(btn); return true; } function doDrag(event) { event.stopPropagation(); event.preventDefault(); } function doDrop(btn, event) { doDrag(event); if (event.dataTransfer.files.length != 0) { Btn.push(Drop = btn); btn.value = "0 %"; post(btn.form, false, null, event.dataTransfer.files[0]); } } function dropProgress(event) { if (Drop) Drop.value = event.lengthComputable? Math.round((event.loaded * 100) / event.total) + " %" : "(?) %"; } function dropLoad(event) { Drop = null; } function hasElement(form, name) { for (var i = 0; i < form.elements.length; ++i) if (form.elements[i].name == name) return true; return false; } function setHref(fld, url) { var i = url.indexOf("~"); if (url.charAt(i = i>=0? i+1 : 0) == "+") { url = url.substr(0,i) + url.substr(i+1); fld.target = "_blank"; } fld.href = decodeURIComponent(url); } /*** Form submit ***/ function doPost(form) { for (var i = 0; ; ++i) { if (i == Btn.length) return true; if (Btn[i].form == form) return post(form, false, null, null); } } function post(form, auto, exe, file) { var i, data; if (!FormReq || !hasElement(form,"*Get") || (i = form.action.indexOf("~")) <= 0) return true; if (FormReq.readyState > 0 && FormReq.readyState < 4) { Queue.push([form, auto, exe, file]); return false; } form.style.cursor = "wait"; try {FormReq.open("POST", SesId + "!jsForm?" + form.action.substr(i+1));} catch (e) {return true;} FormReq.onload = function() { var i, j; if (FormReq.responseText == "T") { Queue.length = 0; form.submit(); } else { var txt = FormReq.responseText.split("&"); if (txt[0]) { var r = txt[0].split(":"); if (Auto) clearTimeout(Auto); if (!r[1]) Auto = null; else { Auto = setTimeout(function() { if (Chg) Auto = setTimeout(arguments.callee, r[1]); else { Btn.push(document.getElementById(r[0])); post(form, true, null, null); } }, r[1] ); } } if (!auto || !Chg) { for (i = 1; i < txt.length;) { var fld = txt[i++]; var val = decodeURIComponent(txt[i++]); if (!fld) { window[txt[i++]](val); continue; } if (!(fld = document.getElementById(fld))) continue; if (fld.tagName == "SPAN") { if (i != txt.length && txt[i].charAt(0) == "=") ++i; if (i == txt.length || txt[i].charAt(0) != "+") { if (fld.firstChild.tagName != "A") fld.firstChild.data = val? val : "\u00A0"; else fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild); } else { var a = document.createElement("A"); setHref(a, txt[i++].substr(1)); a.appendChild(document.createTextNode(val)); fld.replaceChild(a, fld.firstChild); } } else if (fld.tagName == "A") { if (i != txt.length && txt[i].charAt(0) == "=") ++i; if (i == txt.length || txt[i].charAt(0) != "+") { fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild); fld.removeAttribute("href"); } else { fld.firstChild.data = val; setHref(fld, txt[i++].substr(1)); } } else if (fld.tagName == "IMG") { var parent = fld.parentNode; fld.src = val; fld.alt = txt[i++]; if (parent.tagName == "A") { if (txt[i]) setHref(parent, txt[i]); else { var grand = parent.parentNode; grand.removeChild(parent); grand.appendChild(fld); } } else if (txt[i]) { var a = document.createElement("A"); parent.removeChild(fld); parent.appendChild(a); a.appendChild(fld); setHref(a, txt[i]); } ++i; } else { if (fld.type == "checkbox") { fld.checked = val != ""; document.getElementsByName(fld.name)[0].value = ""; } else if (fld.type == "select-one") { for (j = 0; j < fld.options.length; ++j) { if (fld.options[j].text == val) fld.selectedIndex = j; fld.options[j].disabled = false; } } else if (fld.type == "radio") { fld.value = val; fld.checked = txt[i++].charAt(0) != ""; } else if (fld.type == "image") fld.src = val; else if (fld.value != val) { fld.value = val; if (fld.pilSetValue) fld.pilSetValue(val); fld.scrollTop = fld.scrollHeight; } fld.disabled = false; if (i < txt.length && txt[i].charAt(0) == "=") { if (fld.type == "select-one") { for (j = 0; j < fld.options.length; ++j) if (fld.options[j].text != val) fld.options[j].disabled = true; } fld.disabled = true; InBtn = 0; // 'onblur' on won't come when disabled if (fld.type == "checkbox" && fld.checked) document.getElementsByName(fld.name)[0].value = "T"; ++i; } if (fld.pilDisable) fld.pilDisable(fld.disabled); } while (i < txt.length && (j = "#*?".indexOf(txt[i].charAt(0))) >= 0) { switch (j) { case 0: // '#' var cls; val = txt[i++].substr(1); if ((cls = fld.getAttribute("class")) != null) { j = cls.indexOf(" "); if (!val) val = j >= 0? cls.substr(j+2) : ""; else if (j >= 0) val += cls.substr(j); else val += " " + cls; } fld.setAttribute("class", val); break; case 1: // '*' var node = fld.parentNode.parentNode.lastChild; var img = document.createElement("IMG"); if (!node.firstChild) node = fld.parentNode.parentNode.parentNode.lastChild; node.removeChild(node.firstChild); img.src = txt[i++].substr(1); if (!txt[i]) node.appendChild(img); else { var a = document.createElement("A"); setHref(a, txt[i]); a.appendChild(img); node.appendChild(a); } ++i; break; case 2: // '?' fld.title = decodeURIComponent(txt[i++].substr(1)); break; } } } Chg = false; } } form.style.cursor = ""; if (Queue.length > 0) { var a = Queue.shift(); post(a[0], a[1], a[2], a[3]); } } if (!exe) data = ""; else { data = "*Gui:0=" + exe[0]; for (var i = 1; i < exe.length; ++i) data += "&*JsArgs:" + i + "=" + exe[i]; } for (i = 0; i < Btn.length;) if (Btn[i].form != form) ++i; else { data += "&" + Btn[i].name + "=" + encodeURIComponent(Btn[i].type == "submit"? Btn[i].value : Btn[i].src); Btn.splice(i,1); } for (i = 0; i < form.elements.length; ++i) { var fld = form.elements[i]; if (fld.name && fld.type != "submit") { // "image" won't come :-( var val; if (fld.type == "checkbox") val = fld.checked? "T" : ""; else if (fld.type == "select-one") val = fld.options[fld.selectedIndex].text; else if (fld.type == "radio" && !fld.checked) continue; else val = fld.value; data += "&" + fld.name + "=" + encodeURIComponent(val.replace(/ +$/,"")); } } try { if (!file) FormReq.send(data); else { var rd = new FileReader(); rd.readAsBinaryString(file); rd.onload = function() { FormReq.setRequestHeader("X-Pil", "*ContL=T"); FormReq.sendAsBinary(data + "&*Drop=" + encodeURIComponent(file.name) + "=" + file.size + "\n" + rd.result ); } } } catch (e) { FormReq.abort(); return true; } return false; } /*** Hints ***/ function doHint(field) { if (!Hint) { Hint = document.createElement("div"); Hint.setAttribute("class", "hint"); Hint.style.visibility = "hidden"; Hint.style.position = "absolute"; Hint.style.zIndex = 9999; Hint.style.textAlign = "left"; Hints = document.createElement("div"); Hints.setAttribute("class", "hints"); Hints.style.position = "relative"; Hints.style.top = "-2px"; Hints.style.left = "-3px"; Hint.appendChild(Hints); } field.parentNode.appendChild(Hint); field.onblur = function() { Hint.style.visibility = "hidden"; } var top = field.offsetHeight; var left = 0; for (var obj = field; obj && obj.style.position != "absolute"; obj = obj.offsetParent) { top += obj.offsetTop; left += obj.offsetLeft; } Hint.style.top = top + "px"; Hint.style.left = left + "px"; } function hintKey(field, event, tok, coy) { var i, data; if (event.keyCode == 9 || event.keyCode == 27) return false; if (Hint.style.visibility == "visible") { if (Item >= 0 && event.keyCode == 13) { setHint(field, Hints.childNodes[Item]); return false; } if (event.keyCode == 38) { // Up if (Item > 0) { hintOff(Item); hintOn(--Item); } return false; } if (event.keyCode == 40) { // Down if (Item < (lst = Hints.childNodes).length-1) { if (Item >= 0) hintOff(Item); hintOn(++Item); } return false; } } if (event.keyCode == 13) return true; var req = new XMLHttpRequest(); if (tok) { for (Beg = field.selectionStart; Beg > 0 && !field.value.charAt(Beg-1).match(/\s/); --Beg); End = field.selectionEnd; } else { Beg = 0; End = field.value.length; } if (event.keyCode != 45) { // INS if (Beg == End) { Hint.style.visibility = "hidden"; return false; } if (coy && Hint.style.visibility == "hidden") return false; } try { req.open("POST", (SesId? SesId : "") + ((i = field.id.lastIndexOf("-")) < 0? "!jsHint?$" + field.id : "!jsHint?+" + field.id.substr(i+1) ) ); } catch (e) {return true;} req.onload = function() { var i, n, lst, str; if ((str = req.responseText).length == 0) Hint.style.visibility = "hidden"; else { lst = str.split("&"); while (Hints.hasChildNodes()) Hints.removeChild(Hints.firstChild); for (i = 0, n = 7; i < lst.length; ++i) { addHint(i, field, str = decodeURIComponent(lst[i])); if (str.length > n) n = str.length; } Hints.style.width = n + 3 + "ex"; Hint.style.width = n + 4 + "ex"; Hint.style.visibility = "visible"; Item = -1; } } var data = "*JsHint=" + encodeURIComponent(field.value.substring(Beg,End)); for (i = 0; i < field.form.elements.length; ++i) { var fld = field.form.elements[i]; if (fld.name == "*Get") data += "&*Get=" + fld.value; else if (fld.name == "*Form") data += "&*Form=" + fld.value; } try {req.send(data);} catch (e) { req.abort(); return true; } return (event.keyCode != 45); // INS } function addHint(i, field, str) { var item = document.createElement("div"); item.appendChild(document.createTextNode(str)); item.onmouseover = function() { if (Item >= 0) hintOff(Item); hintOn(i); field.onblur = false; field.onchange = false; Item = i; } item.onmouseout = function() { hintOff(Item); field.onblur = function() { Hint.style.visibility = "hidden"; } field.onchange = function() { return fldChg(field); }; Item = -1; } item.onclick = function() { setHint(field, item); } Hints.appendChild(item); } function setHint(field, item) { Hint.style.visibility = "hidden"; field.value = field.value.substr(0,Beg) + item.firstChild.nodeValue + field.value.substr(End); Chg = true; post(field.form, false, null, null); field.setSelectionRange(Beg + item.firstChild.nodeValue.length, field.value.length); field.focus(); field.onchange = function() { return fldChg(field) }; } function hintOn(i) { var s = Hints.childNodes[i].style; s.background = "black"; s.color= "white"; } function hintOff(i) { var s = Hints.childNodes[i].style; s.background = "white"; s.color= "black"; } /*** Scroll/touch ***/ var TblY; function tblTouch(event) { if (event.touches.length == 1) TblY = event.touches[0].pageY; return true; } function tblMove(table, event) { if (event.touches.length == 1) { var dy = event.touches[0].pageY - TblY; if (dy < -12 || dy > +12) { TblY = event.touches[0].pageY; for (var obj = table.parentNode; obj; obj = obj.parentNode) if (obj.tagName == "FORM") return post(obj, false, [dy > 6? "jsUp" : "jsDn"], null); } return false; } return true; } /*** Lisp calls ***/ function lisp(form, fun) { if (form) { var exe = [fun]; for (var i = 2; i < arguments.length; ++i) if (typeof arguments[i] === "number") exe[i-1] = "+" + arguments[i]; else exe[i-1] = "." + encodeURIComponent(arguments[i]); return post(form, false, exe, null); } if (arguments.length > 2) { fun += "?" + lispVal(arguments[2]); for (var i = 3; i < arguments.length; ++i) fun += "&" + lispVal(arguments[i]); } var req = new XMLHttpRequest(); try {req.open("GET", SesId + "!" + fun);} catch (e) {return true;} req.onload = function() { if (req.responseText) eval(req.responseText); } try {req.send(null);} catch (e) { req.abort(); return true; } return false; } function lispVal(x) { if (typeof x === "number") return "+" + x; if (x.charAt(0) == "-") return "%2D" + encodeURIComponent(x.substr(1)); return encodeURIComponent(x); } function ping(min) { if (SesId) { lisp(null, "ping", min); setTimeout(function() {ping(min)}, 20000); } } picoLisp/lib/form.l0000644000175000017500000014777112617044061012650 0ustar abuabu# 06nov15abu # (c) Software Lab. Alexander Burger # *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans # "*Cnt" "*Lst" "*App" "*Err" "*Foc" "*Post2" "*Stat" "*Ix" "*Chart" "*Cho" (allow "@img/" T) (push1 '*JS (allow "@lib/form.js")) (mapc allow (quote *Gui *Get *Got *Form "!jsForm" *Evt *Drop *JsHint "!jsHint" jsUp jsDn *JsArgs "!tzOffs" ) ) (one "*Cnt") (off "*Lst" "*Post2" "*Chart" "*Cho" "*TZO") (de *Throbber ("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) ) (de tzOffs (Min) (setq "*TZO" (* Min 60)) (respond) ) # Define GUI form (de form ("Attr" . "Prg") (inc '*Form) (let "App" (if *PRG (get "*Lst" (- "*Cnt" *Get) *Form) (prog1 (setq *Top (new NIL NIL 'able T 'evt 0)) (queue (nth "*Lst" (- "*Cnt" *Get)) *Top) ) ) (let "Lst" (get "*Lst" (- "*Cnt" *Get) 1) (for ("F" . "L") "Lst" (let *Form (- "F" (length "Lst")) (cond ((and (== *PRG (car "L")) (memq "App" (get *PRG 'top))) (apply "form" "L") ) ((or (== *PRG "App") (memq "App" (get *PRG 'top))) (if (get "L" 1 'top) (apply "form" "L") (put (car "L") 'top (cons *PRG (get *PRG 'top))) (let *PRG NIL (apply "form" "L")) ) ) ) ) ) ) ("form" "App" "Attr" "Prg") ) ) (de "form" ("*App" "Attr" "Prg") (with "*App" (job (: env) ( "Attr" (urlMT *Url *Menu *Tab *ID) ( '*Get *Get) ( '*Form *Form) ( '*Evt (: evt)) (zero "*Ix") (if *PRG (let gui '(() (with (get "*App" 'gui (inc '"*Ix")) (for E "*Err" (when (== This (car E)) (
'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 (get Fld 'chg) (get Fld 'able) (=: lock)) (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)) ) # 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 '"*Lst" L) (and (nth "*Lst" 99) (con @)) (setq *Get "*Cnt") (inc '"*Cnt") ) (de _doForm () (one *Form) (run "Prg") (setq "*Stat" (cons (pair "*Err") (copy (get "*Lst" (- "*Cnt" *Get))) ) ) ) (de jsForm (Url) (if (or *PRG (not *Post)) (noContent) (setq *Url Url Url (chop Url)) (let action '(Prg (off "*Err") (with (postForm) (catch "stop" (postGui) (httpHead "text/plain; charset=utf-8") (if (and (= (car "*Stat") "*Err") (= (cdr "*Stat") (get "*Lst" (- "*Cnt" *Get))) ) (ht:Out *Chunked (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 (pack (cdr Url)))) ) ((tail '("." "l") Url) (load *Url) ) ) ) ) ) ) (de postForm () (when (num? (format *Get)) (let? Lst (get "*Lst" (- "*Cnt" (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 ("Fun" NIL *Btn NIL) (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) (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") (and *Lock (with (caar "*Err") (tryLock *Lock))) (finally (when *Lock (if (lock @) (=: able (off *Lock)) (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) (timeout `(* 3600 1000)) (redirect (baseHRef) *SesId Url "?" (pack (make (loop (and (sym? (next)) (= `(char '*) (char (arg))) (link (arg) "=") (next) ) (link (ht:Fmt (arg))) (NIL (args)) (link "&") ) ) ) ) (throw "stop") ) ) # Active elements (de span Args (def (car Args) (list NIL (list ' (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 NIL "lisp(null, 'tzOffs', (new Date()).getTimezoneOffset())" ) (pack (tim$ (% Tim 86400)) " UTC") ) ) ) ) # Return chart property (de chart @ (pass get "*Chart") ) # Table extensions (patch (cdr ) 'Attr '(if "*Chart" (list '("ontouchstart" . "return tblTouch(event)") '("ontouchmove" . "return tblMove(this,event)") Attr ) Attr ) ) (daemon '
(on "rowF") ) (de alternating () (onOff "rowF") ) # REPL form (de repl (Attr) (form Attr (gui 'view '(+FileField) '(tmp "repl") 80 25) (--) (gui 'line '(+Focus +TextField) 64 ":") (gui '(+JS +Button) "eval" '(let Str (val> (: home line)) (out (pack "+" (tmp "repl")) (prinl ": " Str) (catch '(NIL) (let Res (in "/dev/null" (eval (any Str))) (prin "-> ") (println Res) ) ) (when *Msg (prinl @) (off *Msg)) ) (clr> (: home line)) ) ) (gui '(+JS +Button) "clear" '(clr> (: home view)) ) ) ) # Dialogs (de _dlg (Attr Env) (let L (get "*Lst" (- "*Cnt" *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) ) (de alert (Env . Prg) (_dlg 'alert Env) ) (de note (Str Lst) (alert (env '(Str Lst)) ( 'note Str) (--) (for S Lst (
S)) (okButton) ) ) (de ask (Str . Prg) (alert (env '(Str Prg)) ( '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)) ) (T (=: env (env Lst)) (=: diaform T) (run Prg 1) ) ) ) (de saveButton (Exe) (gui '(+Button) ,"Save" Exe) ) (de closeButton (Lbl Exe) (when (get "*App" 'top) (gui '(+Rid +Close +Button) Lbl Exe) ) ) (de okButton (Exe) (when (get "*App" 'top) (if (=T Exe) (gui '(+Force +Close +Button) T "OK") (gui '(+Close +Button) "OK" Exe) ) ) ) (de cancelButton () (when (get "*App" 'top) (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 "*Lst" (- "*Cnt" *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) (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) ) (T "@") ) ) (dm show> ("Var") (if (: act) (super "Var") (") ) (de (X Y . Prg) (prin "") (htPrin Prg 2) (prinl "") ) (de font (X . Prg) (ifn Prg (cond ((num? X) (setq *FontSize X)) ((sym? X) (setq *FontFamily X)) (T (setq *FontSize (car X) *FontFamily (fin X))) ) (cond ((num? X) (let *FontSize X (run Prg 1 '(*FontSize)) ) ) ((sym? X) (let *FontFamily X (run Prg 1 '(*FontFamily)) ) ) (T (let (*FontSize (car X) *FontFamily (fin X)) (run Prg 1 '(*FontSize *FontFamily)) ) ) ) ) ) (de width (N . Prg) (ifn Prg (setq *StrokeWidth N) (let *StrokeWidth N (run Prg 1 '(*StrokeWidth)) ) ) ) (de italic "Prg" (let *FontStyle 'italic (run "Prg") ) ) (de bold "Prg" (let *FontWeight 'bold (run "Prg") ) ) (de indent ("X" . "Prg") (prinl "") (dec '*DX "X") (prog1 (run "Prg") (prinl "") ) ) (de rotate ("A" . "Prg") (prinl "") (prog1 (run "Prg") (prinl "") ) ) (de window ("X" "Y" *DX *DY . "Prg") (prinl "") (let *Pos 0 (prog1 (run "Prg") ) (prinl "") ) ) (de ps @ (let A (arg 1) (if (member A (0 NIL T)) (next) (off A) ) (prin "") (while (args) (let X (next) (if (atom X) (ht:Prin X) (casq (pop 'X) (B # Bold (prin (if X "" "")) ) (I # Italic (prin (if X "" "")) ) (S # Superscript (prin (if X "" "")) ) (U # Underline (prin (if X "" "")) ) (L # Line through (prin (if X "" "")) ) (C # Color (if X (prin "") (prin "") ) ) ) ) ) ) (prinl "") ) (de down (N) (inc '*Pos (or N *FontSize)) ) (de table (Lst . Prg) (let (PosX 0 Max *FontSize) (mapc '((N Exe) (window PosX *Pos N Max (if (atom Exe) (ps NIL (eval Exe 2)) (eval Exe 2 '(*Pos *DX *DY)) ) (inc 'PosX N) (setq Max (max *Pos Max)) ) ) Lst Prg ) (inc '*Pos Max) ) ) (de hline (Y X2 X1) (inc 'Y *Pos) (polyline "black" (or X2 *DX) Y (or X1 0) Y) ) (de vline (X Y2 Y1) (polyline "black" X (or Y2 *DY) X (or Y1 0)) ) (de brief (Flg Font Abs . Prg) (when Flg (polyline "black" 10 265 19 265) # Faltmarken (polyline "black" 10 421 19 421) ) (polyline "black" 50 106 50 103 53 103) # Fenstermarken (polyline "black" 50 222 50 225 53 225) (polyline "black" 288 103 291 103 291 106) (polyline "black" 288 225 291 225 291 222) (polyline "black" 50 114 291 114) # Absender (window 60 102 220 10 (font Font (ps 0 Abs)) ) (window 65 125 210 90 (run Prg 1) ) ) # Convert to PDF (de svgPdf ("Dst" . "Prg") (let "Src" (tmp "pdf.svg") (out "Src" (run "Prg")) (call "rsvg-convert" "-f" "pdf" "-o" "Dst" "Src") ) "Dst" ) # Multipage PDF (de pdf (*DX *DY "Dst" . "Prg") (zero *Page) (run "Prg") (apply call (make (for I *Page (link (tmp "pdf" I ".svg")) ) ) "rsvg-convert" "--dpi-x" 72 "--dpi-y" 72 "-f" "pdf" "-o" "Dst" ) "Dst" ) (de page "Prg2" (out (tmp "pdf" (inc '*Page) ".svg") ( *DX *DY "pt" (run "Prg2") ) ) ) (de httpPdf (File) (httpEcho File "application/pdf" 1) ) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/term.l���������������������������������������������������������������������������������0000644�0001750�0001750�00000002433�11347735141�012642� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 16mar10abu # (c) Software Lab. Alexander Burger ### Key codes ### (setq *XtF1 (in '("tput" "kf1") (line T)) *XtF2 (in '("tput" "kf2") (line T)) *XtF3 (in '("tput" "kf3") (line T)) *XtF4 (in '("tput" "kf4") (line T)) *XtF5 (in '("tput" "kf5") (line T)) *XtF6 (in '("tput" "kf6") (line T)) *XtF7 (in '("tput" "kf7") (line T)) *XtF8 (in '("tput" "kf8") (line T)) *XtF9 (in '("tput" "kf9") (line T)) *XtF10 (in '("tput" "kf10") (line T)) *XtF11 (in '("tput" "kf11") (line T)) *XtF12 (in '("tput" "kf12") (line T)) *XtMenu "^[[29~" #? *XtIns (in '("tput" "kich1") (line T)) *XtDel (in '("tput" "kdch1") (line T)) *XtPgUp (in '("tput" "kpp") (line T)) *XtPgDn (in '("tput" "knp") (line T)) *XtUp (in '("tput" "cuu1") (line T)) *XtDown "^[[B" #? *XtRight (in '("tput" "cuf1") (line T)) *XtLeft "^[[D" #? *XtEnd "^[[F" #? *XtHome (in '("tput" "home") (line T)) ) ### Cursor movements ### (de xtUp (N) (do N (prin *XtUp)) ) (de xtDown (N) (do N (prin *XtDown)) ) (de xtRight (N) (do N (prin *XtRight)) ) (de xtLeft (N) (do N (prin *XtLeft)) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/test.l���������������������������������������������������������������������������������0000644�0001750�0001750�00000001137�12620365164�012651� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 10nov15abu # (c) Software Lab. Alexander Burger ### Unit Tests ### # Local usage: # ./pil lib/test.l -bye + # Global usage: # pil @lib/test.l -bye + (setq *CMD (cmd) *PWD (in '(pwd) (line T)) ) (test T (pool (tmp "db"))) (load "@test/src/main.l" "@test/src/apply.l" "@test/src/flow.l" "@test/src/sym.l" "@test/src/subr.l" "@test/src/big.l" "@test/src/io.l" "@test/src/db.l" "@test/src/net.l" "@test/src/ext.l" "@test/src/ht.l" ) (load "@test/lib.l") (load "@test/lib/misc.l") (load "@test/lib/lint.l") (load "@test/lib/math.l") (msg 'OK) # vi:et:ts=3:sw=3 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/tinymce.l������������������������������������������������������������������������������0000644�0001750�0001750�00000011522�12513741157�013342� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 16apr15abu # (c) Software Lab. Alexander Burger ### TinyMCE Interface ### (allow "tinymce/" T) (de () (javascript "tinymce/tinymce.min.js" " tinymce.init({ selector: 'textarea', plugins: 'textcolor colorpicker hr directionality paste', toolbar: 'forecolor bold italic superscript underline strikethrough | hr | removeformat', nowrap: true, menubar: false, statusbar: false, min_height: 12, toolbar_items_size: 'small', language: '" (or *Lang "en") "', entity_encoding: 'raw', force_br_newlines : true, force_p_newlines : false, forced_root_block : '', setup: function(ed) { ed.on('init', function(e) { var fld = ed.getElement(); fld.pilSetValue = function(val) { ed.setContent(val); } fld.pilDisable = function(flg) { ed.getBody().setAttribute('contenteditable', !flg); } fld.pilDisable(fld.disabled); } ) ed.on('change', function(e) { ed.getElement().value = ed.getContent(); fldChg(ed.getElement()); } ) } } )" ) ) # Parse HTML text (de htmlText (Text) (let (Lst (split (chop Text) "<" ">") Tag) (make (recur (Tag) (loop (let? S (pop 'Lst) (unless (= S '("^J")) (link (ht:Pack S)) ) ) (NIL Lst) (T (and (= "/" (caar Lst)) (= Tag (cdar Lst))) (pop 'Lst) ) (let S (pop 'Lst) (cond ((= S '`(chop "br /")) (link 0) ) ((= S '`(chop "hr /")) (link T) ) ((and (= "p" (car S)) (sp? (cadr S))) (and (made) (link 0)) (recurse '("p")) (and (find bool Lst) (link 0)) ) ((= S '`(chop "strong")) (link '(B . T)) (recurse S) (link '(B)) ) ((= S '`(chop "em")) (link '(I . T)) (recurse S) (link '(I)) ) ((= S '`(chop "sup")) (link '(S . T)) (recurse S) (link '(S)) ) ((= S '`(chop "span style=\"text-decoration: underline;\"")) (link '(U . T)) (recurse '("s" "p" "a" "n")) (link '(U)) ) ((= S '`(chop "span style=\"text-decoration: line-through;\"")) (link '(L . T)) (recurse '("s" "p" "a" "n")) (link '(L)) ) ((head '`(chop "span style=\"color: ") S) (setq S (nth S 21)) (link (cons 'C (pack (head 6 S)))) (recurse '("s" "p" "a" "n")) (link '(C)) ) (T (recurse (car (split S " ")))) ) ) ) ) ) ) ) # Remove markup (de unmarkup (Text) (let L (chop Text) (use (@A @X @Z) (while (match '(@A "<" @X ">" @Z) L) (setq L (conc @A (and @A @Z (head '("b" "r") @X) (cons " ")) @Z ) ) ) ) (extract pack (split L " " "^J")) ) ) # HTML text index relation (class +HtIdx +Fold +Idx) (dm has> (Val X) (and (or (= Val X) (member Val (mapcar fold (unmarkup X))) ) X ) ) (dm rel> (Obj Old New Hook) (setq Old (unmarkup Old) New (unmarkup New)) (for O (diff Old New) (super Obj O NIL Hook) ) (for N (diff New Old) (super Obj NIL N Hook) ) ) (dm rel?> (Obj Val Hook) (for V (unmarkup Val) (NIL (super Obj V Hook)) T ) ) (dm lose> (Obj Val Hook) (for V (unmarkup Val) (super Obj V Hook) ) ) (dm keep> (Obj Val Hook) (for V (unmarkup Val) (super Obj V Hook) ) ) NIL ####### README ####### Using the TinyMCE 4.x Javascript/HTML WYSIWYG editor in PicoLisp applications 1. Get 'tinymce' $ (cd /some/path; unzip tinymce_4.1.7.zip) 2. In the application's runtime directory, create a link to the tinymce installation, e.g.: $ ln -s /some/path/tinymce/js/tinymce tinymce 3. Load "@lib/tinymce.l" at startup (load .. "@lib/tinymce.l" ..) 4. On each page where you want to use tinymce in textareas, call () before the first textarea, e.g.: (action (html 0 "Title" "lib.css" NIL (form NIL .. () (gui '(+Var +TextField) '*Text 60 8) # Textarea .. # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/too.l����������������������������������������������������������������������������������0000644�0001750�0001750�00000040701�12527341160�012467� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 21may15abu # (c) Software Lab. Alexander Burger (de admin "Prg" (out 2 (prinl *Pid " + Admin " (stamp)) (loop (tell 'bye 2) (NIL (lock)) (wait 200) ) (for (F . @) (or *Dbs (2)) (when (dbck F) (quit "DB Check" (cons F @)) ) ) (run "Prg") (when (dbgc) (println 'dbgc @) ) (prinl *Pid " - Admin " (stamp)) ) ) ### Local Backup ### (de snapshot (Dst . @) (when (info (pack Dst "/1")) (for (L (flip (sort (extract format (dir Dst)))) L) (let N (pop 'L) (call 'mv (pack Dst '/ N) (pack Dst '/ (inc N))) (when (> (car L) (*/ N 9 10)) (call 'rm "-rf" (pack Dst '/ (pop 'L))) ) ) ) ) (when (call 'mkdir (pack Dst "/1")) (while (args) (let (Lst (filter bool (split (chop (next)) '/)) Src (car Lst) Old (pack Dst "/2/" Src) New (pack Dst "/1/" Src) ) (recur (Lst Src Old New) (ifn (cdr Lst) (recur (Src Old New) (cond ((=T (car (info Src T))) # Directory (call 'mkdir "-p" New) (for F (dir Src T) (unless (member F '("." "..")) (recurse (pack Src '/ F) (pack Old '/ F) (pack New '/ F) ) ) ) (call 'touch "-r" Src New) ) ((= (info Src T) (info Old T)) # Same `(if (== 64 64) '(native "@" "link" 'I Old New) '(call 'ln Old New) ) ) (T (call 'cp "-a" Src New)) ) ) # Changed or new (call 'mkdir "-p" New) (recurse (cdr Lst) (pack Src '/ (cadr Lst)) (pack Old '/ (cadr Lst)) (pack New '/ (cadr Lst)) ) (call 'touch "-r" Src New) ) ) ) ) ) ) (de purge (Dst N) (for D (dir Dst) (when (>= (format D) N) (call 'rm "-rf" (pack Dst '/ D)) ) ) ) ### DB Garbage Collection ### (de dbgc () (markExt *DB) (let Cnt 0 (finally (mark 0) (for (F . @) (or *Dbs (2)) (for (S (seq F) S (seq S)) (unless (mark S) (inc 'Cnt) (and (isa '+Entity S) (zap> S)) (zap S) ) ) ) ) (commit) (when *Blob (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (when (match Pat F) (unless (and (setq S (extern (pack (replace @S '/)))) (get S (intern (pack @R))) ) (inc 'Cnt) (call 'rm (pack F)) ) (wipe S) ) ) ) ) ) ) (gt0 Cnt) ) ) (de markExt (S) (unless (mark S T) (markData (val S)) (maps markData S) (wipe S) ) ) (de markData (X) (while (pair X) (markData (pop 'X)) ) (and (ext? X) (markExt X)) ) ### DB Mapping ### (de dbMap ("ObjFun" "TreeFun") (default "ObjFun" quote "TreeFun" quote) (finally (mark 0) (_dbMap *DB) (dbMapT *DB) ) ) (de _dbMap ("Hook") (unless (mark "Hook" T) ("ObjFun" "Hook") (for "X" (getl "Hook") (when (pair "X") (if (and (ext? (car "X")) (not (isa '+Entity (car "X"))) (sym? (cdr "X")) (find '(("X") (isa '+relation (car "X"))) (getl (cdr "X")) ) ) (let ("Base" (car "X") "Cls" (cdr "X")) (dbMapT "Base") (for "X" (getl "Base") (when (and (pair "X") (sym? (cdr "X")) (pair (car "X")) (num? (caar "X")) (ext? (cdar "X")) ) ("TreeFun" "Base" (car "X") (cdr "X") "Cls" "Hook") (iter (tree (cdr "X") "Cls" "Hook") _dbMap) ) ) (wipe "Base") ) (dbMapV (car "X")) ) ) ) (wipe "Hook") ) ) (de dbMapT ("Base") (let "X" (val "Base") (when (and (pair "X") (num? (car "X")) (ext? (cdr "X")) ) ("TreeFun" "Base" "X") (iter "Base" dbMapV) ) ) ) (de dbMapV ("X") (while (pair "X") (dbMapV (pop '"X")) ) (and (ext? "X") (_dbMap "X")) ) ### DB Check ### (de dbCheck () (while (lock) # Lock whole database (tell 'bye 2) (wait 200) ) (for (F . N) (or *Dbs (2)) # Low-level integrity check (unless (pair (println F N (dbck F T))) (quit 'dbck @) ) ) (dbMap # Check tree structures NIL '((Base Root Var Cls Hook) (println Base Root Var Cls Hook) (unless (= (car Root) (chkTree (cdr Root))) (quit "Tree size mismatch") ) (when Var (scan (tree Var Cls Hook) '((K V) (or (isa Cls V) (isa '+Alt (meta V Var)) (quit "Bad Type" V) ) (unless (has> V Var (if (pair K) (car K) K)) (quit "Bad Value" K) ) ) NIL T T ) ) ) ) (and *Dbs (dbfCheck)) # Check DB file assignments (and (dangling) (println 'dangling @)) # Show dangling index references (and (badECnt) (println 'badECnt @)) # Show entity count mismatches T ) # Check Index References (de dangling () (make (dbMap '((This) (and (isa '+Entity This) (not (: T)) (dangle This) (link @) ) ) ) ) ) (de dangle (Obj) (and (make (for X (getl Obj) (let V (or (atom X) (pop 'X)) (unless (rel?> Obj X V) (link X) ) ) ) ) (cons Obj @) ) ) # Entity Counts (de badECnt () (let Cnt NIL (for (F . @) (or *Dbs (2)) (for (This (seq F) This (seq This)) (and (isa '+Entity This) (not (: T)) (for Cls (type This) (recur (Cls) (or (== '+Entity Cls) (for C (type Cls) (T (recurse C) (and (get *DB Cls) (accu 'Cnt Cls 1)) ) ) ) ) ) ) ) ) (filter '((X) (<> (cdr X) (get *DB (car X) 0)) ) Cnt ) ) ) (de fixECnt () (for X (getl *DB) (and (pair X) (set (car X) 0)) ) (commit) (for (F . @) *Dbs (for (This (seq F) This (seq This)) (and (isa '+Entity This) (not (: T)) (incECnt This) ) ) ) (commit) ) ### Rebuild tree ### (de rebuild (X Var Cls Hook) (let Lst NIL (let? Base (get (or Hook *DB) Cls) (unless X (setq Lst (if (; (treeRel Var Cls) hook) (collect Var Cls Hook) (collect Var Cls) ) ) ) (zapTree (get Base Var -1)) (put Base Var NIL) (commit) ) (nond (X (let Len (length Lst) (recur (Lst Len) (unless (=0 Len) (let (N (>> 1 (inc Len)) L (nth Lst N)) (re-index (car L) Var Hook) (recurse Lst (dec N)) (recurse (cdr L) (- Len N)) ) ) ) ) ) ((atom X) (for Obj X (re-index Obj Var Hook) ) ) (NIL (for (Obj (seq X) Obj (seq Obj)) (and (isa Cls Obj) (re-index Obj Var Hook)) ) ) ) (commit) ) ) (de re-index (Obj Var Hook) (unless (get Obj T) (when (get Obj Var) (rel> (meta Obj Var) Obj NIL (put> (meta Obj Var) Obj NIL @) Hook ) (at (0 . 10000) (commit)) ) ) ) ### Database file management ### (de dbfCheck () (for "Cls" (all) (when (and (= `(char "+") (char "Cls")) (isa '+Entity "Cls")) (or (get "Cls" 'Dbf) (meta "Cls" 'Dbf) (println 'dbfCheck "Cls") ) (for Rel (getl "Cls") (and (pair Rel) (or (isa '+index (car Rel)) (isa '+Swap (car Rel)) (find '((B) (or (isa '+index B) (isa '+Swap B) ) ) (; Rel 1 bag) ) ) (not (; @ dbf)) (println 'dbfCheck (cdr Rel) "Cls") ) ) ) ) ) (de dbfMigrate (Pool Dbs) (let (scan '(("Tree" "Fun") (let "Node" (cdr (root "Tree")) (if (ext? (fin (val "Node"))) (recur ("Node") (let? "X" (val "Node") (recurse (cadr "X")) ("Fun" (car "X") (cdddr "X")) (recurse (caddr "X")) (wipe "Node") ) ) (recur ("Node") (let? "X" (val "Node") (recurse (car "X")) (for "Y" (cdr "X") ("Fun" (car "Y") (or (cddr "Y") (fin (car "Y")))) (recurse (cadr "Y")) ) (wipe "Node") ) ) ) ) ) iter '(("Tree" "Bar") (scan "Tree" '(("K" "V") ("Bar" "V"))) ) zapTree '((Node) (let? X (val Node) (zapTree (cadr X)) (zapTree (caddr X)) (zap Node) ) ) ) (dbfUpdate) ) (let Lst (make (for (S *DB S (seq S)) (link (cons S (val S) (getl S))) ) ) (pool) (call 'rm (pack Pool 1)) (pool Pool Dbs) (set *DB (cadar Lst)) (putl *DB (cddr (pop 'Lst))) (for L Lst (let New (new T) (set New (cadr L)) (putl New (cddr L)) (con L New) ) ) (set *DB (dbfReloc0 (val *DB) Lst)) (for X Lst (set (cdr X) (dbfReloc0 (val (cdr X)) Lst)) (putl (cdr X) (dbfReloc0 (getl (cdr X)) Lst)) ) (commit) (dbMap # Relocate base symbols '((Obj) (putl Obj (dbfReloc0 (getl Obj) Lst)) (commit) ) '((Base Root Var Cls Hook) (when (asoq (cdr Root) Lst) (con Root (cdr @)) (touch Base) (commit) ) ) ) ) ) (de dbfUpdate () (dbMap # Move '((Obj) (let N (or (meta Obj 'Dbf 1) 1) (unless (= N (car (id Obj T))) (let New (new N) (set New (val Obj)) (putl New (getl Obj)) (set Obj (cons T New)) ) (commit) ) ) ) ) (when *Blob (for X (make (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (and (match Pat F) (setq S (extern (pack (replace @S '/)))) (=T (car (pair (val S)))) (link (cons (pack F) (blob (cdr (val S)) @R)) ) ) ) ) ) ) ) (and (dirname (cdr X)) (call 'mkdir "-p" @)) (call 'mv (car X) (cdr X)) ) ) (dbMap # Relocate '((Obj) (when (=T (car (pair (val Obj)))) (setq Obj (cdr (val Obj))) ) (when (isa '+Entity Obj) (putl Obj (dbfReloc (getl Obj))) (commit) ) ) '((Base Root Var Cls Hook) (if Var (dbfRelocTree Base Root (tree Var Cls Hook) (or (get Cls Var 'dbf) (and (find '((B) (or (isa '+index B) (isa '+Swap B) ) ) (get Cls Var 'bag) ) (get @ 'dbf) ) ) ) (dbfRelocTree Base Root Base) ) ) ) (dbgc) ) (de dbfReloc (X) (cond ((pair X) (cons (dbfReloc (car X)) (dbfReloc (cdr X))) ) ((and (ext? X) (=T (car (pair (val X))))) (cdr (val X)) ) (T X) ) ) (de dbfReloc0 (X Lst) (cond ((pair X) (cons (dbfReloc0 (car X) Lst) (dbfReloc0 (cdr X) Lst)) ) ((asoq X Lst) (cdr @)) (T X) ) ) (de dbfRelocTree (Base Root Tree Dbf) (let? Lst (make (scan Tree '((K V) (link (cons K V))))) (zapTree (cdr Root)) (touch Base) (set Root 0) (con Root) (commit) (for X (make (for (Lst (cons Lst) Lst (mapcan '((L) (let (N (/ (inc (length L)) 2) X (nth L N)) (link (car X)) (make (and (>= N 2) (link (head (dec N) L))) (and (cdr X) (link @)) ) ) ) Lst ) ) ) ) (store Tree (dbfReloc (car X)) (dbfReloc (cdr X)) Dbf ) ) (commit) ) ) ### Dump Objects ### (zero *DumpBlob) (dm (dumpKey> . +Entity) () (unless (: T) (pick '((X) (when (isa '+Key (meta This (fin X))) (if (meta This (fin X) 'hook) (cons (fin X) (get This @) X) (cons (fin X) X) ) ) ) (getl This) ) ) ) (dm (dumpType> . +Entity) () (type This) ) (dm (dumpValue> . +Entity) (X) X ) (de dump "CL" (let "C" (cons 0 10000) (for ("Q" (goal "CL") (asoq '@@ (prove "Q"))) (let (Obj (cdr @) K (fin (dumpExt Obj))) (for X (getl Obj) (unless (or (= K (fin X)) (= `(char "+") (char (fin X)))) (let? Y (dumpValue> Obj X) (cond ((pair Y) (prinl) (space 3) (if (atom (cdr Y)) (printsp (cdr Y)) (printsp (cadr Y)) (prin "`") ) (dumpVal (car Y)) ) ((isa '+Blob (meta Obj X)) (let F (blob Obj X) (ifn (info F) (msg F " no blob") (prinl) (space 3) (prin Y " `(tmp " (inc '*DumpBlob) ")") (call 'cp "-a" F (tmp *DumpBlob)) ) ) ) (T (prinl) (space 3) (print Y T) ) ) ) ) ) (prinl " )") ) (at "C" (println '(commit))) ) (println '(commit)) ) ) (de dumpExt (Obj) (prin "(obj ") (let K (dumpKey> Obj) (ifn (last K) (print (dumpType> Obj) (id Obj T)) (prin "(") (printsp (dumpType> Obj) (car K)) (dumpVal (cadr K)) (when (pair (cddr K)) (space) (dumpVal (car @)) ) (prin ")") ) K ) ) (de dumpVal (X) (nond ((atom X) (prin "(") (dumpVal (pop 'X)) (while (pair X) (space) (dumpVal (pop 'X)) ) (when X (prin " . ") (dumpVal X)) (prin ")") ) ((ext? X) (print X)) ((type X) (print (val X))) (NIL (prin "`") (dumpExt X) (prin ")")) ) ) # Dump/load data and blobs (de dumpDB ("Name" . "Prg") (out (pack "Name" ".l") (run "Prg")) (when (dir (tmp)) (out (pack "Name" ".tgz") (chdir (tmp) (in (append '("tar" "cfz" "-") (filter format @)) (echo) ) ) ) ) ) (de loadDB ("Name") (let Tgz (pack "Name" ".tgz") (when (and (info Tgz) (n0 (car @))) (in Tgz (chdir (tmp) (out '("tar" "xfz" "-") (echo)) ) ) ) ) (load (pack "Name" ".l") ) ) ### Debug ### `*Dbg (noLint 'dbfMigrate 'iter) # vi:et:ts=3:sw=3 ���������������������������������������������������������������picoLisp/lib/tsm.l����������������������������������������������������������������������������������0000644�0001750�0001750�00000000311�11515251456�012466� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 18jan11abu # (c) Software Lab. Alexander Burger (when (sys "TERM") (setq *Tsm (cons (in '("tput" "smul") (line T)) (in '("tput" "rmul") (line T)) ) ) ) # vi:et:ts=3:sw=3 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/user.l���������������������������������������������������������������������������������0000644�0001750�0001750�00000001500�12522147046�012640� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 05may15abu # (c) Software Lab. Alexander Burger (must "User Administration" UserAdmin) (menu ,"User Administration" (idForm ,"User" '(choUser) 'nm '+User T '(may Delete) '((: nm)) ( 2 ,"Login Name" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"User" 30) ,"Password" (gui '(+Able +PasswdField) '(or (may Password) (== *Login (: home obj))) 30 ) ,"Role" (gui '(+Able +E/R +Obj +TextField) '(may RoleAdmin) '(role : home obj) '(nm +Role) T ) ,"Full Name" (gui '(+E/R +TextField) '(nam : home obj) 40) ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) ( NIL (editButton T)) ) ) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/xhtml.l��������������������������������������������������������������������������������0000644�0001750�0001750�00000052753�12560115774�013043� 0����������������������������������������������������������������������������������������������������ustar �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 04aug15abu # (c) Software Lab. Alexander Burger # *JS "*JS" *Style *Menu *Tab *ID (mapc allow '(*JS *Menu *Tab *ID "!ping")) (setq *Menu 0 *Tab 1) (off "*JS") (de htPrin (Prg Ofs) (default Ofs 1) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) ) (de htJs () (for X "*JS" (prin " " (car X) "=\"") (ht:Prin (cdr X)) (prin "\"") ) ) (de htStyle (Attr) (cond ((atom Attr) (prin " class=\"") (ht:Prin Attr) (prin "\"") ) ((and (atom (car Attr)) (atom (cdr Attr))) (prin " " (car Attr) "=\"") (ht:Prin (cdr Attr)) (prin "\"") ) (T (mapc htStyle Attr)) ) ) (de dfltCss (Cls) (htStyle (cond ((not *Style) Cls) ((atom *Style) (pack *Style " " Cls)) ((and (atom (car *Style)) (atom (cdr *Style))) (list Cls *Style) ) ((find atom *Style) (replace *Style @ (pack @ " " Cls)) ) (T (cons Cls *Style)) ) ) ) (de tag (Nm Attr Ofs Prg) (prin "<" Nm) (and Attr (htStyle @)) (prin ">") (if (atom Prg) (ht:Prin (eval Prg Ofs)) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) ) (prin "") ) (de (Nm Attr . Prg) (tag Nm Attr 2 Prg) ) (de ("JS" . "Prg") (let "*JS" (append "*JS" "JS") (run "Prg") ) ) (de style (X S) (nond (X S) (S X) ((pair X) (cond ((atom S) (pack S " " X)) ((and (atom (car S)) (atom (cdr S))) (list X S) ) ((find atom S) (replace S @ (pack @ " " X)) ) (T (cons X S)) ) ) ((or (pair (car X)) (pair (cdr X))) (cond ((atom S) (list S X)) ((and (atom (car S)) (atom (cdr S))) (if (= (car X) (car S)) X (list S X) ) ) (T (cons X (delete (assoc (car X) S) S)) ) ) ) (NIL (for Y X (setq S (style Y S)) ) ) ) ) (de ") (prinl "") (and (fin Ttl) ( 'title NIL @) (prinl)) (mapc prinl Ttl) (and *Host *Port (prinl "")) (when Css (if (atom Css) ("css" Css) (mapc "css" Css) (when (fin Css) (prinl "") ) ) ) (and *SesId (javascript NIL "SesId=\"" @ "\"")) (mapc javascript *JS) (when (=0 Upd) (javascript NIL "document.addEventListener('visibilitychange', function() {if (!document.hidden) window.location.replace(location.href)})" ) ) (prinl "") (tag 'body Attr 2 Prg) (prinl "") ) ) (de "css" (Css) (prinl "") ) (de javascript (JS . @) (when *JS (when JS (prinl "") ) (when (rest) (prinl "") ) ) ) (de ping (Min) (timeout (setq *Timeout (* Min `(* 60 1000)))) (respond) ) (de (Min) (javascript NIL "onload=ping(" Min ")") ) (de
(Attr . Prg) (tag 'div Attr 2 Prg) (prinl) ) (de (Attr . Prg) (tag 'span Attr 2 Prg) ) (de
Prg (htPrin Prg 2) (prinl "
") ) (de -- () (prinl "
") ) (de ---- () (prinl "

") ) (de
() (prinl "
") ) (de (N) (do (or N 1) (prin " ")) ) (de Prg (tag 'small NIL 2 Prg) ) (de Prg (tag 'big NIL 2 Prg) ) (de Prg (tag 'em NIL 2 Prg) ) (de Prg (tag 'strong NIL 2 Prg) ) (de

(Attr . Prg) (tag 'h1 Attr 2 Prg) (prinl) ) (de

(Attr . Prg) (tag 'h2 Attr 2 Prg) (prinl) ) (de

(Attr . Prg) (tag 'h3 Attr 2 Prg) (prinl) ) (de

(Attr . Prg) (tag 'h4 Attr 2 Prg) (prinl) ) (de

(Attr . Prg) (tag 'h5 Attr 2 Prg) (prinl) ) (de
(Attr . Prg) (tag 'h6 Attr 2 Prg) (prinl) ) (de

(Attr . Prg) (tag 'p Attr 2 Prg) (prinl) ) (de 

 (Attr . Prg)
   (tag 'pre Attr 2 Prg)
   (prinl) )

(de 
     (Attr . Prg)
   (tag 'ol Attr 2 Prg)
   (prinl) )

(de
(Attr Ttl "Head" . Prg) (tag 'table Attr 1 (quote (and Ttl (tag 'caption NIL 1 Ttl)) (when (find cdr "Head") (tag 'tr NIL 1 (quote (for X "Head" (tag 'th (car X) 2 (cdr X)) ) ) ) ) (htPrin Prg 2) ) ) (prinl) ) (de (Attr . Prg) (tag 'tr NIL 1 (quote (let (L Prg H (up "Head")) (while L (let (X (pop 'L) A (car (pop 'H)) N 1) (while (== '- (car L)) (inc 'N) (pop 'L) (pop 'H) ) (tag 'td (style Attr (style (and (> N 1) (cons "colspan" N)) (if (== 'align A) '(align (align . right)) A) ) ) 1 (quote (if (atom X) (ht:Prin (eval X 1)) (eval X 1) ) ) ) ) ) ) ) ) ) (de (Attr . Prg) (tag 'tr Attr 2 Prg) ) (de
(Attr . Prg) (tag 'th Attr 2 Prg) ) (de
(Attr . Prg) (tag 'td Attr 2 Prg) ) (de (X . Lst) (tag 'table 'grid 1 (quote (while Lst (tag 'tr NIL 1 (quote (use X (let L (and (sym? X) (chop X)) (do (or (num? X) (length X)) (let (C (cond ((pair X) (pop 'X)) ((= "." (pop 'L)) 'align) ) E (pop 'Lst) ) (unless (== '- E) (when (== '- (car Lst)) (let N 1 (for (P Lst (and P (== '- (pop 'P)))) (inc 'N) ) (push 'N "colspan") (setq C (if C (list C N) N)) ) ) (tag 'td C 1 (quote (if (atom E) (ht:Prin (eval E 1)) (eval E 1) ) ) ) ) ) ) ) ) ) ) ) ) ) (prinl) ) (de Lst ( '(width . "100%") NIL NIL ( NIL (
'((width . "33%") (align . left)) (eval (car Lst) 1) ) ( '((width . "34%") (align . center)) (eval (cadr Lst) 1) ) ( '((width . "33%") (align . right)) (eval (caddr Lst) 1) ) ) ) ) (de Lst ( '(width . "100%") NIL '((norm) (align)) ( NIL (eval (car Lst) 1) (run (cdr Lst) 1) ) ) ) (de tip ("X" "Txt") ( (cons 'title (glue "^J" "X")) "Txt") ) (de ("X" . "Prg") (let *Style (style (cons 'title (glue "^J" "X")) *Style) (run "Prg") ) ) # Layout (de "Lst" (let ("X" 0 "Y" 0) (recur ("Lst" "Y") (for "L" "Lst" (let ("Args" (mapcar eval (cddar "L")) "DX" (eval (caar "L")) "DY" (eval (cadar "L")) "Cls" (unless (sub? ":" (car "Args")) (pop '"Args")) "Style" (cons 'style (glue "; " (cons "position:absolute" (pack "top:" (abs "Y") (if (ge0 "Y") "px" "%")) (pack "left:" (abs "X") (if (ge0 "X") "px" "%")) (cond ((=0 "DX") "min-width:100%") ("DX" (pack "width:" (abs @) (if (ge0 "DX") "px" "%")) ) ) (cond ((=0 "DY") "min-height:100%") ("DY" (pack "height:" (abs @ ) (if (ge0 "DY")"px" "%")) ) ) "Args" ) ) ) ) (prog1 (if "Cls" (list "Cls" "Style") "Style") # -> '@' (eval (cadr "L")) ) (let "X" (+ "X" "DX") (recurse (cddr "L") "Y") ) (inc '"Y" "DY") ) ) ) ) ) # Menus (de urlMT (Url Menu Tab Id Str) (pack Url "?" "*Menu=+" Menu "&*Tab=+" Tab "&*ID=" (ht:Fmt Id) Str) ) (de Lst (let (M 1 N 1 E 2 U) (recur (Lst N E) (
    NIL (for L Lst (nond ((car L) (
  • NIL (htPrin (cdr L) 2))) ((=T (car L)) (if (setq U (eval (cadr L) E)) (
  • (pack (if (= U *Url) 'act 'cmd) N) ( "-->" ( (eval (car L) E) (urlMT U *Menu (if (= U *Url) *Tab 1) (eval (caddr L)) (eval (cadddr L)) ) ) ) ) (
  • (pack 'cmd N) (ht:Prin (eval (car L) E)) ) ) ) ((bit? M *Menu) (
  • (pack 'sub N) ( ,"Open submenu" ( (eval (cadr L) E) (urlMT *Url (| M *Menu) *Tab *ID) ) ) ) (setq M (>> -1 M)) (recur (L) (for X (cddr L) (when (=T (car X)) (recurse X) (setq M (>> -1 M)) ) ) ) ) (NIL (
  • (pack 'top N) ( ,"Close submenu" ( (eval (cadr L) E) (urlMT *Url (x| M *Menu) *Tab *ID) ) ) (setq M (>> -1 M)) (recurse (cddr L) (inc N) (inc E)) ) ) ) ) ) ) ) ) (de Lst (use U (
      NIL (for (I . M) Lst (if (= I *Menu) (
    • "top" ( (eval (car M) 1) (urlMT *Url 0 *Tab *ID) ) (
        NIL (for L (cdr M) (if (setq U (eval (cadr L) 1)) (
      • (if (= U *Url) "act" "cmd") ( (eval (car L) 1) (urlMT U 0 (if (= U *Url) *Tab 1) (eval (caddr L)) (eval (cadddr L)) ) ) ) (
      • "cmd" (ht:Prin (eval (car L) 1)) ) ) ) ) ) (
      • "sub" ( (eval (car M) 1) (urlMT *Url I *Tab *ID) ) ) ) ) ) ) ) (de bar? (Attr) (ifn (and *JS (gt0 *Menu)) Attr (cons (cons "onclick" (pack "if (!Btn.length) window.location.href='" (urlMT (sesId *Url) 0 *Tab *ID) "'") ) (if (pair (cdr Attr)) Attr (cons Attr)) ) ) ) # Update link (de updLink () ( ,"Update" ( 'step ( "@" (urlMT *Url *Menu *Tab *ID))) ) ) # Tabs (de Lst (
'tab NIL NIL (for (N . L) Lst (if (= N *Tab) (
'top (ht:Prin (eval (car L) 1))) ( 'sub ( (eval (car L) 1) (urlMT *Url *Menu N *ID)) ) ) ) ) (htPrin (get Lst *Tab -1) 2) ) ### DB Linkage ### (de mkUrl (Lst) (pack (pop 'Lst) "?" (make (while Lst (and (sym? (car Lst)) (= `(char '*) (char (car Lst))) (link (pop 'Lst) "=") ) (link (ht:Fmt (pop 'Lst))) (and Lst (link "&")) ) ) ) ) (de <$> (Str Obj Msg Tab) (cond ((not Obj) (ht:Prin Str)) ((=T Obj) ( Str (pack Msg Str))) ((send (or Msg 'url>) Obj (or Tab 1)) ( Str (mkUrl @)) ) (T (ht:Prin Str)) ) ) # Links to previous and next object (de stepBtn (Var Cls Hook Msg) (default Msg 'url>) ( 'step (use (Rel S1 S2) (if (isa '+Joint (setq Rel (meta *ID Var))) (let Lst (get *ID Var (; Rel slot)) (setq S2 (lit (cadr (memq *ID Lst))) S1 (lit (car (seek '((L) (== *ID (cadr L))) Lst))) ) ) (let (K (cond ((isa '+Key Rel) (get *ID Var) ) ((isa '+Fold Rel) (cons (fold (get *ID Var)) *ID) ) (T (cons (get *ID Var) (conc (mapcar '((S) (get *ID S)) (; Rel aux)) *ID ) ) ) ) Q1 (init (tree Var Cls Hook) K NIL) Q2 (init (tree Var Cls Hook) K T) ) (unless (get *ID T) (step Q1 T) (step Q2 T) ) (setq S1 (list 'step (lit Q1) T) S2 (list 'step (lit Q2) T) ) ) ) (if (and (eval S1) (send Msg @ *Tab)) ( ,"Next object of the same type" ( "<<<" (mkUrl @)) ) (prin "<<<") ) (prin " -- ") (if (and (eval S2) (send Msg @ *Tab)) ( ,"Next object of the same type" ( ">>>" (mkUrl @)) ) (prin ">>>") ) ) ) ) # Character Separated Values (off "*CSV") (de csv ("Nm" . "Prg") (call 'rm "-f" (tmp "Nm" ".csv")) (let "*CSV" (pack "+" (tmp "Nm" ".csv")) (run "Prg") ) ( "CSV" (tmp "Nm" ".csv")) ) (de <0> @ (when "*CSV" (out @ (prin (next)) (while (args) (prin "^I" (next)) ) (prinl "^M") ) ) ) (de <%> @ (prog1 (pass pack) (ht:Prin @) (prinl "
") (<0> @) ) ) (de ("Lst") (when "*CSV" (out @ (prin (eval (cadar "Lst"))) (for "S" (cdr "Lst") (prin "^I" (eval (cadr "S"))) ) (prinl "^M") ) ) "Lst" ) (de <+> (Str Obj Msg Tab) (if (sub? "^J" Str) (let L (split (chop Str) "^J") ( (cons 'title Str) (ht:Prin (car L))) (and "*CSV" (out @ (prin (glue " " L) "^I"))) ) (<$> Str Obj Msg Tab) (and "*CSV" (out @ (prin Str "^I"))) ) ) (de <-> (Str Obj Msg Tab) (if (sub? "^J" Str) (let L (split (chop Str) "^J") ( (cons 'title Str) (ht:Prin (car L))) (<0> (glue " " L)) ) (<$> Str Obj Msg Tab) (<0> Str) ) ) ### HTML form ### (de (Attr Url . Prg) (prin "
" ) (prin "") (tag 'fieldset Attr 2 Prg) (prinl "
") ) (de htmlVar ("Var") (prin "name=\"") (if (pair "Var") (prin (car "Var") ":" (cdr "Var")) (prin "Var") ) (prin "\"") ) (de htmlVal ("Var") (if (pair "Var") (cdr (assoc (cdr "Var") (val (car "Var")))) (val "Var") ) ) (de