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.l0000644000175000017500000003014213177102052011661 0ustar abuabu# 03nov17abu # (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 (++ Prg) 1))) ) ) (ifn (sym? (car Prg)) Prg (cons (cons 'job (cons (lit (make (while (atom (car Prg)) (link (cons (++ Prg) (eval (++ 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" (++ "Z") "Y" (++ "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) ) 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 (in File (let Lst (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 (in File (let P (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 uniq (Lst) (let R NIL (filter '((X) (not (idx 'R (cons (hash X) X) T)) ) Lst ) ) ) ### 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)) ) ) ) ) (unless (== 64 64) (from "####")) (de local () (symbols (list (car (symbols))) (read) ) ) (de import Lst (for Sym Lst (intern Sym T) ) Lst ) #### ### 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 ) ) # Accumulate (de accu (Var Key Val) (when Val (if (assoc Key (val Var)) (con @ (+ Val (cdr @))) (push Var (cons Key Val)) ) ) ) # Flooding Algorithm (de flood ("Lst" "Fun" "Init") (let G (mapcar '(("X") (cons "X" ("Fun" "X"))) "Lst") (for L G (for X (cdr L) (let A (asoq X G) (unless (memq (car L) (cdr A)) (con A (cons (car L) (cdr A))) ) ) ) ) (make (recur ("Init") (for X "Init" (unless (memq X (made)) (link X) (recurse (cdr (asoq X G))) ) ) ) ) ) ) ### Pretty Printing ### (de pretty (X N) (setq N (abs (space (or N 0)))) (while (and (pair X) (== 'quote (car X))) (prin "'") (++ X) ) (cond ((atom X) (print X)) ((memq (car X) '(de dm redef)) (_pretty (spPrt (++ X)) (spPrt (++ X)) (prtty1 X N Z) ) ) ((memq (car X) '(let let?)) (_pretty (cond ((atom (car X)) (spPrt (++ X)) (prtty? (++ X) N) ) ((>= 12 (size (car X))) (prin " (") (let Z (++ X) (prtty2 Z NIL Z) ) (prin ")") ) (T (nlPrt N) (prin "(") (let Z (++ X) (prtty2 Z (+ N 3) Z) ) (prin " )") ) ) (prtty1 X N Z) ) ) ((== 'for (car X)) (_pretty (cond ((or (atom (car X)) (atom (cdar X))) (spPrt (++ X)) (prtty? (++ X) N) ) ((>= 12 (size (car X))) (spPrt (++ X)) ) (T (nlPrt N) (prtty0 (++ X) (+ 3 N)) ) ) (prtty1 X N Z) ) ) ((== 'if2 (car X)) (_pretty (when (>= 12 (size (head 2 X))) (spPrt (++ X)) (spPrt (++ 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 (++ X)) (prtty2 X NIL Z) ) (prin ")") ) ) ((memq (car X) '(=: use later recur tab new)) (_pretty (space) (print (++ X)) (prtty1 X N Z) ) ) ((memq (car X) '(set setq default)) (_pretty (if (cdddr X) (prog (nlPrt N) (prtty2 X N Z) ) (spPrt (++ X)) (nlPrt1 (++ X) N) ) ) ) ((memq (car X) '(T NIL ! if ifn when unless case casq with catch throw push bind job in out err ctl)) (prtty3 X N) ) (T (prtty0 X N)) ) ) (de _pretty "Prg" (prin "(") (let Z X (print (++ X)) (run "Prg") ) (prin " )") ) (de prtty0 (X N) (prin "(") (let Z X (pretty (++ 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 (++ X) N) ) ) (de prtty2 (X N Z) (loop (print (++ X)) (NIL X) (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (if N (prtty? (++ X) N) (space) (print (++ 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 (++ X)) (when (or (atom (car X)) (>= 12 (size (car X)))) (spPrt (++ 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 '+-- (++ X)) (print '+---) (view (++ 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 (let A (if (cdr Prg) (cons 'and Prg) (car Prg)) (cons (list 'unless A (list 'quit "'assert' failed" (lit A)) ) ) ) ) ) # 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.l0000644000175000017500000000057312673265074011672 0ustar abuabu# 19mar16abu # (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" "@lib/too.l") (noLint 'pretty 'Z) (noLint '_pretty 'Z) ### @lib/form.l ### `(bool (getd 'form)) (noLint 'gui) (noLint 'choDlg 'gui) (noLint 'jsForm 'action) # vi:et:ts=3:sw=3 picoLisp/lib.css0000644000175000017500000001276713053775332012245 0ustar abuabu/* 24feb17abu * 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} .wrap {white-space: normal} .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 { border: 0; 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; font-size: smaller; 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 { border: 0; padding: 0; font-size: smaller; } .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; } /* Buttons */ .button { width: 80%; background-color: lightgrey; border: 1px solid black; border-radius: 3ex; text-align: center; display: table; padding: 2ex; margin: auto; } .button2 { display: table-cell; vertical-align: middle; font-weight: bold; font-size: larger; } 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.l0000644000175000017500000000751213015541121012422 0ustar abuabu# 24nov16abu # (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 (or (may UserAdmin) (== *Login This)) (list "@lib/user.l" '*ID This) ) ) ### Permission management ### (de permission Lst (while Lst (queue '*Perms (car Lst)) (def (++ Lst) (++ Lst)) ) ) (de may Args (mmeq Args (; *Login role perm)) ) (de must Args (unless (if (cdr Args) (find '((X) (if (atom X) (memq X (; *Login role perm)) (eval X) ) ) @ ) *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.l0000644000175000017500000000214313015542034012440 0ustar abuabu# 24nov16abu # (c) Software Lab. Alexander Burger # Exit on error (de *Err ~(as trail (for (L (trail T) L) (if (pair (car L)) (println (++ L)) (space 3) (println (++ L) (++ 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/android.l0000644000175000017500000002400113231120511013265 0ustar abuabu# 21jan18abu # (c) Software Lab. Alexander Burger (ifn (info "UUID") (off *Uuid) (setq *Uuid (in "UUID" (line T))) (for F '("JAVA" "LISP" "RQST" "RPLY" "BOSS") (native "@" "unlink" 'I F) (native "@" "mkfifo" 'I F `(oct "600")) ) (hear (open "BOSS")) ) (symbols 'android 'pico) # SSL (sys "LD_LIBRARY_PATH" "lib") (sys "SSL_CERT_FILE" "tls/cert.pem") # (boss 'sym ['any ..]) (local) boss (de boss @ (out "BOSS" (pr (rest))) ) # Android Context (local) CONTEXT (de CONTEXT . {OOOO40000000000}) # Java I/O # (java "cls" 'T ['any ..]) -> obj New object # (java 'obj 'msg ['any ..]) -> any Send message to object # (java 'obj "fld" ["fld" ..]) -> any Value of object field # (java "cls" 'msg ['any ..]) -> any Call method in class # (java "cls" "fld" ["fld" ..]) -> any Value of class field # (java T "cls" ["cls" ..]) -> obj Define interface # (java 'obj) -> [lst ..] Reflect object # (java "cls") -> cls Get class (local) [java1 java *Java *Lisp] (de java1 () (unless *Java (setq *Java (open "JAVA") *Lisp (open "LISP")) (let R (open "RPLY") (task (open "RQST") R R (in @ (out R (ext 65535 (pr (with (rd) # Obj (if (get (rd) This) (apply @ (rd)) (rd) NIL ) ) ) ) ) ) ) (push '*Fork '(off *Java *Lisp) (list 'mapc 'close (list R *Java *Lisp)) ) (forked) ) (queue '*Ext (cons 65535 java)) ) ) (de java @ (ext 65535 (out *Java (pr (rest))) (let? Val (in *Lisp (rd)) (if (== 'err (car (pair Val))) (nil (msg (cdr Val))) Val ) ) ) ) # Android device ID (local) [dev getString getContentResolver] (de dev () (java "android.provider.Settings$Secure" 'getString (java CONTEXT 'getContentResolver) "android_id" ) ) # Push-Load (local) loadTxt loadUrl (de loadTxt @ (java CONTEXT 'loadTxt (pass pack)) ) (de loadUrl @ (java CONTEXT 'loadUrl (pass pack)) ) # Clear WebView history and cache (local) [clearHistory clearCache] (de clearHistory () (java CONTEXT 'clearHistory) ) (de clearCache () (java CONTEXT 'clearCache) ) # Wake lock (local) [wake *Wake getSystemService newWakeLock acquire release)] (de wake @ (default *Wake (java (java CONTEXT 'getSystemService "power") # PowerManager 'newWakeLock 1 "PilWake" ) ) # PowerManager.WakeLock (when (args) # (wake 'flg) (java *Wake (if (next) 'acquire 'release)) ) ) # Check if WIFI is active (local) [getActiveNetworkInfo getType] (de wifi? () (and (java (java CONTEXT 'getSystemService "connectivity") # ConnectivityManager 'getActiveNetworkInfo ) # NetworkInfo (=1 (java @ 'getType)) ) ) # onnectivityManager.TYPE_WIFI # Generate file content URI (local) [fileUri getUriForFile getPackageName] (de fileUri (File) (java "android.support.v4.content.FileProvider" 'getUriForFile CONTEXT (pack (java CONTEXT 'getPackageName) ".fileprovider") (java "java.io.File" T File) ) ) # Update APK (local) [update? getInt] (de update? () (gt0 # (java (java CONTEXT 'getPackageManager) 'canRequestPackageInstalls) (java "android.provider.Settings$Secure" 'getInt (java CONTEXT 'getContentResolver) "install_non_market_apps" ) ) ) (local) [update startActivity setFlags setData fromFile] (de update (File) (java (; CONTEXT GUI) 'startActivity (prog1 (java "android.content.Intent" T "android.intent.action.INSTALL_PACKAGE") (java @ 'setFlags 1) # Intent.FLAG_GRANT_READ_URI_PERMISSION (java @ 'setData (fileUri File)) ) ) ) # Toast (local) toast (de toast (Str) (java CONTEXT 'toast Str) Str ) # Notification (local) [ notify cancel setSmallIcon setContentTitle setContentText setAutoCancel setLights setAction putExtra setContentIntent getActivity build ] (de notify (Id Ttl Msg File) (let N (java CONTEXT 'getSystemService "notification") # NotificationManager (ifn Ttl (java N 'cancel Id) (let B (java "android.support.v4.app.NotificationCompat$Builder" T CONTEXT) (java B 'setSmallIcon (java "de.software_lab.pilbox.R$drawable" "notify")) (java B 'setContentTitle Ttl) (java B 'setContentText Msg) (java B 'setAutoCancel T) (java B 'setLights `(hex "FFFFFF") 500 500) (let Intent (java "android.content.Intent" T CONTEXT (java "de.software_lab.pilbox.PilBoxActivity")) # Activity class (java Intent 'setFlags `(hex "24000000")) # FLAG_ACTIVITY_SINGLE_TOP | FLAG_ACTIVITY_NEW_TASK (when File (java Intent 'setAction "RPC") (java Intent 'putExtra "LOAD" File) ) (java B 'setContentIntent (java "android.app.PendingIntent" 'getActivity CONTEXT 0 Intent `(hex "18000000") ) ) ) # FLAG_ACTIVITY_NEW_TASK | FLAG_UPDATE_CURRENT (prog1 (java B 'build) # Notification (java N 'notify Id @) ) ) ) ) ) # Service foreground state (local) [startForeground stopForeground] (de startForeground (Ttl Msg) (java CONTEXT 'startForeground 1 (notify 1 Ttl Msg) ) ) (de stopForeground () (java CONTEXT 'stopForeground T) ) # Start Activity for a result (local) [ startActivityForResult *ResultProxy *ProxyResults resolveActivity getPackageManager setResultProxy good bad ] (de startActivityForResult (Fun Action . @) (let Intent (java "android.content.Intent" T Action) (when (java Intent 'resolveActivity (java CONTEXT 'getPackageManager)) (while (args) (let S (next) (if (str? S) (java Intent 'putExtra S (next)) (java Intent S (next) (next)) ) ) ) (unless *ResultProxy (java CONTEXT 'setResultProxy (setq *ResultProxy (java T "de.software_lab.pilbox.ResultProxy")) ) ) (def 'good *ResultProxy '((Req Intent) (when (asoq Req *ProxyResults) (del @ '*ProxyResults) ((cdr @) Intent) ) ) ) (def 'bad *ResultProxy '((Req Res) (del (asoq Req *ProxyResults) '*ProxyResults) ) ) (let Req (inc (0)) (push '*ProxyResults (cons Req Fun)) (java (; CONTEXT GUI) 'startActivityForResult Intent Req) ) ) ) ) # GPS access (local) checkSelfPermission (de location? () (=0 (java "android.support.v4.content.ContextCompat" 'checkSelfPermission CONTEXT "android.permission.ACCESS_FINE_LOCATION" ) ) ) (local) [ gps *LocMan *LocLsn onLocationChanged onProviderDisabled onProviderEnabled onStatusChanged requestLocationUpdates isProviderEnabled getLastKnownLocation getLatitude getLongitude ] (de gps () (unless *LocMan (setq *LocMan (java CONTEXT 'getSystemService "location") *LocLsn (java T "android.location.LocationListener") ) (def 'onLocationChanged *LocLsn '((Loc) (msg Loc " onLocationChanged") NIL ) ) (def 'onProviderDisabled *LocLsn '((Prov)) ) (def 'onProviderEnabled *LocLsn '((Prov)) ) (def 'onStatusChanged *LocLsn '((Prov Stat Extras)) ) (java *LocMan 'requestLocationUpdates "gps" '(L . 20000) (-3 . 100) *LocLsn) ) (when (java *LocMan 'isProviderEnabled "gps") (let? Loc (java *LocMan 'getLastKnownLocation "gps") (cons (+ (java Loc 'getLatitude) 90000000) (+ (java Loc 'getLongitude) 180000000) ) ) ) ) # Camera access (local) [camera? hasSystemFeature] (de camera? () (java (java CONTEXT 'getPackageManager) 'hasSystemFeature "android.hardware.camera" ) ) ## '((Intent) ## (setq *Picture (tmp "img")) ## (loadUrl (baseHRef) *SesId "app/camera.l") ) (local) takePicture (de takePicture (Dst Fun) (out Dst) (startActivityForResult Fun "android.media.action.IMAGE_CAPTURE" "output" (fileUri Dst) ) ) # ZXing QR-Codes (local) [zxing? queryIntentActivities] (de zxing? () (with (java (java CONTEXT 'getPackageManager) 'queryIntentActivities (java "android.content.Intent" T "com.google.zxing.client.android.SCAN") 65536 ) # MATCH_DEFAULT_ONLY (gt0 (: size)) ) ) ## '((Intent) ## (java Intent 'getStringExtra "SCAN_RESULT") ## (java Intent 'getStringExtra "SCAN_RESULT_FORMAT") ) (local) scanQR (de scanQR (Fun) (startActivityForResult Fun "com.google.zxing.client.android.SCAN" "SCAN_MODE" "QR_CODE_MODE" ) ) # Alarm (local) [alarm elapsedRealtime getInstance getTimeInMillis getBroadcast] (de alarm (N When File) (let (Intent (java "android.content.Intent" T CONTEXT (java "de.software_lab.pilbox.Receiver")) Alarm (java CONTEXT 'getSystemService "alarm") ) # AlarmManager (ifn When (java Alarm 'cancel (java "android.app.PendingIntent" 'getBroadcast CONTEXT N Intent 0) ) (java Intent 'putExtra "LOAD" File) (java Alarm 'set (if (atom When) 2 0) # ELAPSED_REALTIME_WAKEUP RTC_WAKEUP (cons 'L (if (atom When) (+ (* 1000 When) (java "android.os.SystemClock" 'elapsedRealtime) ) (let (Dat (date (car When)) Tim (time (cdr When)) C (java "android.icu.util.Calendar" 'getInstance) ) (java C 'set (car Dat) (dec (cadr Dat)) (caddr Dat) (car Tim) (cadr Tim) (caddr Tim) ) (java C 'getTimeInMillis) ) ) ) (java "android.app.PendingIntent" 'getBroadcast CONTEXT N Intent 0 ) ) ) ) ) # Terminate PilBox (local) [terminate finishAndRemoveTask] (de terminate () (java (; CONTEXT GUI) 'finishAndRemoveTask) ) # vi:et:ts=3:sw=3 picoLisp/lib/boss.l0000644000175000017500000000050212645466211012635 0ustar abuabu# 13jan16abu # (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.l0000644000175000017500000004007413113566564013003 0ustar abuabu# 31may17abu # (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)))) (when (cddr X) (setq @@ (car X)) (throw NIL @) ) (setq @@ (caar X)) (throw NIL (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" (++ "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" (++ "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.js0000600000175000017500000001777012702115271013321 0ustar abuabu/* 09apr16abu * (c) Software Lab. Alexander Burger */ 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) { var req = new XMLHttpRequest(); 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 {req.open("POST", url);} catch (e) {return true;} req.responseType = "arraybuffer"; req.onload = function() { var ele = document.getElementById(id); ele.dly = dly; renderCanvas(ele, plio(new Uint8Array(req.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 {req.send(null);} catch (e) { req.abort(); return true; } return false; } function doCsDn(cvs, x, y) { var r = cvs.getBoundingClientRect(); cvs.csDn = true; cvs.csDnX = x - r.left; cvs.csDnY = y - r.top; cvs.csMv = false; return false; } function csMouseDn(cvs, event) { return doCsDn(cvs, event.clientX, event.clientY); } function csTouchDn(cvs, event) { return doCsDn(cvs, event.touches[0].clientX, event.touches[0].clientY); } function doCsMv(cvs, x, y) { var r = cvs.getBoundingClientRect(); if (cvs.curs) csCursor(cvs, x - r.left, y - r.top); if (!cvs.csDn) return true; if (drawCanvas(cvs.id, cvs.dly, cvs.csMv? -1 : 0, cvs.csDnX, cvs.csDnY, x - r.left, y - r.top)) return true; cvs.csMv = true; return false; } function csMouseMv(cvs, event) { return doCsMv(cvs, event.clientX, event.clientY); } function csTouchMv(cvs, event) { if (event.targetTouches.length == 1) { event.preventDefault(); return doCsMv(cvs, event.touches[0].clientX, event.touches[0].clientY); } return false; } 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 csTouchEnd(cvs) { cvs.csDn = false; if (cvs.csMv) return drawCanvas(cvs.id, cvs.dly); return false; } function csLeave(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 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.l0000600000175000017500000000417212701413146013131 0ustar abuabu# 07apr16abu # (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.l0000644000175000017500000000361613015542121013222 0ustar abuabu# 24nov16abu # (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 (++ 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.l0000644000175000017500000010234713223734616012266 0ustar abuabu# 05jan18abu # (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) (== (++ 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) (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)) (++ 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)) (++ 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)))) (++ 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 Q 1) (while (find '((N) (>= N Q)) Lst) (for N Lst (and N (bit? Q N) (setq Res (| Res P)) ) (setq P (>> -1 P)) ) (setq Q (>> -1 Q)) ) (cons Res X) ) ) (dm has> (Val X) (and Val (or (extra Val X) (extra (let (N (inc (length (: aux))) M 1 V 0) (while (gt0 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) (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 T) ) ) (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) (if (ext? Val) (if (val @) (extra Obj @ Hook) T ) (extra Obj 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)) (prog2 (dbSync) (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 `(if (== 64 64) '(native "@" "symlink" 'I (pack (glue "/" (chop Obj)) "." Var) (pack "=" (name Obj) "." Var) ) '(call "ln" "-sf" (pack (glue "/" (chop Obj)) "." Var) (pack "=" (name Obj) "." Var) ) ) ) ) ) (de incECnt (Obj) (let M NIL (for Cls (type Obj) (recur (Cls) (or (== '+Entity Cls) (memq Cls M) (when (isa '+Entity (push 'M Cls)) (for C (type @) (recurse C) ) (if (get *DB Cls) (inc @) (put *DB Cls (new T 1)) ) ) ) ) ) ) ) (de decECnt (Obj) (let M NIL (for Cls (type Obj) (recur (Cls) (or (== '+Entity Cls) (memq Cls M) (when (isa '+Entity (push 'M Cls)) (for C (type @) (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) (++ X)) (and (meta This X) (zap> @ This V)) ) ) (unless (: T) (decECnt This)) ) (dm url> (Tab)) (dm url1> () (url> This 1)) (dm url2> () (url> This 2)) (dm url3> () (url> This 3)) (dm url4> () (url> This 4)) (dm url5> () (url> This 5)) (dm url6> () (url> This 6)) (dm url7> () (url> This 7)) (dm url8> () (url> This 8)) (dm url9> () (url> This 9)) (dm gui> ()) (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) (++ X)) (and (not (memq X Lst)) (meta This X) (lose> @ This V) ) ) ) (decECnt This) (=: T T) (upd> This) ) ) (dm lose!> (Lst) (dbSync) (lose> This Lst) (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) (++ 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!> (Lst) (dbSync) (keep> This Lst) (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) ) ) ) ) ) ) (de request! (Typ Var . @) (prog2 (dbSync) (pass request Typ Var) (commit 'upd) ) ) # Create or update object # *ObjIdx (de obj Lst (let Obj (let L (++ Lst) (if (pair (car L)) (apply request L) (cache '*ObjIdx (++ Lst) (new (or (meta L 'Dbf 1) 1) L) ) ) ) (while Lst (let (K (++ Lst) V (++ Lst)) (if (=T K) (lose> Obj) (put> Obj K V) ) ) ) Obj ) ) # vi:et:ts=3:sw=3 picoLisp/lib/debug.l0000644000175000017500000003232113226117554012760 0ustar abuabu# 12jan18abu # (c) Software Lab. Alexander Burger # Prompt (when symbols (de *Prompt (unless (== 'pico (car (symbols))) (car (symbols)) ) ) ) # Browsing (de help (Sym Ex) (when (; Sym doc) (prinl "========================================") (in @ (from (pack "
")) (out '("w3m" "-T" "text/html" "-dump") (echo "") (echo "
") (prinl "
") (echo "\n
")
            (ifn Ex
               (prinl "

")
               (prin "
")
               (prinl (echo "\n
")) ) ) )
      (prinl "========================================") )
   Sym )

(de docs (Dir)
   (when (=T (car (info Dir)))
      (let All (all)
         (for F (dir Dir)
            (when (match '("r" "e" "f" @ "." "h" "t" "m" "l") (chop F))
               (let P (pack Dir F)
                  (in P
                     (while (from "
 ((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
                  (== '@ (++ 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 (member *OS '("Android" "Linux"))
   (de proc @
      (apply call
         (make (while (args) (link "-C" (next))))
         "ps" "-H" "-o" "pid,ppid,start,size,pcpu,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 (++ L)))
            (conc
               (car (default S (cons (cons))))
               (cons (cons (++ L) (++ L))) ) )
         (T (== '^ (car L)))
         (T
            (and
               (pair (car L))
               (== 'bt (caar L)) ) ) )
      (for L S
         (let? X (++ 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 (++ 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.l0000644000175000017500000000411612645466076012632 0ustar  abuabu# 13jan16abu
# (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.js0000644000175000017500000004232313046605477013027 0ustar  abuabu/* 08feb17abu
 * (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 || field.type == "textarea")) {
      post(field.form, false, null, null);
      Key = 0;
   }
   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);
}

function idFocus(fld) {
   try {
      document.createEvent("TouchEvent");
      return true;
   } catch (e) {}
   setTimeout(function() {document.getElementById(fld).focus()}, 420);
}

/*** 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.l0000644000175000017500000015723013241512275012640 0ustar  abuabu# 16feb18abu
# (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))
            ~(as *Dbg
               (when (file)
                  (put *Top '*Dbg
                     (list (cons (cddr @) (pack (car @) (cadr @)))) ) ) )
            (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
         (and (args) "?")
         (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 DX DY)
   (default DX 80  DY 25)
   (form Attr
      (=: repl (tmp "repl"))
      (gui 'view '(+FileField) (: repl) DX DY)
      (--)
      (gui 'line '(+Focus +Able +Hint1 +TextField)
         '(= (: home view file) (: home repl))
         '*ReplH
         DX )
      (----)
      (gui '(+JS +Able +Button) '(= (: home view file) (: home repl)) "Eval"
         '(let Str (val> (: home line))
            (out (pack "+" (: home repl))
               (if (pre? "$ " Str)
                  (err NIL
                     (prinl Str)
                     (flush)
                     (in (list "sh" "-c" (cddr (chop Str)))
                        (echo) ) )
                  (err NIL
                     (prinl ": " Str)
                     (flush)
                     (catch '(NIL)
                        (in "/dev/null"
                           (up 99 @@@ "@3")
                           (up 99 @@ "@2")
                           (up 99 @ "@1")
                           (setq  "@3" "@2"  "@2" "@1"  "@1" (run (str Str) 99)) )
                        (println '-> "@1") ) )
                  (when *Msg (prinl @) (off *Msg)) ) )
            (push1 '*ReplH Str)
            (clr> (: home line)) ) )
      (gui '(+JS +Button)
         '(if (= (: home view file) (: home repl)) ,"Edit" ,"Done")
         '(file> (: home view)
            (if (= (: home view file) (: home repl))
               (if (val> (: home line))
                  (setq *ReplF (push1 '*ReplH @))
                  (set> (: home line) *ReplF)
                  *ReplF )
               (clr> (: home line))
               (: home repl) ) ) ) ) )


# 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 (++ 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)
            (when
               (or
                  (nT (car (pair Exe)))
                  (setq Exe (run (cdr Exe) 2)) )
               (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�00000001220�13026426503�012636� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 21dec16abu
# (c) Software Lab. Alexander Burger

### Unit Tests ###
# Local usage:
# ./pil lib/test.l -bye +

# Global usage:
# pil @lib/test.l -bye +

(unless *Dbg
   (quit "Needs debug mode '+'") )

(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�00000011555�13134625111�013337� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 22jul17abu
# (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',
         paste_as_text: true,
         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 (++ Lst)
                  (unless (= S '("^J"))
                     (link (ht:Pack S)) ) )
               (NIL Lst)
               (T (and (= "/" (caar Lst)) (= Tag (cdar Lst)))
                  (++ Lst) )
               (let S (++ 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�00000027632�13240325751�012500� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 12feb18abu
# (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 (++ L)
            (call "mv" (pack Dst '/ N) (pack Dst '/ (inc N)))
            (when (> (car L) (*/ N 9 10))
               (call "rm" "-rf" (pack Dst '/ (++ 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 (++ 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 (++ "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) (++ 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)
                        (when (isa '+Entity Cls)
                           (for C (type Cls)
                              (recurse C) )
                           (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)) )
   (for (F . @) (or *Dbs (2))
      (for (This (seq F) This (seq This))
         (and
            (isa '+Entity This)
            (not (: T))
            (incECnt This) )
         (at (0 . 10000) (commit)) ) )
   (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)
               (isa '+relation (car 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") ) ) ) ) )

### 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 (++ X))
         (while (pair X)
            (space)
            (dumpVal (++ 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") ) )

# 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�00000001703�12713600014�012634� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 08may16abu
# (c) Software Lab. Alexander Burger

(must "User Administration" UserAdmin (== *Login *ID))

(menu ,"User Administration"
   (idForm ,"User" '(choUser) 'nm '+User
      '(or (may UserAdmin) (== *Login (: home obj)))
      '(or (may Delete) (== *Login (: home obj)))
      '((: 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) )
      (gui> (: obj))
      ( NIL (editButton T)) ) )

# vi:et:ts=3:sw=3
�������������������������������������������������������������picoLisp/lib/vip.l����������������������������������������������������������������������������������0000644�0001750�0001750�00000131101�13235364760�012467� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 03feb18abu
# (c) Software Lab. Alexander Burger

(symbols 'vip 'pico)
(local) [
   *CmdWin *Flat *Chr *Complete *Repeat *Change *Count *Cnt *Search *Clip
   *Lines *Columns *TagStack ]

### Curses library interface ###
(local) curses
(de curses @
   (pass native "libncurses.so") )

### VIP Editor ###
(local) [*Buffers +Buffer fName rdLines delim? markup status]
(class +Buffer)
# text file key undo redo dirt pos lastX lastY 

(dm T (File Y)
   (and (=: file File) (queue '*Buffers This))
   (=: pos (or Y 1))
   (=: lastX (=: lastY 1)) )

(de fName (File)
   (if (pre? "~/" File)
      (pack (sys "HOME") "/" (cddr (chop File)))
      File ) )

(de rdLines ()
   (make (until (eof) (link (line)))) )

(de delim? (C)
   (member C '`(cons NIL (chop " \t\n\r\"'(),[]`{}"))) )

(de markup (Lst)
   (let (S 'text  N 1)
      (for L Lst
         (let P NIL
            (while L
               (let C (++ L)
                  (state 'S
                     (text (and (= "\"" C) 'string)
                        (set C 0) )
                     (text (and L (= "#" C) (delim? P) 'comment)
                        (set C N)
                        (when (= "{" (car L))
                           (set (++ L) (inc 'N)) ) )
                     (text 'text
                        (set (setq P C))
                        (and (= "\\" C) L (set (++ L))) )
                     (string (and (= "\"" C) 'text)
                        (set (setq P C) 0) )
                     (string (and (= "\\" C) (not L) 'skip)
                        (set C T) )
                     (string 'string
                        (set C T)
                        (and (= "\\" C) L (set (++ L) T)) )
                     (skip (and (sp? C) 'skip)
                        (set C) )
                     (skip (and (= "\"" C) 'text)
                        (set (setq P C) 0) )
                     (skip 'string
                        (set C T) )
                     (comment
                        (cond
                           ((=1 (set (setq P C) N))
                              (if L 'comment 'text) )
                           ((and
                                 (= "}" C)
                                 (= "#" (car L))
                                 (=1 (set (++ L) (dec 'N))) )
                              'text )
                           (T
                              (and
                                 (= "#" C)
                                 (= "{" (car L))
                                 (set (++ L) (inc 'N)) )
                              'comment ) ) ) ) ) ) ) ) ) )

(dm load> ()
   (markup
      (=: text
         (let? File (fName (: file))
            (let? I (info File)
               (if (=T (car I))
                  (let D (chop File)
                     (unless (= "/" (last D))
                        (conc D (list (char `(char "/")))) )
                     (mapcar
                        '((F)
                           (conc
                              (chop (setq F (pack D F)))
                              (when (=T (car (info F)))
                                 (list (char `(char "/"))) ) ) )
                        (dir File) ) )
                  (gc (inc (*/ (car I) 32768)))  # 2 cells / char
                  (if (sys "CCRYPT" (: key))
                     (pipe
                        (in File (out '("ccrypt" "-d" "-ECCRYPT") (echo)))
                        (rdLines) )
                     (in File (rdLines)) ) ) ) ) ) )
   (=: undo (=: redo (=: dirt)))
   (=: pos (min1 (: pos) (length (: text)))) )

(dm save> ()
   (when (: file)
      (unless (=T (car (info @)))
         (if (sys "CCRYPT" (: key))
            (pipe
               (out '("ccrypt" "-e" "-ECCRYPT")
                  (mapc prinl (: text)) )
               (out (fName (: file)) (echo)) )
            (out (fName (: file)) (mapc prinl (: text))) ) )
      (=: dirt (: undo))
      (for (This *CmdWin (setq This (: next)))
         (status) ) ) )


(local) [*Window +Window]
(class +Window)
# buffer top lines status ptr winX winY posX posY prev next last

(dm T (Buffer Top Height WinX WinY PosX PosY Prev)
   (=: buffer Buffer)
   (=: top Top)
   (when (=: prev Prev)
      (when (=: next (: prev next))
         (=: next prev This) )
      (=: prev next This)
      (curses "wattr_on" NIL
         (=: status (curses "newwin" 'N 1 *Columns (+ Top (dec 'Height)) 0))
         262144 ) )  # A_REVERSE
   (=: ptr (curses "newwin" 'N (=: lines Height) *Columns Top 0))
   (curses "keypad" NIL (: ptr) 1)
   (=: winX WinX)
   (=: winY WinY)
   (=: posX PosX)
   (=: posY PosY) )


(local) [
   min1 delwin cursor addLine chgLine redraw repaint scroll goto chgwin eqwin
   getch getch2 reload done change undo redo jmp@@ cnt@@ goLeft goRight goUp
   goDown goAbs goFind word lword end lend getWord _forward goForward _backward
   goBackward goPFore goPBack shift shiftY indent cutX cutN paste join tglCase
   insChar overwrite _bs insMode cmdMode cmdPipe evRpt move chgRight jmpMark
   wordFun moveSearch patMatch parMatch pipeN nextBuf shell shFile reset command
   vi ]

(de min1 (A B)
   (max 1 (min A B)) )

(de delwin ()
   (when (=: prev next (: next))
      (=: next prev (: prev)) )
   (curses "delwin" NIL (: ptr))
   (curses "delwin" NIL (: status)) )

(de cursor ()
   (curses "wmove" NIL (: ptr)
      (- (: posY) (: winY))
      (- (: posX) (: winX)) ) )

(de addLine (Y L N)
   (curses "wmove" NIL (: ptr) Y 0)
   (for C (nth L (: winX))
      (T (lt0 (dec 'N)))
      (curses "wattrset" NIL (: ptr)
         (cond
            (*Flat 0)
            ((=T (val C))  # A_UNDERLINE
               (ifn (>= "^_" C "^A")
                  131072
                  (setq C (char (+ 64 (char C))))
                  `(+ 131072 512) ) )  # COLOR_PAIR(2)
            ((>= "^_" C "^A")  # COLOR_PAIR(2)
               (setq C (char (+ 64 (char C))))
               512 )
            ((gt0 (val C)) 256)  # COLOR_PAIR(1)
            (T 0) ) )
      (curses "waddnstr" NIL (: ptr) C  -1) ) )

(de chgLine (L)
   (cursor)
   (curses "wclrtoeol" NIL (: ptr))
   (addLine (- (: posY) (: winY)) L *Columns)
   (cursor) )

(de status ()
   (when (: status)
      (curses "mvwaddstr" NIL @ 0 0
         (let
            (N (length (: buffer text))
               A (pack
                  (: buffer file)
                  (unless (= (: buffer undo) (: buffer dirt)) " [+]") )
               Z (pack
                  (: posY) "," (: posX) "/" N " "
                  (if (gt0 (dec N))
                     (*/ 100 (dec (: posY)) @)
                     0 )
                  "%" ) )
            (pack A (need (- *Columns (length A) (length Z)) " ") Z) ) )
      (curses "wrefresh" NIL (: status)) ) )

(de redraw (Flg)
   (curses "werase" NIL (: ptr))
   (for (Y . L) (nth (: buffer text) (: winY))
      (addLine (dec Y) L *Columns)
      (T (= Y (: lines))) )
   (or Flg (status)) )

(de repaint ()
   (for (This *CmdWin This (: next))
      (redraw)
      (curses "wrefresh" NIL (: ptr)) ) )

(de scroll (N)
   (curses "scrollok" NIL (: ptr) 1)
   (curses "wscrl" NIL (: ptr) N)
   (curses "scrollok" NIL (: ptr) 0) )

(de goto (X Y Flg)
   (if
      (and
         (not Flg)
         (>= (inc (: posY)) Y (dec (: posY)))
         (let W (+ (: winX) *Columns -1)
            (>= W (: posX) (: winX))
            (>= W X (: winX)) ) )
      (cond
         ((= Y (inc (: posY)))
            (when
               (and
                  (>= (- (: posY) (: winY)) (/ (: lines) 2))
                  (nth (: buffer text) (+ (: lines) (: winY))) )
               (scroll 1)
               (addLine (dec (: lines)) (car @) *Columns)
               (inc (:: winY)) ) )
         ((= Y (dec (: posY)))
            (when
               (and
                  (> (: winY) 1)
                  (>= (/ (: lines) 2) (- (: posY) (: winY))) )
               (scroll -1)
               (addLine 0 (get (: buffer text) (dec (:: winY))) *Columns) ) ) )
      (=: winX
         (if (>= *Columns X)
            1
            (- X (/ *Columns 4)) ) )
      (=: winY
         (min1
            (- Y (/ (: lines) 2))
            (- (length (: buffer text)) (: lines) -1) ) )
      (unless Flg (redraw T)) )
   (when Flg (redraw T))
   (unless (== This *Window)
      (curses "wrefresh" NIL (: ptr)) )
   (=: posX X)
   (=: buffer pos (=: posY Y))
   (status) )

(de chgwin (Lines Top)
   (curses "wresize" NIL (: ptr) (=: lines Lines) *Columns)
   (when Top
      (curses "mvwin" NIL (: ptr) (=: top @) 0) )
   (when (: status)
      (curses "mvwin" NIL @ (+ (: top) Lines) 0) )
   (goto (: posX) (: posY) T) )

(de eqwin ()
   (let
      (H (dec *Lines)
         D (*/ H
            (let N 0
               (for (This *CmdWin (: next) @)
                  (inc 'N) ) ) ) )
      (with *CmdWin (chgwin 1 H))
      (when (>= D 3)
         (for (This *CmdWin (setq This (: next)))
            (if (: next)
               (chgwin (dec D) (dec 'H D))
               (chgwin (dec H) 0) ) ) )
      (cursor) ) )

(de getch ()
   (loop
      (curses "wget_wch" NIL (: ptr) '(*Chr (4 . I)))
      (NIL (= 410 *Chr)  # KEY_RESIZE
         (unless (= 27 *Chr) (setq *Chr (char *Chr))) )
      (setq
         *Lines (car (struct "LINES" '(I)))
         *Columns (car (struct "COLS" '(I))) )
      (eqwin) ) )

(de getch2 (C)
   (when C
      (if (= "^V" C)
         (prog2
            (mapc curses '("nocbreak" "raw"))
            (or (getch) "^[")
            (mapc curses '("noraw" "cbreak")) )
         C ) ) )

(de reload (File N)
   (unless (== This *CmdWin)
      (when File
         (=: last (: buffer))
         (=: buffer
            (or
               (find '((This) (= File (: file))) *Buffers)
               (new '(+Buffer) File) ) ) )
      (load> (: buffer))
      (goto 1 (or N (: buffer pos)) T)
      (repaint) ) )

(de done ()
   (nond
      ((; *CmdWin next next) (throw 'done))
      ((n== This *CmdWin))
      ((== This (; *CmdWin next))
         (delwin)
         (let (N (: lines)  Top (: top))
            (with (setq *Window (: prev))
               (chgwin (+ 1 N (: lines)) Top) ) ) )
      (NIL
         (delwin)
         (let N (: lines)
            (with (setq *Window (: next))
               (chgwin (+ 1 N (: lines))) ) ) ) ) )

(de change Prg
   (let
      (Pos (nth (: buffer text) (: posY))
         Env
         (env
            'PosX1 (: posX)  'PosY1 (: posY)
            'OldA (car Pos)  'OldD (cdr Pos)
            'NewD (: buffer text)
            '(Pos PosX2 PosY2 NewA) ) )
      (let? Res
         (job Env
            (prog1
               (run Prg)
               (setq
                  PosX2 (: posX)  PosY2 (: posY)
                  NewA (if Pos (car @) (: buffer text)) )
               (and Pos (setq NewD (cdr @))) ) )
         (=: buffer redo NIL)
         (push (:: buffer undo)
            (cons Env
               '(ifn Pos
                  (=: buffer text NewD)
                  (set Pos OldA)
                  (con Pos OldD) )
               '(ifn Pos
                  (=: buffer text NewA)
                  (set Pos NewA)
                  (con Pos NewD) ) ) )
         (markup (: buffer text))
         (goto (: posX) (: posY) T)
         (repaint)
         Res ) ) )

(de undo ()
   (let? U (pop (:: buffer undo))
      (push (:: buffer redo) U)
      (bind (car U)
         (eval (cadr U))
         (markup (: buffer text))
         (goto PosX1 PosY1 T)
         (repaint) ) ) )

(de redo ()
   (let? R (pop (:: buffer redo))
      (push (:: buffer undo) R)
      (bind (car R)
         (eval (cddr R))
         (markup (: buffer text))
         (goto PosX2 PosY2 T)
         (repaint) ) ) )

(de jmp@@ (Y)
   (=: buffer lastX (: posX))
   (=: buffer lastY (: posY))
   (setq @@ Y) )

(de cnt@@ ()
   (- @@ (: posY) -1) )

(de goLeft (N)
   (setq @@ (: posY))
   (max 1 (- (: posX) N)) )

(de goRight (N I)
   (setq @@ (: posY))
   (min1
      (or (=T N) (+ (: posX) N))
      (+
         (or I 0)
         (length (get (: buffer text) (: posY))) ) ) )

(de goUp (N)
   (setq @@ (max 1 (- (: posY) N)))
   (min1 (: posX) (length (get (: buffer text) @@))) )

(de goDown (N I)
   (setq @@
      (min1
         (or (=T N) (+ (: posY) N))
         (+ (or I 0) (length (: buffer text))) ) )
   (min1 (: posX) (length (get (: buffer text) @@))) )

(de goAbs (X Y I)
   (jmp@@
      (min1 Y
         (+ (or I 0) (length (: buffer text))) ) )
   (min1 X (length (get (: buffer text) @@))) )

(de goFind (C D N I)
   (setq @@ (: posY))
   (let (Lst (get (: buffer text) (: posY))  L (nth Lst (: posX)))
      (do N (setq L (member C (cdr L))))
      (+ D (or I 0) (offset L Lst)) ) )

(de word (L C)
   (and (delim? C) (not (delim? (car L))) ) )

(de lword (L C)
   (and (sp? C) (not (sp? (car L))) ) )

(de end (L)
   (and (not (delim? (car L))) (delim? (cadr L))) )

(de lend (L)
   (and (not (sp? (car L))) (sp? (cadr L))) )

(de getWord (Flg)
   (make
      (let (Lst (get (: buffer text) (: posY))  L (nth Lst (: posX)))
         (when Flg
            (for C L
               (T (delim? C))
               (link C) ) )
         (until (delim? (car (setq L (prior L Lst))))
            (yoke (car L)) ) ) ) )

(de _forward (Lst C 1st)
   (for ((X . L) Lst  L  (cdr L))
      (T (and (Fun L C 1st) (=0 (dec 'N)))
         (jmp@@ Y)
         (+ (or I 0) X) )
      (setq C (car L))
      (off 1st) ) )

(de goForward (Fun N I)
   (let (Y (: posY)  Pos (nth (: buffer text) Y)  L (nth (++ Pos) (: posX)))
      (if (_forward (cdr L) (car L) T)
         (+ (: posX) @)
         (loop
            (NIL Pos)
            (inc 'Y)
            (T (_forward (++ Pos)) @) ) ) ) )

(de _backward (Lst L 1st)
   (use P
      (loop
         (NIL L)
         (setq P (prior L Lst))
         (T (and (Fun L (car P) 1st) (=0 (dec 'N)))
            (jmp@@ Y)
            (offset L Lst) )
         (setq L P)
         (off 1st) ) ) )

(de goBackward (Fun N)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (or
         (_backward
            (car Pos)
            (nth (car Pos) (dec (: posX)))
            T )
         (loop
            (NIL (setq Pos (prior Pos (: buffer text))))
            (dec 'Y)
            (T (_backward (car Pos) (tail 1 (car Pos))) @ ) ) ) ) )

(de goPFore (Cnt D I)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (loop
         (NIL (cdr Pos)
            (jmp@@ Y)
            (max 1 (+ (or I 0) (length (car Pos)))) )
         (inc 'Y)
         (T
            (and
               (car Pos)
               (not (cadr Pos))
               (=0 (dec 'Cnt)) )
            (jmp@@ (+ Y D))
            1 )
         (++ Pos) ) ) )

(de goPBack (Cnt)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (loop
         (NIL (setq Pos (prior Pos (: buffer text))))
         (dec 'Y)
         (T
            (and
               (not (car Pos))
               (cadr Pos)
               (=0 (dec 'Cnt)) ) ) )
      (jmp@@ Y)
      1 ) )

(de shift (N Flg)
   (change
      (let? P Pos
         (do N
            (when (car P)
               (if Flg
                  (do 3 (push P (char 32)))
                  (do 3
                     (NIL (sp? (caar P)))
                     (pop P) ) ) )
            (NIL (cdr P))
            (setq P (con P (cons (car @) (cdr @)))) )
         (=: posX 1) ) ) )

(de shiftY (X Flg)
   (shift (cnt@@) Flg) )

(de indent ()
   (change
      (let? P Pos
         (when (clip (car P))
            (let (N (*/ (offset @ (trim (car P))) 3)  Sup N)
               (set P @)
               (loop
                  (do (* N 3) (push P (char 32)))
                  (for C (car P)
                     (unless (val C)
                        (case C
                           ("(" (inc 'N))
                           (")" (dec 'N))
                           ("[" (push 'Sup N) (inc 'N))
                           ("]" (setq N (++ Sup))) ) ) )
                  (NIL (clip (cadr P)) T)
                  (setq P (con P (cons @ (cddr P)))) ) ) ) ) ) )

(de cutX (X Flg)
   (when X
      (let Y @@
         (unless (> (list Y X) (list (: posY) (: posX)))
            (xchg 'X (:: posX)  'Y (:: posY)) )
         (change
            (when Pos
               (let (L (car Pos)  DX (: posX))
                  (and
                     (set *Clip
                        (make
                           (if Flg
                              (set Pos (cut (dec DX) 'L))
                              (setq L (nth L DX)) )
                           (while (>= (dec 'Y) (: posY))
                              (link L)
                              (setq L (cadr Pos))
                              (if Flg
                                 (con Pos (cddr Pos))
                                 (++ Pos) )
                              (one DX) )
                           (link (cut (- X DX) 'L))
                           (when Flg
                              (set Pos (conc (car Pos) L))
                              (=: posX (min1 (: posX) (length (car Pos)))) )
                           (setq @@ (unless L 1)) ) )
                     Flg ) ) ) ) ) ) )

(de cutN (N)
   (change
      (when Pos
         (off @@)
         (set *Clip
            (cons T
               (if (setq Pos (prior Pos (: buffer text)))
                  (make
                     (setq OldA (car @)  OldD (cdr @))
                     (do N
                        (link (cadr Pos))
                        (NIL (con Pos (cddr Pos))
                           (one @@)
                           (dec (:: posY)) ) )
                     (=: posX 1) )
                  (cut N (:: buffer text)) ) ) ) ) ) )

(de paste (Lst Flg)
   (change
      (let P (or Pos (=: buffer text (cons)))
         (ifn (=T (car Lst))
            (let L (car P)
               (cond
                  ((=0 Flg) (setq PosX1 (=: posX 1)))
                  ((=1 Flg)
                     (and
                        (get (: buffer text) (: posY) 1)
                        (get (: buffer text) (: posY) (inc (:: posX)))
                        (inc 'PosX1) ) )
                  (Flg
                     (=: posX
                        (max 1
                           (inc (length (get (: buffer text) (: posY)))) ) ) ) )
               (set P
                  (conc (cut (dec (: posX)) 'L) (mapcar name (++ Lst))) )
               (for S Lst
                  (setq P (con P (cons (mapcar name S) (cdr P))))
                  (inc (:: posY)) )
               (=: posX (max 1 (length (car P))))
               (set P (append (car P) L)) )
            (=: posX 1)
            (ifn Flg
               (for L (cdr Lst)
                  (con P (cons (car P) (cdr P)))
                  (set P (mapcar name L))
                  (setq P (cdr P)) )
               (inc (:: posY))
               (for L (cdr Lst)
                  (setq P (con P (cons (mapcar name L) (cdr P)))) ) ) )
         T ) ) )

(de join (Cnt)
   (change
      (do Cnt
         (NIL (cdr Pos))
         (set Pos
            (append
               (car Pos)
               (cons (char 32) (clip (cadr Pos))) ) )
         (con Pos (cddr Pos)) )
      T ) )

(de tglCase (Cnt)
   (change
      (let? C (get Pos 1 (: posX))
         (do Cnt
            (set Pos
               (place (: posX) (car Pos)
                  ((if (upp? C) lowc uppc) C) ) )
            (NIL (setq C (get Pos 1 (inc (: posX)))))
            (inc (:: posX)) )
         T ) ) )

(de insChar (C Cnt)
   (change
      (when (car Pos)
         (do Cnt
            (set Pos (place (: posX) (car Pos) (name C)))
            (NIL (get Pos 1 (inc (:: posX)))) )
         (dec (:: posX)) ) ) )

(de incChar (Cnt)
   (change
      (set Pos
         (place (: posX) (car Pos)
            (char (+ Cnt (char (get Pos 1 (: posX))))) ) ) ) )

(de overwrite (Lst)
   (change
      (let
         (P (or Pos (=: buffer text (cons)))
            L (conc (cut (dec (: posX)) P) (car Lst)) )
         (set P
            (append L
               (cdr (nth (car P) (length (++ Lst)))) ) )
         (=: posX (max 1 (length L))) ) ) )

(de _bs ()
   (++ Chg)
   (dec (:: posX))
   (unless Rpl
      (set P (remove (: posX) (car P))) ) )

(de insMode (Flg Win Rpl . @)
   (change
      (let (P (or Pos (=: buffer text (cons)))  Chg)
         (cond
            ((=0 Flg)
               (con P (cons (car P) (cdr P)))
               (set P)
               (goto 1 (: posY) T) )
            ((=1 Flg))
            (Flg
               (setq P (con P (cons NIL (cdr P))))
               (goto 1 (inc (: posY)) T)
               (setq Chg (0)) ) )
         (cursor)
         (while
            (case (or (next) (getch))
               (NIL)
               (("\n" "\r")
                  (cond
                     (Rpl (curses "beep") T)
                     ((== This *CmdWin)
                        (nil (command (or Win This) (car P))) )
                     (T
                        (push 'Chg 0)
                        (con P
                           (cons (nth (car P) (: posX)) (cdr P)) )
                        (set P (head (dec (: posX)) (car P)))
                        (setq P (cdr P))
                        (goto 1 (inc (: posY)) T)
                        (cursor)
                        T ) ) )
               (("^H" "^?" `(char 263))  # [BACKSPACE]
                  (when (> (: posX) (if (> (: posY) PosY1) 1 PosX1))
                     (_bs)
                     (chgLine (car P)) )
                  T )
               (T
                  (let S (list @)
                     (nond
                        ((= @ "\t") (off *Complete))
                        ((unless Rpl (setq S (pack (getWord))))
                           (setq S
                              (make
                                 (do (- 3 (% (dec (: posX)) 3))
                                    (link (char 32)) ) ) ) )
                        (NIL
                           (default *Complete
                              (conc
                                 (list S)
                                 (filter '((P) (pre? S P)) (all))
                                 (let P (rot (split (chop S) "/"))
                                    (setq
                                       S (pack (car P))
                                       P (and (cdr P) (pack (glue "/" @) "/")) )
                                    (extract
                                       '((X)
                                          (let? F (and (pre? S X) (pack P X))
                                             (if (=T (car (info F)))
                                                (pack F "/")
                                                F ) ) )
                                       (dir (fName P) T) ) ) ) )
                           (do (length (car *Complete)) (_bs))
                           (setq S (chop (car (rot *Complete)))) ) )
                     (when (= "^V" (car S))
                        (set S (or (next) (getch2 "^V"))) )
                     (for C S
                        (push 'Chg C)
                        (set P
                           ((if (and Rpl (car P)) place insert)
                              (: posX)
                              (car P)
                              C ) )
                        (inc (:: posX)) )
                     (goto (: posX) (: posY)) )
                  (chgLine (car P))
                  T ) ) )
         (=: posX (max 1 (dec (: posX))))
         (cond
            ((=0 Flg) (push 'Chg 0))
            ((=1 Flg) (and (> PosX1 1) (dec 'PosX1))) )
         (split (reverse Chg) 0) ) ) )

(de cmdMode @
   (let Win (if (== This *CmdWin) (: next) This)
      (with *CmdWin
         (pass insMode (: buffer text) Win NIL) ) ) )

(de cmdPipe (N)
   (apply cmdMode (chop (pack ":" N "!"))) )

(de evRpt (Exe)
   (eval (setq *Repeat Exe) 1) )

(de move @
   (let M (conc (rest) (1))
      (case *Change
         (NIL (and (eval (rest)) (goto @ @@)))
         ("!" (eval (rest)) (cmdPipe (cnt@@)))  # External filter
         (">" (evRpt (list 'shiftY M T)))  # Shift right
         ("<" (evRpt (list 'shiftY M)))  # Shift left
         ("c"  # Change
            (when (cutX (eval M) T)
               (and @@
                  (get (: buffer text) (: posY) 1)
                  (inc (:: posX)) )
               (let L (insMode @@)
                  (setq *Repeat
                     (list 'prog
                        (list 'cutX M T)
                        (list 'paste (lit L) '@@)) ) ) ) )
         ("d" (evRpt (list 'cutX M T)))  # Delete
         ("y" (cutX (eval M)))  # Yank
         (T (curses "beep")) ) ) )

(de chgRight (X)
   (setq *Change "c")
   (move 'goRight X) )

(de jmpMark (C D X)
   (cond
      ((= C D)
         (move 'goAbs
            (or X (: buffer lastX))
            (: buffer lastY) ) )
      ((get (: buffer) (intern C))
         (move 'goAbs (default X (car @)) (cdr @)) ) ) )

(de wordFun (@W)
   (let @N (length @W)
      (setq *Search
         (curry (@W @N) (L C)
            (and
               (delim? C)
               (= '@W (cut @N 'L))
               (delim? (car L) ) ) ) ) ) )

(de moveSearch (Fun1 Fun2)
   (move Fun1 (lit Fun2) *Cnt) )

(de patMatch (Fun Pat)
   (moveSearch Fun
      (setq *Search
         (if (= "\\" (car Pat))
            (let @Pat (cdr Pat)
               (curry (@Pat) (L) (head '@Pat L)) )
            (let @Pat
               (if (= "$" (last Pat))
                  (head -1 Pat)
                  (append Pat '(@)) )
               (ifn (= "\^" (car @Pat))
                  (curry (@Pat) (L) (match '@Pat L))
                  (++ @Pat)
                  (curry (@Pat) (L C)
                     (unless C (match '@Pat L)) ) ) ) ) ) ) )

(de parMatch (Fun1 @Par1 @Sup1 @ParO @ParC @SupO @SupC)
   (moveSearch Fun1
      (curry (@Par1 @Sup1 @ParO @ParC @SupO @SupC Par Sup) (L C 1st)
         (and 1st (setq Par @Par1 Sup @Sup1))
         (unless (caar L)
            (case (car L)
               (@ParO (nil (inc 'Par)))
               (@ParC (or (not C) (=0 (dec 'Par) Sup)))
               (@SupO (nil (push 'Sup Par) (zero Par)))
               (@SupC
                  (or
                     (not C)
                     (=0 (setq Par (++ Sup)) Sup) ) ) ) ) ) ) )

(de pipeN (Cnt Line)
   (evRpt
      (fill
         '(when (cdr (cutN Cnt))
            (pipe (out (list "sh" "-c" Line) (mapc prinl @))
               (paste (cons T (rdLines)) @@) ) )
         '(Line Cnt) ) ) )

(de nextBuf (B)
   (let? M (member (: buffer) *Buffers)
      (=: last (: buffer))
      (=: buffer
         (nond
            (B (car (or (cdr M) *Buffers)))
            ((=T B) B)
            (NIL
               (car (or (prior M *Buffers) (tail 1 *Buffers))) ) ) )
      (unless (: buffer text)
         (load> (: buffer)) )
      (goto 1 (: buffer pos) T) ) )

(de shell (S)
   (curses "endwin")
   (do *Columns (prin "#"))
   (call "sh" "-c" S)
   (prin "[====] ")
   (flush)
   (getch) )

(de shFile (S)
   (when (: buffer file)
      (shell (text S (path (fName @)) *Cnt)) ) )

(de reset ()
   (off *Count *Change)
   (setq *Clip '\"\") )

### Commands ###
(de command (This Line)
   (case (++ Line)
      ("(" (run (str (pack (cons "(" Line)))))  # Evaluate list
      ("/" (patMatch 'goForward Line))  # Search forward
      ("?" (patMatch 'goBackward Line))  # Search backward
      (":"
         (let Cnt 0
            (while (format (car Line))
               (setq Cnt (+ @ (* 10 Cnt)))
               (++ Line) )
            (let C (++ Line)
               (when (>= "z" C "a")
                  (until (sp? (car Line))
                     (setq C (pack C (++ Line))) ) )
               (setq Line (pack (clip Line)))
               (case C
                  ("!"  # External filter
                     (when Line
                        (if (=0 Cnt)
                           (shell Line)
                           (pipeN Cnt Line) ) ) )
                  ("bak" (shFile "mv @1 @1- && cp -p @1- @1"))  # Backup to -
                  ("kab"  # Restore from -
                     (shFile "mv @1- @1 && cp -p @1 @1-")
                     (reload) )
                  ("ls"  # List buffers
                     (let L
                        (make
                           (for (I . This) *Buffers
                              (link (chop (pack ":" I " " (: file)))) ) )
                        (with *CmdWin
                           (paste (cons T L) T)
                           (inc (:: posY) (dec (length L))) ) ) )
                  ("key" (=: buffer key Line) (reload))
                  ("n" (nextBuf))  # Next buffer
                  ("N" (nextBuf T))  # Previous buffer
                  ("e" (reload Line))  # (Edit) Reload buffer
                  ("r"  # Read file contents
                     (in (fName Line)
                        (paste (cons T (rdLines)) 1) ) )
                  ("w" (save> (: buffer)))  # (Write) Save buffer
                  ("x"  # (Exit) Save buffer and close window
                     (unless (= (: buffer undo) (: buffer dirt))
                        (save> (: buffer)) )
                     (done) )
                  ("q" (done))  # (Quit) Close window
                  ("bd"  # Buffer delete
                     (when (cdr *Buffers)
                        (let Buf (: buffer)
                           (for (This *CmdWin (setq This (: next)))
                              (when (== Buf (: buffer))
                                 (if (; *CmdWin next next) (done) (nextBuf)) ) )
                           (del Buf '*Buffers) ) ) )
                  (T
                     (if (get *Buffers Cnt)
                        (nextBuf @)
                        (curses "beep")) ) ) ) )
         (with *CmdWin
            (redraw)
            (curses "wrefresh" NIL (: ptr)) ) )
      (T (curses "beep")) ) )

### VIP Entry Point ###
(de vi (Lst)  # ("file.l" (pat) (99 . "file.l") (T . "file.l"))
   (off *Buffers)
   (for X Lst
      (cond
         ((not X))
         ((atom X) (new '(+Buffer) X))
         ((not (cdr X)) (wordFun (car X)))
         (T
            (new '(+Buffer)
               (cdr X)
               (or (num? (car X)) T) ) ) ) )
   (when *Buffers
      (native "@" "setlocale" NIL 0 "")  # LC_CTYPE: UTF-8
      (sys "ESCDELAY" "60")
      (curses "initscr" 'N)
      (curses "start_color")
      (curses "use_default_colors")
      (curses "init_pair" NIL 1 6 0)  # COLOR_CYAN COLOR_BLACK
      (curses "init_pair" NIL 2 1 0)  # COLOR_RED COLOR_BLACK
      (curses "cbreak")
      (curses "noecho")
      (native "@" "LINES" T)
      (native "@" "COLS" T)
      (setq
         *Lines (car (struct "LINES" '(I)))
         *Columns (car (struct "COLS" '(I))) )
      (reset)
      (setq *CmdWin
         (new '(+Window) (new '(+Buffer)) (dec *Lines) 1 1 1 1 1) )
      (with (car *Buffers)
         (load> This)
         (new '(+Window) This
            0 (dec *Lines)
            1
            (min1
               (- (: pos) (/ (- *Lines 2) 2))
               (- (length (: text)) *Lines -3) )
            1 (: pos)
            *CmdWin ) )
      (with (setq *Window (; *CmdWin next)) (redraw))
      (catch 'done
         (loop
            (setq *Cnt (max 1 (format *Count)))
            (with *Window
               (=: posX
                  (min1 (: posX)
                     (length
                        (get (: buffer text)
                           (=: posY
                              (min1 (: posY) (length (: buffer text))) ) ) ) ) )
               (cursor)
               (case (getch)
                  ("0"
                     (if *Count
                        (queue '*Count "0")
                        (move 'goAbs 1 (: posY))  # Go to beginning of line
                        (off *Change) ) )
                  (("1" "2" "3" "4" "5" "6" "7" "8" "9")  # ["Count" prefix]
                     (queue '*Count *Chr) )
                  ("\"" (setq *Clip (intern (pack '"\"" (getch)))))  # "Register" prefix
                  (("!" "<" ">" "c" "d" "y")  # ["Change" prefix]
                     (cond
                        ((= *Chr *Change)
                           (case *Chr
                              ("!" (cmdPipe *Cnt))  # [!!] External filter
                              (">" (evRpt (list 'shift *Cnt T)))  # [>>] Shift line(s) right
                              ("<" (evRpt (list 'shift *Cnt)))  # [<<] Shift line(s) left
                              ("c" (=: posX 1) (chgRight T))  # [cc] Change whole line
                              ("d" (evRpt (list 'cutN *Cnt)))  # [dd] Delete line(s)
                              ("y"  # [yy] Yank line(s)
                                 (set *Clip
                                    (cons T
                                       (head *Cnt (nth (: buffer text) (: posY))) ) ) ) )
                           (reset) )
                        (*Change (off *Change))
                        (T (setq *Change *Chr)) ) )
                  (T
                     (case *Chr
                        (NIL)
                        (("\n" "\r")
                           (if (== This *CmdWin)
                              (command (: next) (get (: buffer text) (: posY)))
                              (cmdMode) ) )
                        ("." (eval *Repeat))  # Repeat last change
                        (("j" `(char 258)) (move 'goDown *Cnt))  # [DOWN] Move down
                        (("^F" `(char 338)) (move 'goDown *Lines))  # [NPAGE] Page down
                        (("k" `(char 259)) (move 'goUp *Cnt))  # [UP] Move up
                        (("^B" `(char 339)) (move 'goUp *Lines))  # [PPAGE] Page up
                        ("h" (move 'goLeft *Cnt))  # Move left
                        ("l" (move 'goRight *Cnt))  # Move right
                        (`(char 260)  # [LEFT] Scroll left
                           (when (> (: winX) 1)
                              (when (>= (- (: posX) (dec (:: winX))) *Columns)
                                 (dec (:: posX)) ) )
                           (redraw) )
                        (`(char 261)  # [RIGHT] Scroll right
                           (cond
                              ((> (: posX) (: winX)) (inc (:: winX)))
                              ((cdr (nth (: buffer text) (: posY) (: posX)))
                                 (inc (:: posX))
                                 (inc (:: winX)) ) )
                           (redraw) )
                        ("$" (move 'goRight T))  # Go to end of line
                        ("G" (move 'goAbs 1 (or (format *Count) T)))  # Go to end of text
                        ("f" (and (getch2 (getch)) (move 'goFind @ 0 *Cnt)))  # Find character
                        ("t" (and (getch2 (getch)) (move 'goFind @ -1 *Cnt)))  # Till character
                        ("w" (move 'goForward 'word *Cnt))  # Word forward
                        ("W" (move 'goForward 'lword *Cnt))  # Long word forward
                        ("b" (move 'goBackward 'word *Cnt))  # Word backward
                        ("B" (move 'goBackward 'lword *Cnt))  # Long word backward
                        ("e" (move 'goForward 'end *Cnt))  # End of word
                        ("E" (move 'goForward 'lend *Cnt))  # End of long word
                        ("{" (move 'goPBack *Cnt))  # Paragraph(s) backward
                        ("}" (move 'goPFore *Cnt 0))  # Paragraph(s) forward
                        ("'" (jmpMark (getch) "'" 1))  # Jump to mark line
                        ("`" (jmpMark (getch) "`")) # Jump to mark position
                        ("~" (evRpt (list 'tglCase *Cnt)))  # Toggle case
                        (":" (cmdMode (name ":")))  # Command
                        ("/" (cmdMode (name "/")))  # Search forward
                        ("?" (cmdMode (name "?")))  # Search backward
                        ("n" (and *Search (move 'goForward (lit @) *Cnt)))  # Search next
                        ("N" (and *Search (move 'goBackward (lit @) *Cnt)))  # Search previous
                        ("*"  # Search word under cursor
                           (and (getWord T) (moveSearch 'goForward (wordFun @))) )
                        ("%"  # Matching parenthesis
                           (case (get (: buffer text) (: posY) (: posX))
                              ("(" (parMatch 'goForward 1 0 "(" ")" "[" "]"))
                              ("[" (parMatch 'goForward 0 (0 . 0) "(" ")" "[" "]"))
                              (")" (parMatch 'goBackward 1 0 ")" "(" "]" "["))
                              ("]" (parMatch 'goBackward 0 (0 . 0) ")" "(" "]" "[")) ) )
                        ("i"  # Insert
                           (when (insMode)
                              (setq *Repeat (list 'paste (lit @))) ) )
                        ("I"  # Insert at beginning of line
                           (=: posX 1)
                           (when (insMode)
                              (setq *Repeat (list 'paste (lit @) 0)) ) )
                        ("a"  # Append
                           (when (get (: buffer text) (: posY) 1)
                              (inc (:: posX)) )
                           (when (insMode 1)
                              (setq *Repeat (list 'paste (lit @) 1)) ) )
                        ("A"  # Append to end of line
                           (goto
                              (inc (length (get (: buffer text) (: posY))))
                              (: posY) )
                           (when (insMode 1)
                              (setq *Repeat (list 'paste (lit @) T)) ) )
                        ("o"  # Open new line below current line
                           (setq *Repeat (list 'paste (lit (insMode T)) T)) )
                        ("O"  # Open new line above current line
                           (setq *Repeat (list 'paste (lit (insMode 0)) 0)) )
                        ("x" (setq *Change "d") (move 'goRight *Cnt))  # Delete characters
                        ("X" (setq *Change "d") (move 'goLeft *Cnt))  # Delete characters left
                        ("D" (setq *Change "d") (move 'goRight T))  # Delete rest of line
                        ("p" (evRpt (list 'paste (lit (val *Clip)) 1)))  # Paste after current position
                        ("P" (evRpt (list 'paste (lit (val *Clip)))))  # Paste before current position
                        ("J" (evRpt (list 'join *Cnt)))  # Join lines
                        ("m"  # Set mark
                           (put (: buffer) (intern (getch))
                              (cons (: posX) (: posY)) ) )
                        ("r"  # Replace character(s)
                           (and (getch2 (getch)) (evRpt (list 'insChar @ *Cnt))) )
                        ("R"  # Replace
                           (when (insMode NIL NIL T)
                              (setq *Repeat (list 'overwrite (lit @))) ) )
                        ("s" (chgRight 1))  # Substitute character
                        ("C" (chgRight T))  # Change rest of line
                        ("S" (=: posX 1) (chgRight T))  # Change whole line
                        ("," (evRpt '(indent)))  # Fix indentation
                        ("^A" (evRpt (list 'incChar *Cnt)))
                        ("^X" (evRpt (list 'incChar (- *Cnt))))
                        ("u" (undo))  # Undo
                        ("^R" (redo))  # Redo
                        ("g"  # ["Go" prefix]
                           (case (getch)
                              ("f" (reload (pack (getWord T))))  # [gf] Edit file under cursor
                              ("g" (move 'goAbs 1 1))  # [gg] Go to beginning of text
                              (T (curses "beep")) ) )
                        ("+"  # Increase window size
                           (loop
                              (NIL (setq This (: prev))
                                 (for (This (; *Window next) This (: next))
                                    (T (> (: lines) 1)
                                       (with *Window
                                          (chgwin (inc (: lines)) (dec (: top)))
                                          (for (This (: next) (=1 (: lines)) (: next))
                                             (chgwin 1 (dec (: top))) ) )
                                       (chgwin (dec (: lines))) ) ) )
                              (T (> (: lines) 1)
                                 (with *Window
                                    (chgwin (inc (: lines)))
                                    (for (This (: prev) (=1 (: lines)) (: prev))
                                       (chgwin 1 (inc (: top))) ) )
                                 (chgwin (dec (: lines)) (inc (: top))) ) ) )
                        ("-"  # Decrease window size
                           (cond
                              ((=1 ( : lines)))
                              ((: prev)
                                 (chgwin (dec (: lines)))
                                 (with (: prev)
                                    (chgwin (inc (: lines)) (dec (: top))) ) )
                              (T
                                 (chgwin (dec (: lines)) (inc (: top)))
                                 (with (: next)
                                    (chgwin (inc (: lines))) ) ) ) )
                        ("=" (eqwin))  # Set all windows to equal size
                        ("^]"  # Edit symbol
                           (when (get (intern (pack (getWord T))) '*Dbg 1)
                              (push '*TagStack (: posY) (: buffer file))
                              (reload (cdr @) (car @)) ) )
                        ("^T"  # Pop tag stack
                           (reload (pop '*TagStack) (pop '*TagStack)) )
                        (`(char (+ 264 1)) (onOff *Flat) (repaint))  # [F1] Highlight on/off
                        (`(char (+ 264 2)) (shFile "diff -Bb @1- @1"))  # [F2] Show chages to -
                        (`(char (+ 264 3)) (shFile "dif @1 @2"))  # [F3] Custom dif
                        (`(char (+ 264 4)) (goPFore 1 -1) (pipeN (cnt@@) "fmt"))  # [F4] Format paragraph
                        (`(char (+ 264 5)) (nextBuf T))  # [F5] Previous buffer
                        (`(char (+ 264 6)) (nextBuf))  # [F6] Next buffer
                        (`(char (+ 264 7))  # [F7] Load file
                           (let? F (fName (: buffer file))
                              (and (info F) (catch '(NIL) (load F))) ) )
                        ## (`(char (+ 264 8)) ())  # [F8]
                        ## (`(char (+ 264 9)) ())  # [F9]
                        ## (`(char (+ 264 10)) ())  # [F10]
                        ## (`(char (+ 264 11)) ())  # [F11]
                        ## (`(char (+ 264 12)) ())  # [F12]
                        ("\\"  # Select or toggle buffer
                           (nextBuf
                              (if *Count
                                 (get *Buffers (format @))
                                 (or (: last) (car *Buffers)) ) ) )
                        (("q" "^W")  # ["Window" prefix]
                           (case (getch)
                              ("s"  # [qs] Split window
                                 (unless (== This *CmdWin)
                                    (let (Old (inc (: lines))  New (/ Old 2))
                                       (with
                                          (new '(+Window) (: buffer)
                                             (+ (: top) New) (- Old New)
                                             (: winX) (: winY)
                                             (: posX) (: posY)
                                             (: prev) )
                                          (goto (: posX) (: posY) T) )
                                       (chgwin (dec New)) ) ) )
                              ("x"  # [qx] Exchange windows
                                 (and
                                    (; *CmdWin next next)
                                    (n== This *CmdWin)
                                    (let W (if (== (: prev) *CmdWin) (: next) (: prev))
                                       (for P '(buffer winX winY posX posY)
                                          (xchg (prop This P) (prop W P)) )
                                       (goto (: posX) (: posY) T)
                                       (with W
                                          (goto (: posX) (: posY) T) ) ) ) )
                              ("k" (and (: next) (setq *Window @)))  # [qk] Above window
                              ("j" (and (: prev) (setq *Window @)))  # [qj] Below window
                              ("q" (done))  # [qq] (Quit) Close window
                              (T (curses "beep")) ) )
                        (T (curses "beep")) )
                     (reset) ) ) ) ) )
      (curses "endwin") ) )

(when (info (pil "viprc"))
   (load (pil "viprc")) )

`*Dbg

(symbols '(pico)
   (let Src (path "@src64/")
      (in "@src64/tags"
         (use (L F)
            (while (setq L (line))
               (if (= L '("^L"))
                  (setq F (pack Src (car (split (line) ","))))
                  (put
                     (intern
                        (pack (car (setq L (split (cdr L) "^A" ",")))) )
                     '*Dbg
                     (list (cons (format (cadr L)) F)) ) ) ) ) ) ) )

(undef 'pico~vi)
(de pico~vi ("X" C)
   (vi
      (list
         (cond
            ((pair "X")
               (get (cdr "X") '*Dbg -1 (car "X")) )
            (C (get C '*Dbg -1 "X"))
            ((str? "X") "X")
            (T (get "X" '*Dbg 1)) ) ) )
   "X" )

# vi:et:ts=3:sw=3
���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/xhtml.l��������������������������������������������������������������������������������0000644�0001750�0001750�00000053531�13167702103�013026� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 12oct17abu
# (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 (++ L)  A (car (++ H))  N 1)
                  (while (== '- (car L))
                     (inc 'N)
                     (++ L)
                     (++ 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) (++ X))
                                    ((= "." (++ L)) 'align) )
                                 E (++ Lst) )
                              (unless (== '- E)
                                 (when (== '- (car Lst))
                                    (let N 1
                                       (for (P Lst (and P (== '- (++ 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
(zero "LayX" "LayY")

(de  "Lst"
   (let P (and (=T (car "Lst")) (++ "Lst"))
      (recur ("Lst" "LayX")
         (use ("LayX" "LayY")
            (for "L" "Lst"
               (let
                  ("Args" (mapcar eval (cddar "L"))
                     "DX" (eval (caar "L"))
                     "DY" (eval (cadar "L"))
                     "Cls" (unless (sub? ":" (car "Args")) (++ "Args"))
                     "Style"
                     (cons 'style
                        (glue "; "
                           (cons
                              "position:absolute"
                              (pack "top:" "LayY" (if P "%" "px"))
                              (pack "left:" "LayX" (if P "%" "px"))
                              (cond
                                 ((=0 "DX") "min-width:100%")
                                 ("DX" (pack "width:" "DX" (if P "%" "px"))) )
                              (cond
                                 ((=0 "DY") "min-height:100%")
                                 ("DY" (pack "height:" "DY" (if P "%" "px"))) )
                              "Args" ) ) ) )
                  (prog1
                     (if "Cls" (list "Cls" "Style") "Style")  # -> '@'
                     (eval (cadr "L")) )
                  (recurse (cddr "L") (+ "LayX" "DX"))
                  (inc '"LayY" "DY") ) ) ) ) ) )

(de 
 '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 (++ Lst) "?"
      (make
         (while Lst
            (and
               (sym? (car Lst))
               (= `(char '*) (char (car Lst)))
               (link (++ Lst) "=") )
            (link (ht:Fmt (++ 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