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.l0000644000175000017500000003250413506600334011667 0ustar abuabu# 02jul19abu # (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 tasks Prg (task -2 (abs (run Prg)) "Prg" Prg (let (L (assoc @ *Run) P (run "Prg")) (if2 (lt0 (car L)) (lt0 P) (set (cdr L) (abs P)) # (-2 111 ..) -> (-2 999 ..) (prog # (-2 999 ..) -> (7 ..) (del '(task -2) '*Fork) (ifn P (task -2) (set L P) (con L (cddr L)) (push '*Fork (list 'close P) (list 'task P)) ) ) (let N (car L) # (7 ..) -> (-2 999 ...) (del (list 'task N) '*Fork) (del (list 'close N) '*Fork) (set L -2) (con L (cons (abs P) (cdr L))) (push '*Fork '(task -2)) ) (let N (car L) # (3 ..) -> (7 ..) (del (list 'task N) '*Fork) (del (list 'close N) '*Fork) (ifn P (task N) (set L P) (push '*Fork (list 'close P) (list 'task P)) ) ) ) ) ) (forked) ) (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 (cadadr (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) (loop (if (assoc Key Lst) (con @ Val) (push 'Lst (cons Key Val)) ) (NIL (args)) (setq Key (next) Val (next)) ) (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 (unless (== Sym (intern Sym T)) (quit "Import conflict" Sym) ) ) 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) '(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.css0000644000175000017500000001337413434173566012244 0ustar abuabu/* 23feb19abu * 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} .rel10 {width: 10%} .rel20 {width: 20%} .rel25 {width: 25%} .rel30 {width: 30%} .rel40 {width: 40%} .rel50 {width: 50%} .rel60 {width: 60%} .rel70 {width: 70%} .rel75 {width: 75%} .rel80 {width: 80%} .rel90 {width: 90%} .rel96 {width: 96%} .rel100 {width: 100%} /* 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: small; } .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.l0000644000175000017500000000776113432467314012446 0ustar abuabu# 18feb19abu # (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)) (when *Timeout (timeout (setq *Timeout `(* 3600 1000))) ) ) *Login ) (de logout () (when *Login (rollback) (off *Login) (tell 'hi *Pid) (msg *Pid " / " (stamp)) (when *Timeout (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) ) ) (dm login> ()) ### 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) (url *Url) ) ((login (val> (: home nm)) (val> (: home pw))) (clr> (: home pw)) (login> *Login) (url *Url) ) (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.l0000644000175000017500000000233713323050474012451 0ustar abuabu# 16jul18abu # (c) Software Lab. Alexander Burger # Exit on error (de *Err ~(as trail (for ("L" (trail T) "L") (cond ((pair (car "L")) (println (++ "L")) ) ((== '"L" (car "L")) (setq "L" (cddr "L")) ) (T (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.l0000644000175000017500000002663413553345115013323 0ustar abuabu# 21oct19abu # (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 GUI Config javaExt) (de CONTEXT . {H@@@40000000000}) # file 32768, obj (hex "100000000") # (javaExt 'fun 'lst ..) (de javaExt @ (setq *Ext (sort (make (link (cons 32768 java)) (while (next) (for N (next) (link (cons N @)) ) ) ) ) ) ) # Java I/O # (java "cls" 'T ['any ..]) -> obj New object # (java 'obj ['n] 'msg ['any ..]) -> any Send message to object # (java 'obj "fld" ['any]) -> any Value of object field # (java "cls" ['n] 'msg ['any ..]) -> any Call method in class # (java "cls" "fld" ['any]) -> 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 null) (de java1 () (unless *Java (setq *Java (open "JAVA") *Lisp (open "LISP")) (let Rply (open "RPLY") (task (open "RQST") Rply Rply (ext 32768 (in @ (let (X (rd) Obj (rd) Lst (rd)) (out Rply (pr (and (get X Obj) (ext 0 (apply @ Lst))) ) ) ) ) ) ) (push '*Fork '(off *Java *Lisp) (list 'mapc 'close (list Rply *Java *Lisp)) ) (forked) ) (forked) (javaExt) ) ) (de java @ (ext 32768 (out *Java (pr (rest))) (in *Lisp (for (X (rd) X (rd)) (and (=0 X) (quit (rd))) # 0: Exception (let (Obj (rd) Lst (rd)) # Callback (out *Java (pr (and (get X Obj) (ext 0 (apply @ Lst))) ) ) ) ) (rd) ) ) ) # Android device ID (local) (dev getString getContentResolver) (de dev () (java "android.provider.Settings$Secure" 'getString (java CONTEXT 'getContentResolver) "android_id" ) ) # Push-Load (local) (runOnUiThread loadTxt loadData loadUrl) (de loadTxt @ (java (; CONTEXT GUI) 'runOnUiThread (java (; CONTEXT GUI PilView) 0 'loadData (pack "" (pass pack) "") "text/html; charset=utf-8" 'null ) ) ) (de loadUrl @ (java (; CONTEXT GUI) 'runOnUiThread (java (; CONTEXT GUI PilView) 0 'loadUrl (pass pack)) ) ) # Clear WebView history and cache (local) (clearHistory clearCache) (de clearHistory () (java CONTEXT 'clearHistory) ) (de clearCache () (java (; CONTEXT GUI) 'runOnUiThread (java (; CONTEXT GUI PilView) 0 'clearCache T) ) ) # Wake lock (local) (wake *Wake getSystemService newWakeLock acquire release) (de wake @ (default *Wake # PowerManager.WakeLock (java (java CONTEXT 'getSystemService "power") # PowerManager 'newWakeLock 1 "PilWake" ) ) # PARTIAL_WAKE_LOCK = 1 (when (args) # (wake 'flg) (cond ((next) (java *Wake 'acquire)) ((java *Wake 'isHeld) (java *Wake '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) (de fileUri (File) (java "android.support.v4.content.FileProvider" 'getUriForFile CONTEXT "de.software_lab.pilbox.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 (X . @) (java CONTEXT 'toast (pass pack X)) X ) # Notification (local) (notify cancel *Notify createNotificationChannel setSmallIcon setContentTitle setContentText setAutoCancel setAction putExtra setContentIntent getActivity build) (de notify (Id Ttl Msg File) (let N (java CONTEXT 'getSystemService "notification") # NotificationManager (ifn Ttl (java N 'cancel Id) ~(as (>= (format (sys "SDK_INT")) 26) (unless *Notify (java N 'createNotificationChannel (java "android.app.NotificationChannel" T "pil" "PilBox" 2) ) # IMPORTANCE_LOW = 2 (on *Notify) ) ) (let B `(if (>= (format (sys "SDK_INT")) 26) '(java "android.app.Notification$Builder" T CONTEXT "pil") '(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 (or Msg 'null)) (java B 'setAutoCancel T) (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 (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 'setResultProxy *ResultProxy) (java (; CONTEXT GUI) 'startActivityForResult Intent Req) ) ) ) ) # GPS access (local) (permit location? gps *LocMan *LocLsn onLocationChanged onProviderDisabled onProviderEnabled onStatusChanged requestLocationUpdates isProviderEnabled getLastKnownLocation getLatitude getLongitude) (de location? () (java (; CONTEXT GUI) 'permit "android.permission.ACCESS_FINE_LOCATION") ) (de gps () (unless *LocMan (setq *LocMan (java CONTEXT 'getSystemService "location") *LocLsn (java T "android.location.LocationListener") ) ## (def 'onLocationChanged *LocLsn ## '((Loc)) ) ## (def 'onProviderDisabled *LocLsn ## '((Prov)) ) ## (def 'onProviderEnabled *LocLsn ## '((Prov)) ) ## (def 'onStatusChanged *LocLsn ## '((Prov Stat Extras)) ) (java *LocMan 'requestLocationUpdates "network" '(L . 10000) (-3 . 100) *LocLsn) (java *LocMan 'requestLocationUpdates "gps" '(L . 20000) (-3 . 100) *LocLsn) ) (and (or (and (java *LocMan 'isProviderEnabled "gps") (java *LocMan 'getLastKnownLocation "gps") ) (and (java *LocMan 'isProviderEnabled "network") (java *LocMan 'getLastKnownLocation "network") ) ) (cons (+ (java @ 'getLatitude) 90000000) (+ (java @ 'getLongitude) 180000000) ) ) ) # Camera access (local) (camera? hasSystemFeature) (de camera? () (and (java (java CONTEXT 'getPackageManager) 'hasSystemFeature "android.hardware.camera") (java (; CONTEXT GUI) 'permit "android.permission.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 getStringExtra) (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 'setExactAndAllowWhileIdle (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 `(hex "18000000") ) ) ) ) ) # FLAG_ACTIVITY_NEW_TASK | FLAG_UPDATE_CURRENT # Restart PilBox (local) restart (de restart () (java (; CONTEXT GUI) 'restart) ) # 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.js0000600000175000017500000002026713310217736013321 0ustar abuabu/* 13jun18abu * (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: // (csFont Str) ctx.font = cmd[1]; case 2: // (csFillText Str X Y) ctx.fillText(cmd[1], cmd[2], cmd[3]); break; case 3: // (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 4: // (csClearRect X Y DX DY) ctx.clearRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 5: // (csStrokeRect X Y DX DY) ctx.strokeRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 6: // (csFillRect X Y DX DY) ctx.fillRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 7: // (csBeginPath) ctx.beginPath(); break; case 8: // (csClosePath) ctx.closePath(); break; case 9: // (csMoveTo X Y) ctx.moveTo(cmd[1], cmd[2]); break; case 10: // (csLineTo X Y) ctx.lineTo(cmd[1], cmd[2]); break; case 11: // (csBezierCurveTo X1 Y1 X2 Y2 X Y) ctx.bezierCurveTo(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 12: // (csQuadraticCurveTo X1 Y1 X2 Y2) ctx.quadraticCurveTo(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 13: // (csLine X1 Y1 X2 Y2) ctx.moveTo(cmd[1], cmd[2]); ctx.lineTo(cmd[3], cmd[4]); break; case 14: // (csRect X Y DX DY) ctx.rect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 15: // (csArc X Y R A B F) ctx.arc(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 16: // (csStroke) ctx.stroke(); break; case 17: // (csFill) ctx.fill(); break; case 18: // (csClip) ctx.clip(); break; case 19: // (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 20: // (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 21: // (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 22: // (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 23: // (csTranslate X Y) ctx.translate(cmd[1], cmd[2]); break; case 24: // (csRotate A) ctx.rotate(cmd[1]); break; case 25: // (csScale X Y) ctx.scale(cmd[1], cmd[2]); break; case 26: // (csSave) ctx.save(); break; case 27: // (csRestore) ctx.restore(); break; /*** Variables ***/ case 28: // (csCursor Lst) cvs.curs = cmd[1]; break; case 29: // (csFillStyle V) ctx.fillStyle = cmd[1]; break; case 30: // (csStrokeStyle V) ctx.strokeStyle = cmd[1]; break; case 31: // (csGlobalAlpha V) ctx.globalAlpha = cmd[1]; break; case 32: // (csLineWidth V) ctx.lineWidth = cmd[1]; break; case 33: // (csLineCap V) ctx.lineCap = cmd[1]; break; case 34: // (csLineJoin V) ctx.lineJoin = cmd[1]; break; case 35: // (csMiterLimit V) ctx.miterLimit = cmd[1]; break; case 36: // (csGlobalCompositeOperation V) ctx.globalCompositeOperation = cmd[1]; break; case 37: // (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.l0000600000175000017500000000426413310217576013141 0ustar abuabu# 13jun18abu # (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 ### (csFont Str) (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) (csQuadraticCurveTo X1 Y1 X2 Y2) (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.l0000644000175000017500000011224113523205372012253 0ustar abuabu# 09aug19abu # (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 '+Link This) (find '((B) (isa '+Link 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 Old (if (: bag) (for (I . This) @ (let V (get O I) (unless (find '((L) (= V (get L I))) New) (rel> This Obj V NIL (when (: hook) (get (if (sym? @) Obj O) (: hook)) ) ) ) ) ) (unless (member O New) (extra Obj O NIL Hook) ) ) ) (for N New (if (: bag) (for (I . This) @ (let V (get N I) (unless (find '((L) (= V (get L I))) Old) (rel> This Obj NIL V (when (: hook) (get (if (sym? @) Obj N) (: hook)) ) ) ) ) ) (unless (member N 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 Fld)) (dm url1> (Tab Fld) (url> This 1 Fld)) (dm url2> (Tab Fld) (url> This 2 Fld)) (dm url3> (Tab Fld) (url> This 3 Fld)) (dm url4> (Tab Fld) (url> This 4 Fld)) (dm url5> (Tab Fld) (url> This 5 Fld)) (dm url6> (Tab Fld) (url> This 6 Fld)) (dm url7> (Tab Fld) (url> This 7 Fld)) (dm url8> (Tab Fld) (url> This 8 Fld)) (dm url9> (Tab Fld) (url> This 9 Fld)) (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> (Lst) (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) ) (unless (memq (fin X) Lst) (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 ) ) # Create or update lots of objects (de create (Typ Key Vars . Prg) (prune 0) (gc 200 200) (setq Vars # ((var fd lst cnt . cnt) ..) (mapcar '((Var) (if (isa '+index (meta Typ Var)) (cons Var (open (tmp (pack "create-" Var))) NIL 0 1000000 ) Var ) ) Vars ) ) (while (run Prg 1) # (val ..) (let (Lst @ Obj (or (fin Lst) (new (meta Typ 'Dbf 1) Typ))) (and Key (++ Lst) (put> Obj Key @)) (let store '((Tree Key Val Dbf) (link Key)) (mapc '((V Val) (when Val (if (atom V) (put> Obj V Val) (out (cadr V) (for Key (make (put> Obj (car V) Val)) (at (cdddr V) (push (cddr V) Key)) (pr Key Obj) ) ) ) ) ) Vars Lst ) ) ) (at (0 . 1000000) (commit) (prune 2)) ) (commit) (prune 0) (let Lst (mapcan '((V) (unless (atom V) (close (cadr V)) (let (Var (car V) File (tmp (pack "create-" Var))) (later (cons) (off Vars) (gc 0 100) (setq V (mapcar '((Key) (let F (tmp (pack "create-" (inc (0)))) (cons Key F (or (open F) (quit "Too many files")) ) ) ) (cons NIL (sort (caddr V))) ) ) (in File (while (setq Key (rd)) (out (cddr (rank Key V)) (pr Key (rd)) ) ) ) (native "@" "unlink" 'I File) (let (Dbf (meta Typ Var 'dbf) Tree (cons Var (new T))) (for R V (close (cddr R)) (for X (sort (make (in (cadr R) (while (rd) (link (cons @ (rd))) ) ) ) ) (store Tree (car X) (cdr X) Dbf) (at (0 . 1000) (prune 2)) ) (commit) (prune 2) (native "@" "unlink" 'I (cadr R)) ) (commit) Tree ) ) ) ) ) Vars ) (off Vars) (prune) (gc 0) (wait NIL (full Lst)) (for Tree Lst (let (Base (get *DB (meta Typ (car Tree) 'cls)) Root (get (cdr Tree) (car Tree)) ) (ifn (get Base (car Tree)) (put Base (car Tree) Root) (touch Base) (inc @ (car Root)) ) ) (zap (cdr Tree)) ) (commit) ) ) ### Debug ### `*Dbg (noLint 'create 'store) # vi:et:ts=3:sw=3 picoLisp/lib/dbgc.l0000644000175000017500000000311313436471166012573 0ustar abuabu# 02mar19abu # (c) Software Lab. Alexander Burger ### DB Garbage Collection ### (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)) ) (let Cnt 0 (dbSync) ("markExt" *DB) (for L *ExtDBs # ("path/" ) (let ((P N E) L Lck) (for I N (let (Fd (open (pack P (hax (dec I)))) (Cnt . Siz) (blk Fd 0)) (and (=1 I) (setq Lck Fd)) (for Blk (dec Cnt) (mapc "markExt" (fish ext? (ext E (blk Fd Blk Siz Lck))) ) ) (close Fd) ) ) ) ) (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) ) ) ) ) (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) `(if (== 64 64) '(native "@" "unlink" NIL (pack F)) '(call "rm" (pack F)) ) ) (wipe S) ) ) ) ) ) ) (commit) (gt0 Cnt) ) # vi:et:ts=3:sw=3 picoLisp/lib/debug.l0000644000175000017500000003221113561457101012753 0ustar abuabu# 09nov19abu # (c) Software Lab. Alexander Burger # Prompt (when symbols (de *Prompt (unless (== 'pico (car (symbols))) (or (name (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.js0000644000175000017500000004263113500367772013027 0ustar  abuabu/* 13jun19 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 Busy, 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);
}

function setCheck(fld, val) {
   var lst = document.getElementsByName(fld.name);

   for (var i = 1;  i < lst.length; ++i)
      if (lst[i] == fld)
         return lst[i - 1] = val;
}

/*** 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 (Busy) {
      Queue.push([form, auto, exe, file]);
      return false;
   }
   Busy = true;
   form.style.cursor = "wait";
   try {FormReq.open("POST", SesId + "!jsForm?" + form.action.substr(i+1));}
   catch (e) {return true;}
   FormReq.onload = function() {
      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) {
            var i, j;

            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 != "";
                     setCheck(fld, "");
                  }
                  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)
                        setCheck(fld, "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;
                  }
               }
            }
            Busy = false;
            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) {
   Busy = false;
   if (SesId)
      setTimeout(function() {ping1(min)}, 20000);
}

function ping1(min) {
   lisp(null, "ping", min);
   setTimeout(function() {ping1(min)}, 20000);
}
picoLisp/lib/form.l0000644000175000017500000016521713574724476012665 0ustar  abuabu# 13dec19abu
# (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)
      (when *Timeout
         (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 '(+Able +FileField)
         '(<> (: file) (: home repl))
         (: repl)
         DX DY )
      (--)
      (gui 'line '(+Focus +Able +Hint1 +TextField)
         '(= (: home view file) (: home repl))
         '*ReplH
         (*/ DX 4 5) )
      (----)
      (gui '(+JS +Able +Button) '(= (: home view file) (: home repl)) "Eval"
         '(let Str (val> (: home line))
            (out (pack "+" (: home repl))
               (if (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)) )
                        (off *Msg)
                        (println '-> "@1") ) )
                  (and *Msg (prinl @)) ) )
            (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 This)
         (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 (Fmt . Prg)
   (let (PosX 0  Max *FontSize)
      (ifn (=T Fmt)
         (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 3))
                        (eval Exe 3 '(*Pos *DX *DY)) )
                     (inc 'PosX N)
                     (setq Max (max *Pos Max)) ) ) )
            Fmt
            Prg )
         (for
            (N (co 'table (run Prg) (yield))
               N
               (window PosX *Pos N Max
                  (prog1
                     (co 'table T)
                     (inc 'PosX N)
                     (setq Max (max *Pos Max)) ) ) ) )
         (co 'table) )
      (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 2) ) )

# Direct SVG display
(de svgOut "Prg"
   (httpHead "image/svg+xml" 0)
   (ht:Out *Chunked (run "Prg")) )

# Multipage SVG
(de svg (*DX *DY "Dst" . "Prg")
   (zero *Page)
   (out "Dst"
      (let page
         '("Prg2"
            (prin "<" (inc '*Page) ">")
            ( *DX *DY "pt"
               (run "Prg2") ) )
         (run "Prg") ) )
   "Dst" )

(de page.svg (File N)
   (in File
      (from (pack "<" N ">"))
      (echo (pack "<" (inc N) ">")) ) )

# 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
# (pdf "src" "dst")
# (pdf 'dx 'dy "dst" . prg)
(de pdf (*DX *DY "Dst" . "Prg")
   (if "Dst"
      (let page  # Generate SVG files
         '("Prg2"
            (out (tmp "page" (inc '*Page) ".svg")
               ( *DX *DY "pt"
                  (run "Prg2") ) ) )
         (zero *Page)
         (run "Prg") )
      (in *DX  # Multipage SVG file
         (when (echo (pack "<" (one *Page) ">"))
            (while
               (out (tmp "page" *Page ".svg")
                  (when (echo (pack "<" (inc *Page) ">"))
                     (inc '*Page) ) ) ) ) )
      (setq "Dst" *DY) )
   (apply call
      (make
         (for I *Page
            (link (tmp "page" I ".svg")) ) )
      "rsvg-convert"
      "--dpi-x" 72
      "--dpi-y" 72
      "-f" "pdf"
      "-o" "Dst" )
   "Dst" )

# 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�00000026244�13436503351�012477� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 02mar19abu
# (c) Software Lab. Alexander Burger

(de admin "Prg"
   (out 2
      (prinl *Pid " + Admin " (stamp))
      (tell 'bye)
      (for (F . @) (or *Dbs (2))
         (when (dbck F)
            (quit "DB Check" (cons F @)) ) )
      (run "Prg")
      (when (load "@lib/dbgc.l")
         (prinl "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 59 60))
               (call "rm" "-rf" (pack Dst '/ (++ L))) ) ) ) )
   (when (call "mkdir" (pack Dst "/1"))
      (let Ign NIL
         (while (args)
            (if (pre? "-" (next))
               (push 'Ign (pack (cdr (chop (arg)))))
               (let
                  (Lst (filter bool (split (chop (arg)) '/))
                     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)
                           (unless (member Src Ign)
                              (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 ()
   (load "@lib/dbgc.l") )

### 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 ()
   (for (F . N) (or *Dbs (2))  # Low-level integrity check
      (unless (pair (println F N (dbck F T)))
         (quit 'dbck @) ) )
   (dbSync)
   (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
   (rollback) )

# 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/user.l���������������������������������������������������������������������������������0000644�0001750�0001750�00000001610�13514001060�012625� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 18jul19 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) This) ) )
������������������������������������������������������������������������������������������������������������������������picoLisp/lib/vip.l����������������������������������������������������������������������������������0000644�0001750�0001750�00000151165�13572121342�012472� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 05dec19 Software Lab. Alexander Burger
# https://picolisp.com/wiki/?vip

(symbols 'vip 'pico)

(local) (*Shell *CmdWin *StatNm *Chr *Complete *Repeat *Change *Count *Cnt
*Search *Clip *Lines *Columns *TagStack *Spell *F8 *F9 *F10 *F11 *F12 *@)

### ANSI Terminal ###
(local) (xterm ULINE U-OFF REVERS CYAN RED *AttrA *AttrU attr cup clreol hideCsr
showCsr screen1 screen2)

(de xterm ()
   (member (sys "TERM") '("xterm" "screen")) )

(de *Shell "bash")

(de ULINE . 4)
(de U-OFF . 24)
(de REVERS . 7)
(de CYAN . 36)
(de RED . 31)

(off *AttrA *AttrU)

(de attr (A U)
   (if2 (<> A *AttrA) (<> U *AttrU)
      (prin "^[["
         (or (setq *AttrA A) 0)
         ";"
         (if (setq *AttrU U) ULINE U-OFF)
         "m" )
      (prin "^[[" (or (setq *AttrA A) 0) "m")
      (prin "^[[" (if (setq *AttrU U) ULINE U-OFF) "m") ) )

(de cup (Y X)
   (prin "^[[" Y ";" X "H") )

(de clreol ()
   (prin "^[[0K") )

(de hideCsr ()
   (prin "^[[?25l") )

(de showCsr ()
   (prin "^[[?25h") )

(de screen1 ()
   (if (xterm)
      (prin "^[[?1049l")
      (cup *Lines 1) )
   (flush) )

(de screen2 ()
   (and (xterm) (prin "^[[?1049h")) )

### VIP Editor ###
(local) (*Buffers +Buffer fName rplFile fileBuffer rdLines delim? markup min1
beep undo redo evCmd dirty> load> save> view> status)

(class +Buffer)
# text file key undo redo dirt posX posY lastX lastY flat fmt 

(dm T (File Y)
   (and (=: file File) (queue '*Buffers This))
   (=: posX 1)
   (=: posY (or Y 1))
   (=: lastX (=: lastY 1))
   (=: fmt 80) )

(de fName (File)
   (when
      (setq File
         (if (pre? "~/" File)
            (pack (sys "HOME") "/" (cddr (chop File)))
            (path File) ) )
      (use R
         (when (=0 (native "@" "realpath" 'N File '(R (4096 C . 4096))))
            (setq R (chop File)) )
         (pack
            (if (head (conc (chop (pwd)) '("/")) R)
               (cddr (nth R (length (pwd))))
               R ) ) ) ) )

(de prName (File)
   (if (pre? (sys "HOME") File)
      (pack "~/" (cddr (nth (chop File) (length (sys "HOME")))))
      File ) )

(de rplFile (File)
   (pack (replace (chop File) "%" (: buffer file))) )

(de fileBuffer (File Y)
   (setq File (fName File))
   (or
      (find '((This) (= File (: file))) *Buffers)
      (new '(+Buffer) File Y) ) )

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

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

(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
                           (= "#" C)
                           (delim? P)
                           (if L 'comment 'text) )
                        (set C N)
                        (when (= "{" (car L))
                           (set (++ L) (inc 'N)) ) )
                     (text 'text
                        (or
                           (set (setq P C)
                              (and (sp? C) (not L)) )
                           (when (= "\\" C)
                              (let? C (++ L)
                                 (set C (and (sp? C) (not 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
                                 (and (sp? C) (not L) (set P T))
                                 'text ) )
                           ((and
                                 (= "}" C)
                                 (= "#" (car L))
                                 (=1 (set (++ L) (dec 'N))) )
                              'text )
                           (T
                              (and
                                 (= "#" C)
                                 (= "{" (car L))
                                 (set (++ L) (inc 'N)) )
                              'comment ) ) ) ) ) ) ) ) ) )

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

(de beep ()
   (pico~beep)
   NIL )

(dm dirty> (Win)
   (<> (: undo) (: dirt)) )

(dm load> (Win)
   (markup
      (=: text
         (let? File (: file)
            (let? I (info File)
               (if (=T (car I))
                  (let D (chop File)
                     (unless (= "/" (last D))
                        (conc D (list (name "/"))) )
                     (mapcar
                        '((F)
                           (conc
                              (chop (setq F (pack D F)))
                              (let S (car (info F T))
                                 (cond
                                    ((=T S) (list (name "/")))
                                    ((not S)
                                       (conc
                                          (chop " -> ")
                                          (in (list "readlink" F)
                                             (line) ) ) ) ) ) ) )
                        (sort (dir File T)) ) )
                  (gc (+ 4 (*/ (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)))
   (=: posX 1)
   (=: posY (min1 (: posY) (length (: text))))
   (and
      (head '`(chop "# VIP ") (: text 1))
      (split (clip (: text 1 -6)) " ")
      (evCmd
         (apply script (cdr @) (fName (pack (car @)))) ) )
   (off *StatNm) )

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

(dm view> (Win)
   (beep) )


(local) (*Window +Window)

(class +Window)
# buffer top lines winX winY posX posY prev next last mark sc

(dm T (Buffer Top Lines WinX WinY PosX PosY Prev Mark)
   (=: buffer Buffer)
   (=: top Top)
   (=: lines Lines)
   (when (=: prev Prev)
      (when (=: next (: prev next))
         (=: next prev This) )
      (=: prev next This) )
   (=: winX WinX)
   (=: winY WinY)
   (=: posX PosX)
   (=: posY PosY)
   (=: mark Mark)
   (=: sc 0) )

(dm view> ()
   (view> (: buffer) This) )


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

(de delwin ()
   (when (=: prev next (: next))
      (=: next prev (: prev)) ) )

(de cursor ()
   (cup
      (+ (: top) (- (: posY) (: winY) -1))
      (- (: posX) (: winX) -1) ) )

(de addLine (Y L N)
   (cup (+ (: top) Y) 1)
   (clreol)
   (for C (nth L (: winX))
      (T (lt0 (dec 'N)))
      (cond
         ((: buffer flat))
         ((=T (val C))
            (ifn (>= "^_" C "^A")
               (attr NIL T)
               (setq C (char (+ 64 (char C))))
               (attr RED T) ) )
         ((>= "^_" C "^A")
            (setq C (char (+ 64 (char C))))
            (attr RED) )
         ((gt0 (val C))
            (attr CYAN) )
         (T (attr)) )
      (prin C) )
   (attr) )

(de chgLine (L)
   (addLine (- (: posY) (: winY) -1) L *Columns)
   (cursor) )

(de unmark ()
   (when (: mark)
      (out @ (println (: posX) (: posY)))
      (=: mark) ) )

(de status ()
   (unless (== This *CmdWin)
      (cup (+ (: top) (: lines) 1) 1)
      (let
         (N (length (: buffer text))
            A (pack
               (index (: buffer) *Buffers)
               "/"
               (length *Buffers)
               (if (dirty> (: buffer) This) " * " " ") )
            F (prName (: buffer file))
            Z (pack
               (: mark)
               " "
               (: posX) "," (: posY) "/" N " "
               (if (gt0 (dec N))
                  (*/ 100 (dec (: posY)) @)
                  0 )
               "%" ) )
         (attr REVERS)
         (cond
            ((ge0
                  (setq N
                     (- *Columns (length A) (length F) (length Z)) ) )
               (prin A F (need N " ") Z) )
            ((onOff *StatNm)
               (prin (align (- *Columns) (tail *Columns (chop F)))) )
            (T
               (prin
                  A
                  (need (- *Columns (length A) (length Z)) " ")
                  Z ) ) )
         (attr)
         (flush) ) ) )

(de redraw ()
   (hideCsr)
   (let L (nth (: buffer text) (: winY))
      (for Y (: lines)
         (addLine Y (++ L) *Columns) ) )
   (showCsr)
   (status) )

(de repaint ()
   (for (This *CmdWin This (: next))
      (redraw) ) )

(de scLeft (N)
   (and
      (> (: winX) 1)
      (>= (- (: posX) (dec (:: winX))) *Columns)
      (dec (:: posX)) ) )

(de scRight (N)
   (cond
      ((> (: posX) (: winX))
         (inc (:: winX)) )
      ((cdr (nth (: buffer text) (: posY) (: posX)))
         (inc (:: posX))
         (inc (:: winX)) )
      (T
         (for (Y . L) (cdr (nth (: buffer text) (: posY)))
            (T (cdr (nth L (: posX)))
               (inc (:: posY) Y) )
            (T (= Y (: lines))) ) ) ) )

(de goto (X Y F)
   (=: buffer posX (=: posX X))
   (setq X
      (cond
         ((and F
               (>= (inc (: posY)) Y (dec (: posY)))
               (>= (+ (: winX) *Columns -1) X (: winX)) )
            (: winX) )
         ((>= (*/ *Columns 3 4) X) 1)
         (T (- X (/ *Columns 2))) ) )
   (=: buffer posY (=: posY Y))
   (setq Y
      (min1
         (- Y (/ (: lines) 2))
         (- (length (: buffer text)) (: lines) -1) ) )
   (if (and F (= X (: winX)) (= Y (: winY)))
      (status)
      (=: winX X)
      (=: winY Y)
      (redraw) ) )

(de chgwin (Lines Top)
   (=: lines Lines)
   (and Top (=: top @))
   (goto (: posX) (: posY)) )

(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 ()
   (if (= "^[" (setq *Chr (key)))
      (when (key 60)
         (loop
            (setq *Chr (pack *Chr @))
            (T (member *Chr '("^[[A" "^[[B" "^[[C" "^[[D")) *Chr)
            (NIL (key 40) *Chr) ) )
      *Chr ) )

(de getch2 (C)
   (if (= "^V" C) (key) C) )

(de reload (File Y)
   (unless (== This *CmdWin)
      (when File
         (unless
            (==
               (=: last (: buffer))
               (=: buffer (fileBuffer File)) )
            (unmark) ) )
      (load> (: buffer) This)
      (goto 1 (or Y (: buffer posY)))
      (repaint) ) )

(de scratch (File Lst Y)
   (setq File (fName File))
   (if (find '((This) (= File (: file))) *Buffers)
      (put @ 'text Lst)
      (=: last (: buffer))
      (unmark)
      (put
         (=: buffer (new '(+Buffer) File Y))
         'text
         Lst ) )
   (goto 1 (: buffer posY))
   (repaint) )

(de done (Flg)
   (and Flg
      (dirty> (: buffer) This)
      (save> (: buffer) This) )
   (unmark)
   (nond
      ((; *CmdWin next next) (throw 'done Flg))
      ((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))
         (repaint)
         Res ) ) )

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

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

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

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

(de goCol (N)
   (setq @@ (: posY))
   N )

(de goLeft (N)
   (goCol (max 1 (- (: posX) N))) )

(de goRight (N I)
   (goCol
      (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))))
      (if L
         (+ D (or I 0) (offset L Lst))
         (beep) ) ) )

(de tword (L)
   (and
      (delim? (car L))
      (or
         (sub? (cadr L) "\"()[]")
         (not (delim? (cadr L))) ) ) )

(de word (L C)
   (and
      (delim? C)
      (or
         (sub? (car L) "\"()[]")
         (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 Str)
   (make
      (let Lst (get (: buffer text) (: posY))
         (when Flg
            (for C (nth Lst (: posX))
               (T (delim? C))
               (link C) ) )
         (for
            (L (nth Lst (dec (: posX)))
               (not (delim? (car L)))
               (prior L Lst) )
            (yoke (car L)) ) ) ) )

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

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

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

(de goBackward (Fun N)
   (let (Y (: posY)  Pos (nth (: buffer text) Y))
      (or
         (_backward
            (car Pos)
            (nth (car Pos) (dec (: posX))) )
         (loop
            (NIL (setq Pos (prior Pos (: buffer text)))
               (beep) )
            (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 (name " ")))
                  (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 (name " ")))
                  (for C (car P)
                     (unless (val C)
                        (case C
                           ("(" (inc 'N))
                           (")" (dec 'N))
                           ("[" (push 'Sup N) (inc 'N))
                           ("]" (setq N (++ Sup))) ) ) )
                  (while (val (caadr P))
                     (++ P) )
                  (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 (name " ") (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 incNum (Cnt)
   (change
      (let (I (: posX)  L (car Pos)  S (get L I))
         (ifn (format S)
            (set Pos
               (place (: posX) L (char (+ Cnt (char S)))) )
            (while
               (and
                  (gt0 (dec 'I))
                  (format (get L @)) )
               (setq S (pack @ S)) )
            (inc (:: posX)
               (-
                  (length
                     (set Pos
                        (conc
                           (head I L)
                           (need
                              (if (= `(char "0") (char S)) (length S) 1)
                              (chop (max 0 (+ Cnt (format S))))
                              (name "0") )
                           (tail (- (: posX)) L) ) ) )
                  (length L) ) ) ) ) ) )

(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)) )
            ((=1 Flg))
            (Flg
               (setq P (con P (cons NIL (cdr P))))
               (goto 1 (inc (: posY)))
               (setq Chg (0)) ) )
         (cursor)
         (while
            (case (or (next) (getch))
               (NIL)
               (("\n" "\r")
                  (cond
                     (Rpl (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)))
                        (cursor)
                        T ) ) )
               (("^H" "^?")  # [BACKSPACE]
                  (when (and Chg (n0 (car Chg)))
                     (_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 (name " ")) ) ) ) )
                        (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 (fName 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) T) )
                  (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 @ @@ T)))
         ("!" (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 (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)
   (setq *Search
      (ifn (= '"@" (car (setq W (append W '("@Z")))))
         (curry (W) (L C)
            (and
               (delim? C "~")
               (match W L)
               (delim? (car "@Z") "~") ) )
         (++ W)
         (curry (W) (L C)
            (and
               (delim? C "~")
               (and (= '"@" (car L)) (match W (cdr L)))
               (delim? (car "@Z") "~") ) ) ) ) )

(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
      (let (Par @Par1  Sup @Sup1)
         (curry (Par Sup @Par1 @Sup1 @ParO @ParC @SupO @SupC) (L C)
            (unless (caar L)
               (and
                  (case (car L)
                     (@ParO (nil (inc 'Par)))
                     (@ParC (or (not C) (= (dec 'Par) 0 Sup)))
                     (@SupO (nil (push 'Sup Par) (zero Par)))
                     (@SupC
                        (or
                           (not C)
                           (= (setq Par (++ Sup)) 0 Sup) ) ) )
                  (setq Par @Par1  Sup @Sup1) ) ) ) ) ) )

(de *Spell
   "hunspell" "-l" "-d" "en_US,de_DE" )

(de spell ()
   (when
      (pipe
         (out *Spell
            (let Pos (nth (: buffer text) (: posY))
               (prinl
                  (seek
                     '((L) (not (fold (car L))))
                     (nth (++ Pos) (: posX)) ) )
               (mapc prinl Pos) ) )
         (line) )
      (let @W (conc @ '("@Z"))
         (moveSearch 'goForward
            (setq *Search
               (curry (@W) (L C)
                  (and
                     (not (fold C))
                     (match '@W L)
                     (not (fold (car "@Z"))) ) ) ) ) ) ) )

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

(de nextBuf (B)
   (let? M (member (: buffer) *Buffers)
      (=: last (: buffer))
      (unmark)
      (=: 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) This) )
      (goto (: buffer posX) (: buffer posY)) ) )

(de shell (S)
   (screen1)
   (do *Columns (prin "#"))
   (call *Shell "-c" S)
   (prin "[====] ")
   (flush)
   (getch)
   (prinl)
   (screen2)
   (repaint) )

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

(de prCmd (L)
   (with *CmdWin
      (paste (cons T L) (: buffer text))
      (inc (:: posY) (dec (length L))) ) )

(de evCmd Prg
   (out (tmp "repl")
      (err NIL
         (catch '(NIL)
            (setq @ *@  *@ (run Prg 1) *Msg)
            (println '-> *@) ) )
      (and *Msg (prinl @)) )
   (in (tmp "repl")
      (prCmd (rdLines)) ) )

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

### Commands ###
(de command (This Line)
   (case (++ Line)
      ("/" (patMatch 'goForward Line))  # Search forward
      ("?" (patMatch 'goBackward Line))  # Search backward
      ("&" (moveSearch 'goForward (wordFun Line)))  # Search word
      (":"
         (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
                  (" "  # Eval
                     (evCmd (run (str (pack Line)))) )
                  ("$"  # Shell command
                     (scratch (tmp "cmd")
                        (in (list *Shell "-c" (rplFile Line))
                           (make (until (eof) (link (line)))) ) ) )
                  ("!"  # External filter
                     (when Line
                        (if (=0 Cnt)
                           (shell (rplFile Line))
                           (pipeN Cnt Line) ) ) )
                  ("cp"  # Copy to system clipboard
                     (out '("copy")  # System dependent script
                        (let V (val *Clip)
                           (if (=T (car V))
                              (mapc prinl (cdr V))
                              (prin V) ) ) ) )
                  ("ix.io"  # Paste to http://ix.io
                     (pipe
                        (out '("curl" "-sF" "f:1=<-" "ix.io")
                           (mapc prinl (: buffer text)) )
                        (prCmd (rdLines)) ) )
                  ("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
                     (prCmd
                        (make
                           (for (I . This) *Buffers
                              (link
                                 (chop (pack ":" I " " (prName (: file)))) ) ) ) ) )
                  ("key" (=: buffer key Line) (reload))
                  ("m"
                     (when (info (=: mark (fName (rplFile Line))))
                        (in (: mark) (move 'goAbs (read) (read))) ) )
                  ("n" (nextBuf))  # Next buffer
                  ("N" (nextBuf T))  # Previous buffer
                  ("e" (reload (rplFile Line)))  # (Edit) Reload buffer
                  ("r"  # Read file contents
                     (let F (fName (rplFile Line))
                        (when (info F)
                           (in F (paste (cons T (rdLines)) 1)) ) ) )
                  ("w"  # (Write) Save buffer
                     (if Line
                        (out (fName (rplFile @))
                           (mapc prinl (: buffer text)) )
                        (save> (: buffer) This) ) )
                  ("x" (done T))  # (Exit) Save buffer and close window
                  ("q" (done))  # (Quit) Close window
                  ("bx"  # Buffer exchange
                     (let X (memq (: buffer) *Buffers)
                        (if (cdr X)
                           (xchg X @)
                           (beep) ) ) )
                  ("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)
                           (=: last) ) ) )
                  (T
                     (if (get *Buffers Cnt)
                        (nextBuf @)
                        (beep) ) ) ) ) )
         (with *CmdWin
            (redraw) ) )
      (T (beep)) ) )

### VIP Entry Point ###
(de vi (Lst)  # ("file.l" (pat) (99 . "file.l") (T . "file.l"))
   (unless
      (and
         (setq *Columns (format (sys "COLUMNS")))
         (setq *Lines (format (sys "LINES"))) )
      (quit "COLUMNS or LINES not set") )
   (off *Buffers)
   (when (=0 (native "@" "isatty" 'I 0))
      (with (fileBuffer (tmp "stdin"))
         (out (: file) (in 0 (echo))) )
      (ctty "/dev/tty") )
   (for X Lst
      (cond
         ((not X))
         ((atom X) (fileBuffer X))
         ((not (cdr X)) (wordFun (car X)))
         (T
            (fileBuffer
               (cdr X)
               (or (num? (car X)) T) ) ) ) )
   (unless *Buffers
      (fileBuffer (tmp "empty")) )
   (finally (screen1)
      (screen2)
      (let (*TStp1 '((screen1))  *TStp2 '((screen2) (repaint) (cursor) (flush)))
         (reset)
         (setq *CmdWin
            (new '(+Window) (new '(+Buffer)) (dec *Lines) 1 1 1 1 1) )
         (with (car *Buffers)
            (load> This)
            (new '(+Window) This
               0 (- *Lines 2)
               1
               (min1
                  (- (: posY) (/ (- *Lines 2) 2))
                  (- (length (: text)) *Lines -3) )
               1 (: posY)
               *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)))
                                 (goto 1 (inc (: posY)) T)  # Go to next line
                                 (do (: sc) (scRight))
                                 (redraw) ) )
                           ("." (if *Repeat (eval @) (beep)))  # Repeat last change
                           (("j" "^[[B") (move 'goDown *Cnt))  # [DOWN] Move down
                           (("^F" "^[[6~") (move 'goDown (: lines)))  # [PGDOWN] Page down
                           (("k" "^[[A") (move 'goUp *Cnt))  # [UP] Move up
                           (("^B" "^[[5~") (move 'goUp (: lines)))  # [PGUP] Page up
                           ("h" (move 'goLeft *Cnt))  # Move left
                           ("l" (move 'goRight *Cnt))  # Move right
                           ("^[[D" (scLeft) (redraw))  # [LEFT] Scroll left
                           ("^[[C" (scRight) (redraw))  # [RIGHT] Scroll right
                           ("z" (do 3 (scRight)) (redraw))  # Scroll right 3 columns
                           ("Z" (do 3 (scLeft)) (redraw))  # Scroll left 3 columns
                           ("|" (move 'goCol *Cnt))  # Go to column
                           ("$" (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
                           ("\t" (move 'goForward 'tword *Cnt))  # TAB word forward
                           ("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
                           ("&" (cmdMode (name "&")))  # Search word
                           ("n"  # Search next
                              (if *Search
                                 (move 'goForward (lit @) *Cnt)
                                 (beep) ) )
                           ("N"  # Search previous
                              (if *Search
                                 (move 'goBackward (lit @) *Cnt)
                                 (beep) ) )
                           ("*"  # Search word under cursor
                              (and (getWord T "~") (moveSearch 'goForward (wordFun @))) )
                           ("#"  # Search word under cursor backward
                              (and (getWord T "~") (moveSearch 'goBackward (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) ")" "(" "]" "["))
                                 (T (beep)) ) )
                           ("i"  # Insert
                              (when (insMode)
                                 (setq *Repeat (list 'paste (lit @))) ) )
                           ("I"  # Insert at beginning of line
                              (goto 1 (: posY))
                              (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)
                                 T )
                              (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)) ) )
                           ("M" (=: sc (dec (: winX))))  # Mark horizontal scroll position
                           ("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 'incNum *Cnt)))
                           ("^X" (evRpt (list 'incNum (- *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
                                 ("s" (spell))
                                 (T (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
                           (("K" "^]")  # Edit symbol
                              (ifn (get (any (pack (getWord T))) '*Dbg 1)
                                 (beep)
                                 (push '*TagStack (: posY) (: buffer file))
                                 (reload (cdr @) (car @)) ) )
                           (("Q" "^T")  # Pop tag stack
                              (if *TagStack
                                 (reload (pop '*TagStack) (pop '*TagStack))
                                 (beep) ) )
                           (("^[OP" "^[[[A")  # [F1] Highlight on/off
                              (=: buffer flat (not (: buffer flat)))
                              (repaint) )
                           (("^[OQ" "^[[[B")  # [F2] Show chages to -
                              (shFile
                                 (if (sys "CCRYPT" (: buffer key))
                                    "diff -Bb <(ccrypt -c -ECCRYPT @1-) <(ccrypt -c -ECCRYPT @1)"
                                    "diff -Bb @1- @1" ) ) )
                           (("^[OR" "^[[[C")  # [F3] Custom dif
                              (shFile "dif @1 @2") )
                           (("^[OS" "^[[[D")  # [F4] Format paragraph
                              (and *Count (=: buffer fmt @))
                              (goPFore 1 -1)
                              (pipeN (cnt@@) (pack "fmt -" (: buffer fmt))) )
                           (("^[[15~" "^[[[E")  # [F5] Previous buffer
                              (nextBuf T) )
                           ("^[[17~"  # [F6] Next buffer
                              (nextBuf) )
                           ("^[[18~"  # [F7] Load file
                              (when (: buffer file)
                                 (evCmd (load @)) ) )
                           ("^[[19~" (run *F8))  # [F8] Custom key
                           ("^[[20~" (run *F9))  # [F9] Custom key
                           ("^[[21~" (run *F10))  # [F10] Custom key
                           ("^[[23~" (run *F11))  # [F11] Custom key
                           ("^[[24~" (run *F12))  # [F12] Custom key
                           ("\\"  # 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 1)
                                                (: winX) (: winY)
                                                (: posX) (: posY)
                                                (: prev)
                                                (: mark) )
                                             (goto (: posX) (: posY)) )
                                          (=: mark)
                                          (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))
                                          (with W
                                             (goto (: posX) (: posY)) ) ) ) )
                                 ("k" (and (: next) (setq *Window @)))  # [qk] Above window
                                 ("j" (and (: prev) (setq *Window @)))  # [qj] Below window
                                 ("q" (done))  # [qq] (Quit) Close window
                                 (T (beep)) ) )
                           ("v" (view> This))  # View hook
                           (T (beep)) )
                        (reset) ) ) ) ) ) ) ) )

(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)
   (and
      (vi
         (list
            (cond
               ((pair "X")
                  (get (cdr "X") '*Dbg -1 (car "X")) )
               (C (get C '*Dbg -1 "X"))
               (T (or (get "X" '*Dbg 1) "X")) ) ) )
      "X" ) )
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/wide.l���������������������������������������������������������������������������������0000644�0001750�0001750�00000012433�13517515557�012634� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 29jul19abu
# (c) Software Lab. Alexander Burger

# Wide characters (http://www.unicode.org/reports/tr11)
(de wide? (N)
   (and
      (rank N
         (quote
            (1 . 31)  # ^X
            # http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt
            (4352 . 4447)  # 1100..115F
            (8986 . 8987)  # 231A..231B
            (9001 . 9002)  # 2329..232A
            (9193 . 9196)  # 23E9..23EC
            (9200 . 9200)  # 23F0..23F0
            (9203 . 9203)  # 23F3..23F3
            (9725 . 9726)  # 25FD..25FE
            (9748 . 9749)  # 2614..2615
            (9800 . 9811)  # 2648..2653
            (9855 . 9855)  # 267F..267F
            (9875 . 9875)  # 2693..2693
            (9889 . 9889)  # 26A1..26A1
            (9898 . 9899)  # 26AA..26AB
            (9917 . 9918)  # 26BD..26BE
            (9924 . 9925)  # 26C4..26C5
            (9934 . 9934)  # 26CE..26CE
            (9940 . 9940)  # 26D4..26D4
            (9962 . 9962)  # 26EA..26EA
            (9970 . 9971)  # 26F2..26F3
            (9973 . 9973)  # 26F5..26F5
            (9978 . 9978)  # 26FA..26FA
            (9981 . 9981)  # 26FD..26FD
            (9989 . 9989)  # 2705..2705
            (9994 . 9995)  # 270A..270B
            (10024 . 10024)  # 2728..2728
            (10060 . 10060)  # 274C..274C
            (10062 . 10062)  # 274E..274E
            (10067 . 10069)  # 2753..2755
            (10071 . 10071)  # 2757..2757
            (10133 . 10135)  # 2795..2797
            (10160 . 10160)  # 27B0..27B0
            (10175 . 10175)  # 27BF..27BF
            (11035 . 11036)  # 2B1B..2B1C
            (11088 . 11088)  # 2B50..2B50
            (11093 . 11093)  # 2B55..2B55
            (11904 . 11929)  # 2E80..2E99
            (11931 . 12019)  # 2E9B..2EF3
            (12032 . 12245)  # 2F00..2FD5
            (12272 . 12283)  # 2FF0..2FFB
            (12289 . 12350)  # 3001..303E
            (12353 . 12438)  # 3041..3096
            (12441 . 12543)  # 3099..30FF
            (12549 . 12591)  # 3105..312F
            (12593 . 12686)  # 3131..318E
            (12688 . 12730)  # 3190..31BA
            (12736 . 12771)  # 31C0..31E3
            (12784 . 12830)  # 31F0..321E
            (12832 . 12871)  # 3220..3247
            (12880 . 19893)  # 3250..4DB5
            (19968 . 40943)  # 4E00..9FEF
            (40960 . 42124)  # A000..A48C
            (42128 . 42182)  # A490..A4C6
            (43360 . 43388)  # A960..A97C
            (44032 . 55203)  # AC00..D7A3
            (63744 . 64109)  # F900..FA6D
            (64112 . 64217)  # FA70..FAD9
            (65040 . 65049)  # FE10..FE19
            (65072 . 65106)  # FE30..FE52
            (65108 . 65126)  # FE54..FE66
            (65128 . 65131)  # FE68..FE6B
            (94176 . 94179)  # 16FE0..16FE3
            (94208 . 100343)  # 17000..187F7
            (100352 . 101106)  # 18800..18AF2
            (110592 . 110878)  # 1B000..1B11E
            (110928 . 110930)  # 1B150..1B152
            (110948 . 110951)  # 1B164..1B167
            (110960 . 111355)  # 1B170..1B2FB
            (126980 . 126980)  # 1F004..1F004
            (127183 . 127183)  # 1F0CF..1F0CF
            (127374 . 127374)  # 1F18E..1F18E
            (127377 . 127386)  # 1F191..1F19A
            (127488 . 127490)  # 1F200..1F202
            (127504 . 127547)  # 1F210..1F23B
            (127552 . 127560)  # 1F240..1F248
            (127568 . 127569)  # 1F250..1F251
            (127584 . 127589)  # 1F260..1F265
            (127744 . 127776)  # 1F300..1F320
            (127789 . 127797)  # 1F32D..1F335
            (127799 . 127868)  # 1F337..1F37C
            (127870 . 127891)  # 1F37E..1F393
            (127904 . 127946)  # 1F3A0..1F3CA
            (127951 . 127955)  # 1F3CF..1F3D3
            (127968 . 127984)  # 1F3E0..1F3F0
            (127988 . 127988)  # 1F3F4..1F3F4
            (127992 . 128062)  # 1F3F8..1F43E
            (128064 . 128064)  # 1F440..1F440
            (128066 . 128252)  # 1F442..1F4FC
            (128255 . 128317)  # 1F4FF..1F53D
            (128331 . 128334)  # 1F54B..1F54E
            (128336 . 128359)  # 1F550..1F567
            (128378 . 128378)  # 1F57A..1F57A
            (128405 . 128406)  # 1F595..1F596
            (128420 . 128420)  # 1F5A4..1F5A4
            (128507 . 128591)  # 1F5FB..1F64F
            (128640 . 128709)  # 1F680..1F6C5
            (128716 . 128716)  # 1F6CC..1F6CC
            (128720 . 128722)  # 1F6D0..1F6D2
            (128725 . 128725)  # 1F6D5..1F6D5
            (128747 . 128748)  # 1F6EB..1F6EC
            (128756 . 128762)  # 1F6F4..1F6FA
            (128992 . 129003)  # 1F7E0..1F7EB
            (129293 . 129393)  # 1F90D..1F971
            (129395 . 129398)  # 1F973..1F976
            (129402 . 129442)  # 1F97A..1F9A2
            (129445 . 129450)  # 1F9A5..1F9AA
            (129454 . 129482)  # 1F9AE..1F9CA
            (129485 . 129535)  # 1F9CD..1F9FF
            (129648 . 129651)  # 1FA70..1FA73
            (129656 . 129658)  # 1FA78..1FA7A
            (129664 . 129666)  # 1FA80..1FA82
            (129680 . 129685)  # 1FA90..1FA95
            (131072 . 173782)  # 20000..2A6D6
            (173824 . 177972)  # 2A700..2B734
            (177984 . 178205)  # 2B740..2B81D
            (178208 . 183969)  # 2B820..2CEA1
            (183984 . 191456)  # 2CEB0..2EBE0
            (194560 . 195101) ) )  # 2F800..2FA1D
      (>= (cdr @) N) ) )

# vi:et:ts=3:sw=3
�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picoLisp/lib/xhtml.l��������������������������������������������������������������������������������0000644�0001750�0001750�00000056304�13456277220�013037� 0����������������������������������������������������������������������������������������������������ustar  �abu�����������������������������abu��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 19apr19abu
# (c) Software Lab. Alexander Burger

# *JS "*JS" *Style *SsEvts *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 ( "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 "") )
      (and (rest) ( @)) ) )

(de serverSentEvent (Id Var . Prg)
   (allow "!ssEvt")
   (
      "(new EventSource(SesId+'!ssEvt?'+'"
      Id
      "')).onmessage = function(ev) {if (ev.data.charAt(0) == '&') document.title = ev.data.substr(1); else document.getElementById('"
      Id
      "').innerHTML = ev.data;}" )
   (if (assoc Id *SsEvts)
      (con @ (cons Var (unless (val Var) Prg)))
      (push '*SsEvts (cons Id Var Prg)) ) )

(de ssEvt (Id)
   (when (assoc Id *SsEvts)
      (let ((@Var . Prg) (cdr @))
         (task *HtSock)
         (macro
            (and @Var (task (close @Var)))
            (task (setq @Var *HtSock)
               (in @
                  (unless (char)
                     (task (close @Var))
                     (off @Var) ) ) ) )
         (httpHead "text/event-stream" 0)
         (run Prg) ) ) )

(de serverSend (Sock . Prg)
   (when Sock
      (out @
         (ht:Out (bool *Chunked)
            (prin "data: ")
            (htPrin Prg 2)
            (prinl "^J") ) ) ) )

(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 . Prg)
   (tag 'ul Attr 2 Prg)
   (prinl) )

(de 
    •  (Attr . Prg)
   (tag 'li Attr 2 Prg)
   (prinl) )

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

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

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

(de  (Str Url Tar)
   (prin "")
   (ht:Prin Str)
   (prin "") )

(de  (Src Alt Url DX DY)
   (when Url
      (prin "" ) )
   (prin "")
   (and Url (prin "")) )

(de  (Var Val . Prg)
   (prin "")
   (htPrin Prg 2)
   (prin "") )

(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 'thead Attr 2 Prg) )

(de  (Attr . Prg)
   (tag 'tbody 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
   (
 (Attr . Prg)
   (tag 'th Attr 2 Prg) )

(de 
 (Attr . Prg)
   (tag 'td Attr 2 Prg) )

(de 
 '(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)
            (' and '' functions
   Server-Sent Events
   'nsp' function
   Nested block comments
   'tasks' function
   'pool2' function (64-bit)
   Increase 'snapshot' range
   Server-Sent Events
   'blk' function (64-bit)

* 26dec17 picoLisp-17.12
   'byte' function
   Linux/arm64 port
   Added "lib/vip.l" and "bin/vip"
   'fd' function
   National trunk prefix in localization
   'httpGate' shutdown() on SIGALRM
   '+Stop' GUI prefix class
   'help' function
   Bug in '*/' in pil64
   '+Swap/R' GUI prefix class
   '' and '' functions in "lib/gis.l"
   Preserve namespaces in error handler

* 29jun17 picoLisp-17.6
   'ssl' and 'download' functions
   '+TreeChart' GUI class
   'step' stores the key in '@@'
   Optional 'flg' argument for 'delete', 'delq' and 'del'
   Bug in 'ssl', needs SSL_clear()
   Bug in case conversions for TOP character
   "Edit" button in 'repl'
   Added "lib/gis.l" and "lib/android.l"
   Namespace chaining instead of merging
   Disable '+Focus' on touch devices
   Incorrect usage of 'ctl' in 'rc' and 'acquire'
   Bug in 'port' in pil64
   'tzo' function
   'expDat' accepts "." and "+/-" for "today"

* 08dec16 picoLisp-16.12
   'T' result specification for 'native'
   '++' function
   'insert', 'remove', 'place' and 'group' in Asm/C
   '+Obj2' GUI prefix class
   Removed 'zap' protection in pil64
   Bug in 'prin' of anonymous symbols
   '' and '' functions
      lib/xhtml.l
   'local' fix for 'distance'
      lib/gis.l
   Minor reference fixes
      doc/ref.html

14may18
   Minor fix in 'goto'
      lib/vip.l

11may18
   Fix 'ctl' policy
      lib/form.l

09may18
   Check for bad EOL in '_htHead'
      lib/http.l

08may18
   Consider 'Hook' for entity count in 'choDlg'
      lib/form.l

06may18
   Pedantics
      doc/refA.html

05may18
   Minor extension
      ersatz/README
   Generalize and simplify 'serverSentEvent' + 'serverSend'
      lib/xhtml.l
      lib/form.js

02may18
   Minor typo
      doc/refT.html
   No timeouts when '*Timeout' is NIL
      lib/http.l
      lib/form.l
      lib/adm.l
   Accept text from stdin
      lib/vip.l

01may18
   Allow empty (vi) calls
      bin/vip
      lib/vip.l

26apr18
   Disable 'repl' text area unless in edit mode
      lib/form.l
   Change .tiny from "smaller" to "small"
      lib.css
   Minor cosmetics
      lib/android.l

23apr18
   Minor cosmetics
      doc/refL.html

22apr18
   Return true from ':x' command continued
      lib/vip.l
   'nsp' function
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/glob.l
      doc/ref.html
      doc/refN.html
      doc/refP.html
      doc/refS.html
      test/src/sym.l

21apr18
   Handle namespaces in "^]" command
      lib/vip.l
   Minor cosmetics
      {src64,pilos/src}/sym.l

20apr18
   Restore "~" as delimiter
      lib/vip.l

18apr18
   Add "<" and ">" to 'mail' addresses (Mansur Mamkin)
      lib/misc.l

16apr18
   Fix increment (^A) and decrement (^X)
      lib/vip.l
   Nested block comments
      {src64,pilos/src}/io.l
      {src,mini/src}/io.c
      ersatz/sys.src
      doc/ref.html

15apr18
   Return true from ':x' command
      bin/vip
      lib/vip.l

13apr18
   Dangling indexes in duplicate (+List +Bag) items revisited
      lib/db.l
      mini/lib/db.l
      pilos/init/lib/db.l

12apr18
   Ignore non-existing file in ":r" command
      lib/vip.l

10apr18
   Avoid dangling indexes in duplicate (+List +Bag) items
      lib/db.l
      mini/lib/db.l
      pilos/init/lib/db.l
   Word-search also with '@' wildcards
      lib/vip.l

09apr18
   Minor typo
      doc/refV.html

06apr18
   Bug in 'blk' buffer handling
      src64/db.l

01apr18
   Enable hostname validation
      src/ssl.c

23mar18
   'tasks' function
      lib.l
      doc/ref.html
      doc/refT.html

22mar18
   Bug in mirror number parsing
      src/ssl.c

19mar18
   Use hard links if more than one mirror directory
      src/ssl.c
   Persistent marks continued
      lib/vip.l

18mar18
   Persistent marks with "m" command
   "%" replacement for "!", "r" and "w" commands
      lib/vip.l

17mar18
   Replace "%" in "e" command with current filename
      lib/vip.l

15mar18
   Bug in 'echo' for zero 'cnt' arguments
      {src64,pilos/src}/io.l
      src/io.c
      ersatz/fun.src
   Bug in 'pool2' function
      src64/db.l

14mar18
   'pool2' function (64-bit)
      src64/glob.l
      src64/db.l
      doc/ref.html
      doc/refB.html
      doc/refP.html
   'blk' and 'struct' are 64-bit-only
      doc/refB.html
      doc/refS.html

13mar18
   Optional mirror destination directory arguments
      src/ssl.c

11mar18
   Fix trailing slash in 'dirname' and 'basename' arguments
      lib/misc.l
      ersatz/lib.l
      pilos/init/lib/misc.l
      test/lib/misc.l

06mar18
   'diff' with F2 also on encrypted files
   Use 'bash' instead of 'sh' in shell commands
      lib/vip.l

04mar18
   '*F10', '*F11' and  '*F12' (configurable in ~/.pil/viprc)
      lib/vip.l

03mar18
   Fix markup for '#' continued
      lib/vip.l
   Increase 'snapshot' range from 9/10 to 59/60
      lib/too.l

28feb18
   Fix markup for '#' at end of line
      lib/vip.l

27feb18
   Prepend "LSD" command tokens to server messages
      lib/xhtml.l
      lib/form.js

26feb18
   Server-Sent Events
      lib/xhtml.l
      lib/form.js

25feb18
   Allow partial chunks in 'ht:Out'
      src64/ht.l
      src/ht.c

22feb18
   Resolve symbolic links
   Sort directory listing
      lib/vip.l

18feb18
   Show buffer and number of buffers in status line
      lib/vip.l

17feb18
   Relocation errors for 'adrp' in Debian Sid
      src64/arch/arm64.l
      src64/ht.l

16feb18
   Print results in 'repl' inside 'catch' body
      lib/form.l

15feb18
   Return 'T' from 'mark' for non-local symbols (instead of error)
      src64/db.l

14feb18
   Optional 'fd2' for locking
   No need to set 'DbBlock'
   Minor comment fix
      src64/db.l

13feb18
   'blk' function (64-bit)
      src64/glob.l
      src64/db.l
      doc/ref.html
      doc/refB.html
      doc/refE.html

12feb18
   Remove obsolete 'dbfMigrate' function(s)
      lib/too.l

10feb18
   Large font for 'tiny' components
      lib/phone.css

09feb18
   Large font for 'input' fields
      lib/phone.css

07feb18
   Omit 'stepBtn' in 'panel' if 'Cls' is NIL
      lib/form.l

06feb18
   Change "stop" catch tag to 'stop'
      lib/form.l

03feb18
   Pedantics
      lib/vip.l

02feb18
   Remove '*SesAdr' global
      lib/http.l

01feb18
   Optional Session ID for 'psh'
      lib/http.l
      bin/psh

29jan18
   'reload' after "key"
      lib/vip.l

24jan18
   Add note about the meanings of the 'id' numbers
      doc/refI.html

23jan18
   Cosmetics
      doc/select.html

21jan18
   Notifications and Alarm continued
      lib/android.l

20jan18
   Remove 'cancel', change syntax of 'notify' and 'alarm'
      lib/android.l

18jan18
   Initial 'seq' check moved to "init.l"
      app/main.l
      app/init.l

17jan18
   bash-completion uses dynamic loader
      lib/bash_completion

15jan18
   'android~alarm' also at specific date and time
      lib/android.l
   Minor typo
      doc/refB.html

13jan18
   "~" no delimiter
   'reload' after "kab"
      lib/vip.l

12jan18
   Remove "time" from 'proc', and enable for Android
      lib/debug.l
      ersatz/lib.l
   Missing delimiter characters "`~{}"
      lib/vip.l

11jan18
   Destructive side-effect in 'insMode'
      lib/vip.l

10jan18
   Added coroutine producer function
      misc/fibo.l

09jan18
   Bug in token parser
      {src64,pilos/src}/io.l
      ersatz/sys.src
   Let 'co' and 'yield' preserve '@'
      {src64,pilos/src}/flow.l
      doc64/structures
   Cosmetic 'prog1' -> 'swap'
      misc/fibo.l

08jan18
   'byte' is 64-bit-only
      doc/refB.html
      test/src/main.l

05jan18
   Pedantics
      lib/db.l
      app/er.l
   Added 'yoke' link to 'made'
      doc/refM.html

02jan18
   Clean up '*Java', '*Lisp' etc. in '*Fork'
   'android~cancel' function
      lib/android.l

01jan18
   Separate 'java1' function
      lib/android.l

30dec17
   (java "cls") returns the class
   'android~alarm' function
      lib/android.l

####### 17.12 #######
29nov17
   Handle '\' at EOL in strings
      lib/vip.l

19nov17
   'loadTxt' function
      lib/android.l

17nov17
   Ignore SIGPIPE earlier
      src/ssl.c
   Support SSL and AUTH in 'mail'
      lib/misc.l
      doc/refM.html

14nov17
   Edit directories
      lib/vip.l

13nov17
   Added note about valid UTF-8 to "Input/Output"
      doc/ref.html
   Start-of-line search with "^"
      lib/vip.l

12nov17
   Plain (non-pattern) search
   Expand "~/" before file names as $HOME
      lib/vip.l

10nov17
   Inherit LANG to application processes
      src/httpGate.c

09nov17
   Added 'byte' function
      {src64,pilos/src}/glob.l
      {src64,pilos/src}/main.l
      doc/ref.html
      doc/refA.html
      doc/refB.html
      test/src/main.l

05nov17
   Need to seek before truncate
      src/ssl.c

03nov17
   Add 'throw' to pretty-printer
      lib.l
   Bidirectional mode without GET when empty 'url' argument
      src/ssl.c
   Keep port open
      bin/replica

02nov17
   Added (illumos) to SunOS
      README

31oct17
   Bug in setting SYS = .linux
      src64/Makefile

28oct17
   Refer to "picoLisp.tgz" instead of "picoLisp-XXX.tgz"
      INSTALL
   "sys/arm64.linux.*.l" renamed to "sys/arm64.android.*.l"
      src64/Makefile
      src64/sys/arm64.linux.code.l
      src64/sys/arm64.linux.defs.l
      New files
         src64/sys/arm64.android.code.l
         src64/sys/arm64.android.defs.l

25oct17
   Avoid "unpredictable register load" warning in 'drop/pop'
      src64/arch/arm64.l

24oct17
   Fixed example and text for '+Ref2'
      doc/refR.html

18oct17
   New files
      doc/search
      lib/vip.l
      bin/vip

12oct17
   Revert auto-reload on visibilitychange event
      lib/xhtml.l

11oct17
   Don't read same input channel in child processes
      misc/reverse.l

10oct17
   Optional "Reply-To:" header in 'mail' (Andreas Rüegger)
      lib/misc.l

07oct17
   Simple example for reading whole file contents
      doc/tut.html

04oct17
   Continued (Mickie Byrd)
      src/Makefile

03oct17
   Define isinf() for Solaris 10
      src/big.c

27sep17
   Fix for -m32 (Mickie Byrd)
      src/Makefile

14sep17
   Make '*HtSock' global continued
      lib/http.l

11sep17
   Clear named pipes initially
      lib/android.l

10sep17
   'notify' brings current task to front
      lib/android.l
   Use "/dev/urandom" in 'longRand'
      lib/rsa.l

02sep17
   'boss' function
      lib/android.l
   Make '*HtSock' global
      lib/http.l
   Added 'fd' function
      src64/glob.l
      src64/io.l
      src/pico.h
      src/tab.c
      src/io.c
      doc/ref.html
      doc/refF.html

01sep17
   Minor cosmetics
      lib/http.l

31aug17
   Added 'clearHistory' and 'clearCache' functions
   'toast' returns argument string
      lib/android.l

30aug17
   Added 'distance' function
      lib/gis.l
   Added padding to 'tiny' class
      lib/phone.css
   Note about the higher bits in 'rand'
      doc/refR.html

28aug17
   Added "Settings" to language files
      loc/ca
      loc/de
      loc/es
      loc/fr
      loc/gr
      loc/jp
      loc/no
      loc/ru
      loc/sv
   Ignore missing language files in 'locale'
      {lib,pilos/init/lib}/misc.l
   Check for empty value in '(rel?> . +Swap)'
      {lib,pilos/init/lib}/db.l

27aug17
   Minor change: 'max-age' for 'css' from 1 h to 1 d
      lib/http.l

21aug17
   Added 'toast' function
   (wake) only initializes, (wake 'flg) acquires/releases
      lib/android.l
   '*Osm' without implicit clipping
      lib/gis.l

20aug17
   Set '' local
      lib/gis.l

18aug17
   Added '' function
      lib/gis.l
      lib/gis.js
   Make 'css' function global
      lib/xhtml.l

17aug17
   Use "$ " prefix in 'repl' instead of "Shell" button
      lib/form.l

11aug17
   Typos in documentation (Nehal Singhal)
      doc/ref.html
      doc/refA.html
   Added 'startForeground' and 'stopForeground'
      lib/android.l

09aug17
   Omit linefeed in 'wrap' if last word is too long
      lib/misc.l
      test/lib/misc.l

07aug17
   Use 'run'/'str' instead of 'eval'/'any' in 'repl'
      lib/form.l
   No namespace modification in 'java'
      lib/android.l

04aug17
   Keep 'repl' state in global variables
      lib/form.l

02aug17
   Revert 'genKey' change from 25mar16
      {lib,pilos/init/lib}/db.l

31jul17
   'notify' returns 'Notification' object
      lib/android.l

30jul17
   National trunk prefix in localization
      lib/misc.l
      pilos/init/lib/misc.l
      loc/[A-Z]*.l
      doc/refE.html
      doc/refT.html
   Minor reference additions to '+Entity'
      doc/refE.html

29jul17
   OSM continued
      lib/gis.l
   Change 'edit' style to transient
      lib/form.l

28jul17
   OSM view, click and drag events
      lib/gis.l
      lib/gis.js
   'xxxECnt' for PilOS
      pilos/init/lib/db.l

27jul17
   Fixes for 'incECnt', 'decECnt', 'badECnt' and 'fixECnt' (Andreas Rüegger)
      lib/db.l
      lib/too.l
   Documentation fix about T/NIL naming conventions (Nehal Singhal)
      doc/ref.html

26jul17
   'httpGate' shutdown() on SIGALRM
      src/httpGate.c

24jul17
   '+Stop' GUI prefix class
      lib/form.l
   Fix WakeLock release
      lib/android.l

22jul17
   Use home-relative path
      lib/tinymce.l
   Typos in documentation (Nehal Singhal)
      doc/ref.html
      doc/faq.html
      doc/native.html

20jul17
   Changed 'rdOpen[EXY]' to set SIGPIPE to default
      src64/io.l
      src/io.c

19jul17
   Use 'w3m' instead of 'lynx' in 'help'
      lib/debug.l
      doc/refH.html

18jul17
   Added 'help' function (Peter Nagy)
      lib/debug.l
      doc/ref.html
      doc/refH.html
   Enable 'paste' plugin
      lib/tinymce.l

17jul17
   Print PID if 8th argument is zero
      src/ssl.c
   Added 'terminate' function
      lib/android.l

16jul17
   Needs 'fileUri' ('FileProvider') instead of 'fromFile' for SDK >= 24
      lib/android.l

15jul17
   Bug in 'doMulDiv' ('*/')
      {src64,pilos/src}/big.l
   Minor typo
      doc/refT.html

13jul17
   Reference examples
      doc/ref_.html
      doc/refF.html

12jul17
   '+Swap/R' GUI prefix class
      lib/form.l

10jul17
   Added '' URL support
      lib/gis.l
      lib/gis.js

09jul17
   '' function
      lib/gis.l
      lib/gis.js

08jul17
   New file
      lib/gis.js
   Minor 'javascript' cosmetics
      lib/xhtml.l
      lib/form.l
      lib/gis.l

07jul17
   Preserve namespaces in error handler
      {src64,pilos/src}/err.l

06jul17
   'OL-CSS' URL and '' function
      lib/gis.l
   Fix for Cygwin|Msys (Mike Pechkin)
      src/Makefile

05jul17
   Minor addition to greek localiztion
      loc/gr

04jul17
   Added 'wifi?' function
      lib/android.l
   Catalan localiztion (Arnau Figueras)
      loc/ca
   Removed "ifdef __CYGWIN__" for fcntl()
      src/io.c

29jun17
   Mail multipart/alternative block
      lib/misc.l

####### 17.6 #######
28jun17
   Avoid "push S"
      src64/big.l
      pilos/src/big.l

26jun17
   Minor register size change
      src64/arch/arm64.l

24jun17
   Call shell in 'repl'
      lib/form.l
   Minor initialization changes
      lib/android.l

23jun17
   Unlink pipes before creation
      lib/android.l

22jun17
   Minor local declaration
      lib/android.l

20jun17
   Added 'zxing?' checking for QR-Code scanner
      lib/android.l
   Document volatile properties
      doc/ref.html
   "Call" button in 'repl'
      lib/form.l

18jun17
   'ssl' and 'download' functions
      lib/misc.l
      doc/refD.html
      doc/refS.html

16jun17
   Minor ref fixes for 'pool', 'dbSync' and 'lock'
      doc/refP.html
      doc/refD.html
      doc/refL.html

15jun17
   'update', 'update?' and 'location?' functions
   Renamed 'hasCamera' to 'camera?'
      lib/android.l

13jun17
   Added a note in the reference of 'later' about 'rd' and 'pr', in response to
   https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=857277
      doc/refL.html

06jun17
   'lat' and 'lon' functions
      lib/gis.l
   Minor fix to 'idForm', needs (fin "Var")
      lib/form.l

03jun17
   "See also" link to 'swap'
      doc/refS.html

01jun17
   '+TreeChart' GUI class
      lib/form.l

31may17
   'step' stores the key in '@@'
      lib/btree.l
      doc/refS.html

30may17
   Rename 'val' property in '+Radio' to 'rad'
      lib/form.l

26may17
   "name=" optional in 'mail'
      lib/misc.l

16may17
   Wrong charset in "Saint-Exupéry"
      doc/form/form.html

14may17
   Typos in reference (Nehal Singhal)
      doc/form/form.html
      doc/form/refC.html
      doc/form/refD.html
      doc/form/refF.html
      doc/form/refI.html
      doc/form/refO.html
      doc/form/refQ.html
      doc/form/refR.html
      doc/form/refS.html

11may17
   Minor typo
      doc/refA.html

06may17
   Missing line
      loc/es

04may17
   Omit "./" in "src64/tags"
      src64/lib/asm.l

02may17
   Removed 'cut>' and 'paste>' from '+Chart'
      lib/form.l

01may17
   Hint filename in 'repl'
      lib/form.l

30apr17
   Wrong '@' value in 'repl'
      lib/form.l

28apr17
   Fix hook for '+ObjVal'
      lib/form.l

24apr17
   Handle hook for '+ObjVal', and for 'Fld' in 'choDlg'
      lib/form.l

21apr17
   Pass hook to 'panel'
      lib/form.l

20apr17
   Evaluate 'objHook' in '(hint> . +Obj)'
      lib/form.l

19apr17
   Fixes for the mail header parser by Rowan Thorpe
      misc/mailing

18apr17
   Add '@' to the '*Run' reference
      doc/refR.html

12apr17
   Use "302 Found" instead of "301 Moved Permanently" in 'httpGate'
      src/httpGate.c

07apr17
   Simplification of 'delete' etc.
      {src64,pilos/src}/subr.l
      {src64,pilos/src}/sym.l

05apr17
   Optional 'flg' argument also for 'del'
      {src64,pilos/src}/subr.l
      {src64,pilos/src}/sym.l
      {src,mini/src}/subr.c
      {src,mini/src}/sym.c
      doc/refD.html
      test/src/sym.l
   Revert httpGate (without SSL_shutdown())
      src/httpGate.c

04apr17
   Minor fix in 'genKey', make 'ubZval' non-destructive
      pilos/init/lib/db.l
   Delete multiple list elements in '(del> . +List)'
      {lib,mini/lib,pilos/init/lib}/db.l
   Optional 'flg' argument for 'delete' and 'delq'
      {src64,pilos/src}/subr.l
      {src,mini/src}/subr.c
      ersatz/fun.src
      doc/refD.html
      test/src/subr.l

29mar17
   Missing 'flood' function
      doc/ref.html

28mar17
   Conditional "PIE = -no-pie" for x86_64 (Mike Pechkin)
      src64/Makefile
   Add SSL_shutdown() to httpGate
      src/httpGate.c
   Bug in 'ssl', needs SSL_clear()
      src/ssl.c

25mar17
   Bug in case conversions ('fold', 'uppc' etc.) for TOP character
      {src64,pilos/src}/sym.l

24mar17
   'repl' history as '+Hint1'
      lib/form.l
   'repl' eval with environment offset
      lib/form.l

23mar17
   Unmark default namespace
      {src64,pilos/src}/sym.l

21mar17
   Clear line with ^U
      lib/led.l
   Suppress unnecceary "?" in 'url'
      lib/form.l

18mar17
   Handle "301 Moved Permanently" in 'httpGate'
      src/httpGate.c
   Default "PIE = -no-pie" for x86_64
      src64/Makefile

17mar17
   Handle "301 Moved Permanently" in 'httpGate'
      src/httpGate.c
      doc/httpGate.html

16mar17
   Removed legacy version checks
      src64/arch/emu.l
      pilos/make.l

15mar17
   Fix ref example for 'struct' (03nov16: Terminate char arrays on null bytes)
      doc/refS.html
   Internal 'Intent' methods in addition to 'putExtra'
      lib/android.l
   'repl' '@@' and '@@@' handling
   'file>' method for '+FileField'
   "Edit" button in 'repl'
      lib/form.l

11mar17
   Missing part in '+Joint' example
      doc/refJ.html

10mar17
   Still bug in secondary namespace lookup
      {src64,pilos/src}/sym.l
   Pass either unit or zoom to 
      lib/svg.l
   Local renames
      lib/gis.l

09mar17
   Bug lookup of long names in secondary namespaces
      {src64,pilos/src}/sym.l
   New files
      lib/gis.l
      lib/android.l
      lib/nodroid.l
   'all' also for given namespace
      {src64,pilos/src}/sym.l
      doc/refA.html

08mar17
   Minor change (Danilo Kordic)
      lib/eled.l
   Bug in 'intern' for namespaces
      {src64,pilos/src}/sym.l
      doc/refI.html
      doc/refN.html

07mar17
   Minor clean up in 'equ' definitions
      pilos/src/defs.l

06mar17
   'symbols' optional 'prg' for local namespace list
      {src64,pilos/src}/sym.l
      lib.l
      doc/refS.html
      doc/refL.html
   Omit 'local' and 'import' from pil32
      lib.l
   Bug in namespace chaining
      {src64,pilos/src}/sym.l
   Added 'url1>'
      lib/db.l

04mar17
   Namespace chaining instead of merging
      {src64,pilos/src}/glob.l
      {src64,pilos/src}/main.l
      {src64,pilos/src}/gc.l
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/io.l
      {src64,pilos/src}/err.l
      src64/ht.l
      lib.l
      lib/debug.l
      pilos/init/lib.l
      pilos/init/lib/dbg.l
      test/src/sym.l
      doc/ref.html
      doc/refI.html
      doc/refL.html
      doc/refP.html
      doc/refS.html
      doc/refZ.html

03mar17
   French localization
      loc/FR.l
      loc/fr
      app/loc/fr
      app/main.l

24feb17
   Input fields without border
      lib.css

17feb17
   Minor ref fix
      doc/ref.html

08feb17
   idFocus() function and disable '+Focus' on touch devices
      lib/form.js
      lib/form.l

07feb17
   More "See also" entries for flow functions
      doc/refA.html
      doc/refC.html
      doc/refI.html
      doc/refN.html
      doc/refO.html
      doc/refU.html
      doc/refW.html

05feb17
   Minor fixes to some 'chk>' methods
      lib/form.l

30jan17
   Note 'flush' in the 'out' reference
      doc/refO.html

27jan17
   More tag fixes
      doc/form/refC.html

26jan17
   More tag fixes
      doc/form/refA.html
      doc/form/refC.html
      doc/form/refD.html
      doc/form/refF.html
      doc/form/refI.html
      doc/form/refJ.html
      doc/form/refO.html
      doc/form/refQ.html

25jan17
   More tag fixes
      doc/form/refF.html
      doc/form/refO.html
      doc/form/refQ.html
      doc/form/refS.html
      doc/form/refV.html
      doc/form/form.html

24jan17
   Bug in indent script with closing comments '}#'
      bin/pilIndent

23jan17
   More typos in docs
      doc/app.html

22jan17
   Unmatched tags (Jon / Mattias)
      doc/form/refC.html

20jan17
   Incorrect usage of 'ctl' in 'rc' and 'acquire'
      lib.l

17jan17
   Bug in 'port', guarantee 16-bit value after ntohs()
      src64/net.l
   More ref fixes (Jon / Mattias)
      doc/form/refQ.html

13jan17
   Missing '#' in link (Jon / Mattias)
      doc/form/refP.html

09jan17
   Make 'tzo' Linux-only
      src/main.c
      doc/refT.html
      test/src/main.l
   Remove lib/dbase.l from distribution
      lib/dbase.l
   Avoid race condition in 'tzo' unit test
      test/src/main.l

07jan17
   'tzo' function
      src64/sys/arm64.linux.defs.l
      src64/sys/x86-64.linux.defs.l
      src64/sys/ppc64.linux.defs.l
      src64/sys/x86-64.freeBsd.defs.l
      src64/sys/x86-64.openBsd.defs.l
      src64/sys/x86-64.sunOs.defs.l
      src64/sysdefs.c
      src64/main.l
      src64/glob.l
      src/pico.h
      src/tab.c
      src/main.c
      doc/ref.html
      doc/refT.html
      test/src/main.l

02jan17
   One more example for 'fish'
      doc/refF.html

22dec16
   Preserve "LayX" in 
      lib/xhtml.l

19dec16
   Add '+Rid' to 'resetButton'
      lib/form.l

18dec16
   'expDat' accepts "." and "+/-" for "today"
      lib/misc.l
      doc/refE.html
      test/lib/misc.l

16dec16
   Base64-encode 'mail' subject if necessary
      lib/misc.l
   Wrong link to 'mail'
      doc/refP.html

14dec16
   Better error diagnostics
      src64/mkAsm

12dec16
   Minor typo, duplicated line
      doc/refR.html

09dec16
   Reverse bind order (for (pathologically) duplicated symbols)
      {src64,pilos/src}/main.l
      {src64,pilos/src}/flow.l

####### 16.12 #######
05dec16
   Stub for 'PIE = -no-pie' in Linux/x86_64 (enable in Debian Sid)
      src64/Makefile

04dec16
   Example for 'need'
      doc/refN.html

02dec16
   'T' result specification for 'native'
      src64/main.l
      doc/refN.html

29nov16
   Reference clarification for 'diff'
      doc/refD.html

25nov16
   Minor fix, quote in 'delim?' not needed
      lib/led.l

24nov16
   '++' function
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/glob.l
      src/sym.c
      src/tab.c
      src/pico.h
      mini/src/sym.c
      mini/src/init.s
      ersatz/fun.src
      doc/ref.html
      doc/ref_.html
      doc/refP.html
      test/src/sym.l
      bin/pilIndent
      games/chess.l
      misc/trip.l
      misc/rcsim.l
      misc/calc.l
      lib/xm.l
      lib/xml.l
      lib/conDbgc.l
      lib/misc.l
      mini/lib/misc.l
      lib/app.l
      lib/complete.l
      lib/too.l
      lib/form.l
      lib/tex.l
      lib/simul.l
      lib/ps.l
      lib/xmlrpc.l
      lib/lint.l
      lib/btree.l
      lib/adm.l
      lib/debug.l
      mini/lib/debug.l
      lib/json.l
      lib/dbase.l
      lib/http.l
      lib/tinymce.l
      lib/sq.l
      lib/eled.l
      lib/db32-64.l
      lib/led.l
      lib/rsa.l
      lib/db.l
      mini/lib/db.l
      lib/scrape.l
      lib/xhtml.l
      lib/pilog.l
      mini/lib/pilog.l
      lib/svg.l
      ersatz/lib.l
      app/lib.l
      lib.l
      pilos/init/lib/misc.l
      pilos/init/lib/dbg.l
      pilos/init/lib/btree.l
      pilos/init/lib/sq.l
      pilos/init/lib/db.l
      pilos/init/lib/pilog.l
      pilos/init/lib.l
   Incomplete error diagnoses in pil64 (X register)
   'de', 'read', 'with', 'bind', 'co', 'on', 'off', 'onOff', 'zero' and 'one'
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/flow.l
      {src64,pilos/src}/io.l

23nov16
   Surplus parenthesis
      doc/tut.html

16nov16
   Added 'url5>' .. 'url9>'
      lib/db.l

06nov16
   *Dbg info in GUI form (vi *Top)
      lib/form.l

04nov16
   More examples for 'filter'
      doc/refF.html

03nov16
   Terminate 'native' char arrays on null bytes
      src64/main.l
   Bug in 'native', needs 'consE_Y'
      src64/main.l
   Introduce 'consE_Y' to save E across garbage collection
      {src64,pilos/src}/gc.l

25oct16
   Minor typo
      doc/refG.html

24oct16
   'group' in Asm/C
      {src64,pilos/src}/subr.l
      {src64,pilos/src}/glob.l
      pilos/init/lib.l
      src/pico.h
      src/subr.c
      src/tab.c
      lib.l
      test/lib.l
      test/src/subr.l

20oct16
   'insert', 'remove' and 'place' in Asm/C
      {src64,pilos/src}/subr.l
      {src64,pilos/src}/glob.l
      pilos/init/lib.l
      src/pico.h
      src/subr.c
      src/tab.c
      lib.l
      test/lib.l
      test/src/subr.l

17oct16
   Check for '+relation' in 'dbfCheck'
      lib/too.l
   '+Obj2' GUI prefix class
      lib/form.l

11oct16
   Several doc fixes by Rick Hanson
      doc/ref.html

06oct16
   Note in 'lup' reference about empty tree
      doc/refL.html

03oct16
   Minor tuning
      app/item.l

01oct16
   Cleared-up description of 'sort'
      doc/refS.html

30sep16
   Emacs lisp patches by Vasilij Schneidermann
      lib/el/picolisp.el

24sep16
   Minor typo
      doc/native.html

13sep16
   Remove 'zap' protection in pil64
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/glob.l

10sep16
   Add 'viewBox' to ''
      lib/svg.l

09sep16
   Add '+Swap' link
      doc/refR.html

06sep16
   Small optimizations (Mike Pechkin)
      lib/db.l
      mini/lib/db.l
      pilos/init/lib/db.l
   'repl' optional size parameters
      lib/form.l

05sep16
   Viewport relative font size
      lib/phone.css
   Minor ref fix
      doc/refF.html
   'T' argument to '' for percentages
      lib/xhtml.l

04sep16
   Mistype in '=0' ref
      doc/ref_.html
   Global '' state
      lib/xhtml.l

03sep16
   Changed ''
      lib/xhtml.l

17dec15
   '+InsRowButton' GUI prefix class
      lib/form.l
      loc/de
      loc/jp

16dec15
   Added 'pil' to index
      doc/ref.html

10dec15
   Minor typo
      doc/refR.html

03dec15
   Avoid duplicated REPL history after editing with ^E. Simplified.
      lib/led.l
      lib/eled.l
      pilos/init/lib/dbg.l

27nov15
   Preserve default value in '+Tip'
      lib/form.l
   Minor comment fix
      src/ext.c

26nov15
   Add "threads" section to FAQ
      doc/faq.html

####### 15.11 #######
24nov15
   Version Numbering: Switch to YY.MM[.nn] style
      {src64,pilos/src}/version.l
      {src64,pilos/src}/glob.l
      src/main.c
      ersatz/fun.src
      doc/refV.html

####### 3.1.11.14 #######
20nov15
   Changed "bin/replica" to non-forking server
      bin/replica

16nov15
   Fine-tuned and optimized 64-bit version for ARMv8 (arm64)
      README
      INSTALL
      doc64/README
      doc/refC.html
      src64/Makefile
      src64/lib/asm.l
      src64/arch/arm64.l

####### 3.1.11.13 #######
11nov15
   'catch' and 'throw' flow control instructions
      doc64/asm
      src64/lib/asm.l
      src64/arch/*.l
      {src64,pilos/src}/flow.l

####### 3.1.11.12 #######
06nov15
   Omit message-body in 'noContent'
      lib/http.l
   '+ObjVal' GUI prefix class
      lib/form.l

31oct15
   64-bit version for ARMv8 (arm64)
      src64/arch/arm64.l

30oct15
   Condition code instructions: Separate borrow [b] from carry [c]
      doc64/asm
      src64/lib/asm.l
      src64/arch/*.l
      {src64,pilos/src}/flow.l
      {src64,pilos/src}/big.l
      {src64,pilos/src}/db.l

26oct15
   Condition code instructions: Removed 'ldc' and 'ldnc'
      doc64/asm
      src64/lib/asm.l
      src64/arch/*.l
      {src64,pilos/src}/db.l
      {src64,pilos/src}/io.l
      {src64,pilos/src}/sym.l
      src64/ext.l

20oct15
   Removed 'movm' instruction
      doc64/asm
      src64/lib/asm.l
      src64/arch/*.l
      {src64,pilos/src}/io.l

####### 3.1.11.11 #######
12oct15
   Simplified unit test setup
      lib/test.l
      test/src/net.l

12oct15
   Switched ppc64 version to ppc64le (little endian)
      src64/Makefile
      src64/arch/ppc64.l
      src64/sys/ppc64.linux.defs.l

10oct15
   Changed asm syntax 'push/pop F' to 'push/pop zsc' and 'push/pop x'
      src64/arch/x86-64.l
      src64/arch/ppc64.l
      src64/arch/emu.l
      {src64,pilos/src}/main.l
      {src64,pilos/src}/big.l
      {src64,pilos/src}/err.l

04oct15
   Condition code instructions: New extension bit [x] in addition to carry [c]
      doc64/asm
      src64/lib/asm.l
      src64/arch/x86-64.l
      src64/arch/ppc64.l
      src64/arch/emu.l
      {src64,pilos/src}/main.l
      {src64,pilos/src}/gc.l
      {src64,pilos/src}/flow.l
      {src64,pilos/src}/sym.l
      {src64,pilos/src}/subr.l
      {src64,pilos/src}/big.l
      {src64,pilos/src}/io.l
      {src64,pilos/src}/db.l
      src64/net.l
      src64/err.l
      src64/ext.l
      src64/ht.l

####### 3.1.11.10 #######
03oct15
   Check for FD overflow in 'waitFdCEX_A'
      src64/glob.l
      src64/io.l

####### 3.1.11.9 #######
29sep15
   Minor ref and comment fixes
      doc/refI.html
      {src64,pilos/src}/flow.l
      src/flow.c
      mini/src/flow.c
      ersatz/fun.src

16sep15
   'cache' without 'prg' argument returns internal 'var'
      lib.l
      ersatz/lib.l
      pilos/init/lib.l
      test/lib.l
      test/src/sym.l

####### 3.1.11.8 #######
06sep15
   Minor reference details for 'eval' and 'run'
      doc/refE.html
      doc/refR.html

03sep15
   '+Chg' prefix crashes without JS
      lib/form.l

####### 3.1.11.7 #######
02sep15
   Minor cosmetics
      lib/heartbeat.l
      bin/watchdog

   Use (lock) to be on the safe side
      bin/replica

01sep15
   Extensions and additions by Oscar Roca
      lib/openGl.l

####### 3.1.11.6 #######
26aug15
   Omit keyfile lock. Not needed, because only a single 'ssl' process feeds it
      bin/replica

####### 3.1.11.5 #######
04aug15
   Removed '' function
      lib/xhtml.l

####### 3.1.11.4 #######
18jul15
   Synchronize exernal changes in '+E/R' prefix class
      lib/form.l

####### 3.1.11.3 #######
13jul15
   Added all-uppercase rule to the naming conventions
      doc/ref.html

08jul15
   Revert 'ssl' to alarm()
      src/ssl.c

####### 3.1.11.2 #######
06jul15
   Check for empty date in 'day'
      lib/misc.l
      ersatz/lib.l
      doc/tut.html

02jul15
   Slightly improve 'scrape' for 'href' with nested 'img'
      lib/scrape.l

####### 3.1.11.1 #######
25jun15
   Forgotten file
      lib/svg.l

####### 3.1.10.9 #######
18jun15
   Optional 'T' argument to 'asm' function
      src64/lib/asm.l

17jun15
   Slightly extended 'idObj' formatting
      lib/form.l

13jun15
   Generic 'asm' directive
      src64/lib/asm.l

####### 3.1.10.8 #######
09jun15
   Enable "Delete" button only in enabled form
      lib/form.l

01jun15
   Bug in binary print of partial circular lists
      src64/io.l
      pilMCU/src/io.l
      src/io.c

27may15
   Clean up circular checks (64-bit)
   Check for circularity in 'funqE_FE' + 'funq'
      src64/main.l
      src64/subr.l
      src64/io.l
      pilMCU/src/main.l
      pilMCU/src/subr.l
      pilMCU/src/io.l
      ersatz/sys.src
      src/main.c
      mini/src/main.c
      mini/src/sym.c
      doc/refC.html

####### 3.1.10.7 #######
26may15
   Remove setpgid() from 'doExec'
      src64/flow.l
      src/flow.c
   SVG Printing
      lib/svg.l
      app/main.l
      app/ord.l
      app/lib.l

24may15
   '=1' function
      src64/subr.l
      src64/glob.l
      pilMCU/src/subr.l
      pilMCU/src/glob.l
      src/subr.c
      src/tab.c
      src/pico.h
      mini/src/subr.c
      mini/src/init.s
      ersatz/fun.src
      doc/ref.html
      doc/ref_.html
      test/src/subr.l

####### 3.1.10.6 #######
23may15
   Need 'note' instead of 'alert'
      misc/calc.l

21may15
   Check meta 'hook' in '+Obj' prefix
      lib/form.l
   Fix 'dump' for keys with hooks
      lib/too.l

19may15
   Bug in 'compareAE_F' for external symbols
      src64/main.l
      pilMCU/src/main.l

####### 3.1.10.5 #######
18may15
   Update reference to describe the 64-bit structures
      doc/ref.html

06may15
   Slightly simplified
      lib/role.l

05may15
   Imported 'choUser'
      lib/adm.l
      lib/user.l

03may15
   Accept \ddd\ in strings
      src64/io.l
      pilMCU/src/io.l
      src/io.c
      ersatz/sys.src
      doc/ref.html

02may15
   Changed HTTP parsing to use 'till' instead of 'match'
      lib/http.l

####### 3.1.10.4 #######
01may15
   Reference entry for 'prBase64'
      doc/refP.html
   More examples for 'in' and 'out'
      doc/refI.html
      doc/refO.html

30apr15
   Accept \n, \r and \t in strings
      src64/io.l
      pilMCU/src/io.l
      src/io.c
      ersatz/sys.src
      doc/ref.html

####### 3.1.10.3 #######
30apr15
   'prBase64' multiline Base64 printing
      lib/misc.l
   Catch "undefined" arguments in Canvas drawing
      lib/canvas.js

28apr15
   Changes to 'seed' and 'rand' in Ersatz suggested by Christophe Gragnic
      ersatz/fun.src

####### 3.1.10.2 #######
26apr15
   Added library for a subset of JSON
      lib/json.l
   Fix 'memq' instruction in 'emu'
      src64/arch/emu.l
   Support also input (parse) mode for 'ext:Base64'
      src64/ext.l
      src/ext.c
      test/src/ext.l

24apr15
   Additional "user:passwd" argument to 'xmlrpc'
      lib/xmlrpc.l

####### 3.1.10.1 #######
24apr15
   Optional styles in 
 '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
# (stepBtn 'lst ['msg])
# (stepBtn 'var 'cls [['hook] 'msg])
(de stepBtn (X . @)
   ( 'step
      (use (S1 S2)
         (if (pair X)
            (setq S1 (car X)  S2 (cdr X))
            (let
               (Rel (meta *ID X)
                  K
                  (cond
                     ((isa '+Key Rel)
                        (get *ID X) )
                     ((isa '+Fold Rel)
                        (cons (fold (get *ID X)) *ID) )
                     (T
                        (cons
                           (get *ID X)
                           (conc
                              (mapcar '((S) (get *ID S)) (; Rel aux))
                              *ID ) ) ) )
                  Cls (next)
                  Hook (next)
                  Q1 (init (tree X Cls Hook) K NIL)
                  Q2 (init (tree X Cls Hook) K T) )
               (unless (get *ID T)
                  (step Q1 T)
                  (step Q2 T) )
               (setq
                  S1 (step Q1 T)
                  S2 (step Q2 T) ) ) )
         (let Msg (or (next) 'url>)
            (if (and S1 (send Msg @ *Tab))
               ( ,"Next object of the same type"
                  ( "<<<" (mkUrl @)) )
               (prin "<<<") )
            (prin " -- ")
            (if (and 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 
 NIL ,"Page" NIL
      ( NIL ,"Background color" (pgRgbPicker))
      (while Page
         ( NIL
            (eval (++ Page))
            (eval (++ Page)) ) ) )
   (--)
   (
 NIL ,"Box" '((NIL) (NIL) (align) NIL (align) NIL)
      ( NIL
         ,"Image" (pdfImgField) - - - - - )
      ( NIL
         ,"Background color" (pdfRgbPicker) )
      ( NIL
         ,"Border color" (pdfBdRgbPicker)
         ,"Width" (pdfBdWidthField)
         ,"Margin" (pdfBdMarginField) )
      ( NIL
         ,"Font" (pdfFontField *FontFamilies)
         ,"Size" (pdfSizeField)
         ( ,"All Fonts" "!fonts.svg" ,"All Fonts") - )
      (while Box
         ( NIL
            (eval (++ Box))
            (eval (++ Box)) ) ) )
   (ht:Prin ,"Alignment")
   ( 3)
   (pdfAlignRadio)
   (pdfTextField 48 12)
   ( (gui '(+Rid +Button) ,"Apply") (pdfFrontButton) (pdfDelButton)) )

# vi:et:ts=3:sw=3
picoLisp/lib/tex.l0000644000175000017500000000656413015541536012501 0ustar  abuabu# 24nov16abu
# (c) Software Lab. Alexander Burger

# Convert to PDF document
(de dviPdf (Doc)
   (prog1
      (tmp Doc ".pdf")
      (call "/usr/bin/dvips" "-q" (pack Doc ".dvi"))
      (call "ps2pdf" (pack Doc ".ps") @)
      (call "rm" "-f"
         (pack Doc ".tex")
         (pack Doc ".dvi")
         (pack Doc ".ps") ) ) )

# Tex Formatting
(de tex (S  . @)
   (prin "\\" (or S (next)))
   (when (args)
      (prin "{")
      (texPrin (next))
      (while (args)
         (when (next)
            (prin "\\\\")
            (texPrin (arg)) ) )
      (prin "}") )
   (and S (prinl)) )

(de texl (S . @)
   (prin "\\" (or S (next)) "{")
   (loop
      (let Lst (next)
         (texPrin (++ Lst))
         (while Lst
            (when (++ Lst)
               (prin "\\\\")
               (texPrin @) ) ) )
      (NIL (args))
      (prin (next)) )
   (prin "}")
   (and S (prinl)) )

(de texPrin (X)
   (let Q NIL
      (for C (chop X)
         (cond
            ((sub? C "#$%&_{}")
               (prin "\\" C) )
            ((sub? C "<²>")
               (prin "$" C "$") )
            (T
               (prin
                  (case C
                     (`(char 8364) "\\EUR")
                     ("\"" (if (onOff Q) "``" "''"))
                     ("\\" "$\\backslash$")
                     ("\^" "\\char94")
                     ("~" "\\char126")
                     (T C) ) ) ) ) ) ) )


### TeX Document ###
(de document (Doc Cls Typ Use . Prg)
   (out (list "@bin/lat1" (pack Doc ".tex"))
      (prinl "\\documentclass[" Cls "]{" Typ "}")
      (while Use
         (if (atom (car Use))
            (prinl "\\usepackage{" (++ Use) "}")
            (prinl "\\usepackage[" (caar Use) "]{" (cdr (++ Use)) "}") ) )
      (prinl "\\begin{document}")
      (prEval Prg 2)
      (prinl "\\end{document}") )
   (call "sh" "-c"
      (pack "latex -interaction=batchmode " Doc ".tex >/dev/null") )
   (call "rm" (pack Doc ".aux") (pack Doc ".log")) )

(de \\block (S . Prg)
   (prinl "\\begin{" S "}")
   (prEval Prg 2)
   (prinl "\\end{" S "}") )

(de \\figure (S . Prg)
   (prinl "\\begin{figure}" S)
   (prEval Prg 2)
   (prinl "\\end{figure}") )


### Tabular environment ###
(de \\table (Fmt . Prg)
   (prinl "\\begin{tabular}[c]{" Fmt "}")
   (prEval Prg 2)
   (prinl "\\end{tabular}") )

(de \\carry ()
   (prinl "\\end{tabular}")
   (prinl)
   (prinl "\\begin{tabular}[c]{" "Fmt" "}") )

(de \\head @
   (prin "\\textbf{" (next) "}")
   (while (args)
      (prin " & \\textbf{")
      (texPrin (next))
      (prin "}") )
   (prinl "\\\\") )

(de \\row @
   (when (=0 (next))
      (next)
      (prin "\\raggedleft ") )
   (ifn (=T (arg))
      (texPrin (arg))
      (prin "\\textbf{")
      (texPrin (next))
      (prin "}") )
   (while (args)
      (prin " & ")
      (when (=0 (next))
         (next)
         (prin "\\raggedleft ") )
      (ifn (=T (arg))
         (texPrin (arg))
         (prin "\\textbf{")
         (texPrin (next))
         (prin "}") ) )
   (prinl "\\\\") )

(de \\hline ()
   (prinl "\\hline") )

(de \\cline (C1 C2)
   (prinl "\\cline{" C1 "-" C2 "}") )


### Letter Document Class ###
(de \\letter (Lst . Prg)
   (prin "\\begin{letter}{" (++ Lst))
   (while Lst
      (when (++ Lst)
         (prin "\\\\" @) ) )
   (prinl "}")
   (prEval Prg 2)
   (prinl "\\end{letter}") )

(de \\signature (S)
   (tex "signature" S) )

(de \\opening (S)
   (tex "opening" S) )

(de \\closing (S)
   (tex "closing" S) )
picoLisp/lib/xml.l0000644000175000017500000002216013015542207012463 0ustar  abuabu# 24nov16abu
# 21jan09 Tomas Hlavaty 

# Check or write header
(de xml? (Flg)
   (if Flg
      (prinl "")
      (skip)
      (prog1
         (head '("<" "?" "x" "m" "l") (till ">"))
         (char) ) ) )

# Generate/Parse XML data
# expects well formed XML
# encoding by picolisp (utf8 "only", no utf16 etc.)
# trim whitespace except in cdata
# ignore  ent
(de xml (Lst N)
   (if Lst
      (let (Nn NIL Nl NIL Pre NIL)
         (when N
            (do (abs N)
               (push 'Nn (if (lt0 N) "^I" " ")) ) )
         (_xml_ Lst) )
      (_xml) ) )

(de _xml_ (Lst)
   (let Tag (++ Lst)
      (when Nl
         (prinl)
         (when Pre
            (prin Pre) ) )
      (prin "<" Tag)
      (for X (++ Lst)
         (prin " " (car X) "=\"")
         (escXml (cdr X))
         (prin "\"") )
      (ifn Lst
         (prin "/>")
         (prin ">")
         (use Nlx
            (let (Nl N
                  Pre (cons Pre Nn) )
               (for X Lst
                  (if (pair X)
                     (_xml_ X)
                     (off Nl)
                     (escXml X) ) )
               (setq Nlx Nl) )
            (when Nlx
               (prinl)
               (when Pre
                  (prin Pre) ) ) )
         (prin "") ) ) )

(de _xml (In Char)
   (unless Char
      (skip)
      (unless (= "<" (char))
         (quit "Bad XML") ) )
   (case (peek)
      ("?"
         (from "?>")
         (unless In (_xml In)) )
      ("!"
         (char)
         (case (peek)
            ("-"
               (ifn (= "-" (char) (char))
                  (quit "XML comment expected")
                  (from "-->")
                  (unless In (_xml In)) ) )
            ("D"
               (if (find '((C) (<> C (char))) '`(chop "DOCTYPE"))
                  (quit "XML DOCTYPE expected")
                  (when (= "[" (from "[" ">"))
                     (use X
                        (loop
                           (T (= "]" (setq X (from "]" "\"" "'" ""))
                              (NIL (quit "Unbalanced XML DOCTYPE")) ) ) )
                     (from ">") )
                  (unless In (_xml In)) ) )
            ("["
               (if (find '((C) (<> C (char))) '`(chop "[CDATA["))
                  (quit "XML CDATA expected")
                  (pack
                     (head -3
                        (make
                           (loop
                              (NIL (link (char)) (quit "Unbalanced XML CDATA"))
                              (T (= '`(chop "]]>") (tail 3 (made)))) ) ) ) ) ) )
            (T (quit "Unhandled XML tag")) ) )
      (T
         (let Tok (till " ^I^M^J/>" T)
            (use X
               (make
                  (link (intern (pack Tok)))
                  (let L
                     (make
                        (loop
                           (NIL (skip) (quit "Unexpected end of XML" Tok))
                           (T (member @ '("/" ">")))
                           (NIL (setq X (intern (pack (trim (till "="))))))
                           (char)
                           (skip)
                           (let C (char)
                              (unless (member C '("\"" "'"))
                                 (quit "XML attribute quote expected" X) )
                              (link (cons X (pack (xmlEsc (till C))))) )
                           (char) ) )
                     (if (= "/" (char))
                        (prog (char) (and L (link L)))
                        (link L)
                        (loop
                           (NIL (if *XmlKeepBlanks (peek) (skip))
                              (quit "Unexpected end of XML" Tok) )
                           (T (and (= "<" (setq X (char))) (= "/" (peek)))
                              (char)
                              (unless (= Tok (till " ^I^M^J/>" T))
                                 (quit "Unbalanced XML" Tok) )
                              (skip)
                              (char) )
                           (if (= "<" X)
                              (when (_xml T "<")
                                 (link @) )
                              (link
                                 (pack
                                    (xmlEsc
                                       ((if *XmlKeepBlanks prog trim)
                                          (cons X (till "<")) ) ) ) ) ) ) ) ) ) ) ) ) ) )

(de xmlEsc (L)
   (use (@X @Z)
      (make
         (while L
            (ifn (match '("&" @X ";" @Z) L)
               (link (++ L))
               (link
                  (cond
                     ((= @X '`(chop "quot")) "\"")
                     ((= @X '`(chop "amp")) "&")
                     ((= @X '`(chop "lt")) "<")
                     ((= @X '`(chop "gt")) ">")
                     ((= @X '`(chop "apos")) "'")
                     ((= "#" (car @X))
                        (char
                           (if (= "x" (cadr @X))
                              (hex (cddr @X))
                              (format (cdr @X)) ) ) )
                     (T @X) ) )
               (setq L @Z) ) ) ) ) )

(de escXml (X)
   (for C (chop X)
      (prin (case C
               ("\"" """)
               ("&" "&")
               ("<" "<")
               (">" ">")
               (T C) ) ) ) )


# Simple XML string
(de xml$ (Lst)
   (pack
      (make
         (recur (Lst)
            (let Tag (++ Lst)
               (link "<" Tag)
               (for X (++ Lst)
                  (link " " (car X) "=\"" (cdr X) "\"") )
               (ifn Lst
                  (link "/>")
                  (link ">")
                  (for X Lst
                     (if (pair X)
                        (recurse X (+ 3 N))
                        (link X) ) )
                  (link "") ) ) ) ) ) )


# Access functions
(de body (Lst . @)
   (while (and (setq Lst (cddr Lst)) (args))
      (setq Lst (asoq (next) Lst)) )
   Lst )

(de attr (Lst Key . @)
   (while (args)
      (setq
         Lst (asoq Key (cddr Lst))
         Key (next) ) )
   (cdr (asoq Key (cadr Lst))) )

#  output
(de "xmlL" Lst
   (push '"Xml"
      (make
         (link (++ Lst))
         (let Att
            (make
               (while (and Lst (car Lst) (atom (car Lst)))
                  (let K (++ Lst)
                     (if (=T K)
                        (for X (eval (++ Lst) 1)
                           (if (=T (car X))
                              (link (cons (cdr X) NIL))
                              (when (cdr X)
                                 (link X) ) ) )
                        (when (eval (++ Lst) 1)
                           (link (cons K @)) ) ) ) ) )
            (let "Xml" NIL
               (xrun Lst)
               (ifn "Xml"
                  (when Att
                     (link Att) )
                  (link Att)
                  (chain (flip "Xml")) ) ) ) ) ) )

(de "xmlO" Lst
   (let Tag (++ Lst)
      (when "Nl"
         (prinl)
         (when "Pre"
            (prin "Pre") ) )
      (prin "<" Tag)
      (while (and Lst (car Lst) (atom (car Lst)))
         (let K (++ Lst)
            (if (=T K)
               (for X (eval (++ Lst) 1)
                  (if (=T (car X))
                     (prin " " (cdr X) "=\"\"")
                     (when (cdr X)
                        (prin " " (car X) "=\"")
                        (escXml (cdr X))
                        (prin "\"") ) ) )
               (when (eval (++ Lst) 1)
                  (prin " " K "=\"")
                  (escXml @)
                  (prin "\"") ) ) ) )
      (ifn Lst
         (prin "/>")
         (prin ">")
         (use Nl
            (let ("Nl" "N"
                  "Pre" (cons "Pre" "Nn") )
               (xrun Lst)
               (setq Nl "Nl") )
            (when Nl
               (prinl)
               (when "Pre"
                  (prin "Pre") ) ) )
         (prin "") ) ) )

(de  ("N" . Lst)
   (if (=T "N")
      (let ( "xmlL"
            xprin '(@ (push '"Xml" (pass pack)))
            xrun '((Lst Ofs)
                   (default Ofs 2)
                   (for X Lst
                      (if (pair X)
                         (eval X Ofs '("Xml"))
                         (when (eval X Ofs '("Xml"))
                            (xprin @) ) ) ) )
            "Xml" NIL )
         (run Lst 1 '( xprin xrun "Xml"))
         (car (flip "Xml")) )
      (let ( "xmlO"
            xprin '(@ (off "Nl") (mapc escXml (rest)))
            xrun '((Lst Ofs)
                   (default Ofs 2)
                   (for X Lst
                      (if (pair X)
                         (eval X Ofs '("Nl" "Pre"))
                         (when (eval X Ofs '("Nl" "Pre"))
                            (xprin @) ) ) ) )
            "Nn" NIL
            "Nl" NIL
            "Pre" NIL )
         (when "N"
            (do (abs "N")
               (push '"Nn" (if (lt0 "N") "^I" " ")) ) )
         (run Lst 1 '( xprin xrun "N" "Nn" "Nl" "Pre")) ) ) )

# vi:et:ts=3:sw=3
picoLisp/doc/index.html0000644000175000017500000000566712663602746013534 0ustar  abuabu


	
	PicoLisp Docs
	
	


	
		
		
	
	
	
		
		
	




picoLisp/doc/toc.html0000644000175000017500000000216512731744546013201 0ustar  abuabu


	
	PicoLisp Doc TOC
	
	


	
PicoLisp Docs

	


picoLisp/doc/rlook.html0000644000175000017500000000251011276773503013532 0ustar  abuabu


	
	PicoLisp RefLook
	
	
	


	


picoLisp/doc/faq.html0000644000175000017500000007464213422270437013163 0ustar  abuabu



PicoLisp FAQ



abu@software-lab.de



Monk: "If I have nothing in my mind, what shall I do?"

Joshu: "Throw it out."

Monk: "But if there is nothing, how can I throw it out?"

Joshu: "Well, then carry it out."

(Zen koan)



PicoLisp Frequently Asked Questions



(c) Software Lab. Alexander Burger







Why did you write yet another Lisp?



Because other Lisps are not the way I'd like them to be. They concentrate on
efficient compilation, and lost the one-to-one relationship of language and
virtual machine of an interpreted system, gave up power and flexibility, and
impose unnecessary limitations on the freedom of the programmer. Other reasons
are the case-insensitivity and complexity of current Lisp systems.





Who can use PicoLisp?



PicoLisp is for programmers who want to control their programming
environment, at all levels, from the application domain down to the bare metal,
who want to use a transparent and simple - yet universal - programming model,
and who want to know exactly what is going on.


It does not pretend to be easy to learn. There are already plenty of
languages that do so. It is not for people who don't care what's under the hood,
who just want to get their application running. They are better served with some
standard, "safe" black-box, which may be easier to learn, and which allegedly
better protects them from their own mistakes.





What are the advantages over other Lisp systems?



Simplicity


PicoLisp is easy to understand and adapt. There is no compiler enforcing
special rules, and the interpreter is simple and straightforward. There are only
three data types: Numbers, symbols and lists ("LISP" means "List-, Integer- and
Symbol Processing" after all ;-). The memory footprint is minimal, and the
tarball size of the whole system is just a few hundred kilobytes.


A Clear Model


Most other systems define the language, and leave it up to the implementation
to follow the specifications. Therefore, language designers try to be as
abstract and general as possible, leaving many questions and ambiguities to the
users of the language.


PicoLisp does the opposite. Initially, only the single-cell data structure
was defined, and then the structure of numbers, symbols and lists as they are
composed of these cells. Everything else in the whole system follows from these
axioms. This is documented in the chapter about The
PicoLisp Machine in the reference manual.


Orthogonality


There is only one symbolic data type, no distinction (confusion) between
symbols, strings, variables, special variables and identifiers.


Most data-manipulation functions operate on the values of symbols as well as
the CARs of cons pairs:



: (let (N 7  L (7 7 7)) (inc 'N) (inc (cdr L)) (cons N L))
-> (8 7 8 7)




There is only a single functional type, no "special forms". As there is no
compiler, functions can be used instead of macros. No special "syntax"
constructs are needed. This allows a completely orthogonal use of functions. For
example, most other Lisps do not allow calls like



: (mapcar if '(T NIL T NIL) (1 2 3 4) (5 6 7 8))
-> (1 6 3 8)




PicoLisp has no such restrictions. It favors the principle of "Least
Astonishment".


Object System


The OOP system is very powerful, because it is fully dynamic, yet extremely
simple:


    

  • In other systems you have to statically declare "slots". In PicoLisp,
classes and objects are completely dynamic, they are created and extended at
runtime. "Slots" don't even exist at creation time. They spring into existence
purely dynamically. You can add any new property or any new method to any single
object, at any time, regardless of its class.


  • The multiple inheritance is such that not only classes can have several
superclasses, but each individual object can be of more than one class.


  • Prefix classes can surgically change the inheritance tree for any class or
object. They behave like Mixins in this regard.


  • Fine-control of inheritance in methods with super and extra.





Pragmatism


PicoLisp has many practical features not found in other Lisp dialects. Among
them are:


    

  • Auto-quoting of lists when the CAR is a number. Instead of '(1 2
3) you can just write (1 2 3). This is possible because a
number never makes sense as a function name, and has to be checked at runtime
anyway.


  • The quote function returns all
unevaluated arguments, instead of just the first one. This is both faster
(quote does not have to take the CAR of its argument list) and
smaller (a single cell instead of two). For example, 'A expands to
(quote . A) and '(A B C) expands to (quote A B
C).


  • The symbol @ is automatically
maintained as a local variable, and set implicitly in certain flow- and
logic-functions. This makes it often unnecessary to allocate and assign local
variables.


  • Functional I/O is more convenient than
explicitly passing around file descriptors.


  • A well-defined ordinal relationship between
arbitrary data types facilitates generalized comparing and sorting.


  • Uniform handling of var locations (i.e. values of symbols and
CARs of cons pairs).


  • The universality and usefulness of symbol properties is enforced and
extended with implicit and explicit bindings of the symbol This in combination with the access functions
=:, : and ::.


  • A very convenient list-building machinery, using the link, yoke, chain and made functions in the make environment.


  • The syntax of often-used functions is kept non-verbose. For example, instead
of (let ((A 1) (B 2) C 3) ..) you write (let (A 1 B 2 C 3)
..), or just (let A 1 ..) if there is only a single
variable.


  • The use of the hash (#) as a comment character is more appropriate
today, and allows a clean hash-bang (#!) syntax for stand-alone
scripts.


  • The interpreter is invoked with a simple and
flexible syntax, where command line arguments are either files to be interpreted
or functions to be directly executed. With that, many tasks can be performed
without writing a separate script.


  • A sophisticated system of interprocess communication, file locking and
synchronization allows multi-user access to database applications.


  • A Prolog interpreter is tightly integrated into the language. Prolog
clauses can call Lisp expressions and vice versa, and a self-adjusting
depth-first search predicate select can be used in database
queries.





Persistent Symbols


Database objects ("external" symbols) are a primary data type in PicoLisp.
They look like normal symbols to the programmer, but are managed in the database
(fetched from, and stored to) automatically by the system. Symbol manipulation
functions like set, put or get, the
garbage collector, and other parts of the interpreter know about them.


Application Server


It is a stand-alone system (it does not depend on external programs like
Apache or MySQL) and it provides a "live" user interface on the client side,
with an application server session for each connected client. The GUI layout and
behavior are described with S-expressions, generated dynamically at runtime, and
interact directly with the database structures.


Localization


Internal exclusive and full use of UTF-8 encoding, and self-translating transient symbols (strings), make it easy to
write country- and language-independent applications.





How is the performance compared to other Lisp systems?



Despite the fact that PicoLisp is an interpreted-only system, the performance
is quite good. Typical Lisp programs operating on list data structures are
executed in (interpreted) PicoLisp at about the same speed as in (compiled)
CMUCL, and about two or three times faster than in CLisp or Scheme48. Programs
with lots of numeric calculations, however, may be slower on a 32-bit system,
due to PicoLisp's somewhat inefficient implementation of numbers. The 64-bit
version improved on that.


But in practice, speed was never a problem, even with the first versions of
PicoLisp in 1988 on a Mac II with a 12 MHz CPU. And certain things are cleaner
and easier to do in plain C or asm anyway. It is very
easy to write C functions in PicoLisp, either in the kernel, as
shared object libraries, or even inline in the Lisp code.


PicoLisp is very space-effective. Other Lisp systems reserve heap space twice
as much as needed, or use rather large internal structures to store cells and
symbols. Each cell or minimal symbol in PicoLisp consists of only two pointers.
No additional tags are stored, because they are implied in the pointer
encodings. No gaps remain in the heap during allocation, as there are only
objects of a single size. As a result, consing and garbage collection are very
fast, and overall performance benefits from a better cache efficiency. Heap and
stack grow automatically, and are limited only by hardware and operating system
constraints.





What does "interpreted" mean?



It means to directly execute Lisp data as program code. No transformation to
another representation of the code (e.g. compilation), and no structural
modifications of these data, takes place.


Lisp data are the "real" things, like numbers, symbols and lists, which can
be directly handled by the system. They are not the textual
representation of these structures (which is outside the Lisp realm and taken
care of by the reading and printing interfaces).


The following example builds a function and immediately calls it with two
arguments:



: ((list (list 'X 'Y) (list '* 'X 'Y)) 3 4)
-> 12




Note that no time is wasted to build up a lexical environment. Variable
bindings take place dynamically during interpretation.


A PicoLisp function is able to inspect or modify itself while it is running
(though this is rarely done in application programming). The following function
modifies itself by incrementing the '0' in its body:



(de incMe ()
   (do 8
      (printsp 0)
      (inc (cdadr (cdadr incMe))) ) )

: (incMe)
0 1 2 3 4 5 6 7 -> 8
: (incMe)
8 9 10 11 12 13 14 15 -> 16




Only an interpreted Lisp can fully support such "Equivalence of Code and
Data". If executable pieces of data are used frequently, like in PicoLisp's
dynamically generated GUI, a fast interpreter is preferable over any compiler.





Is there (or will be in the future) a compiler available?



No. That would contradict the idea of PicoLisp's simple virtual machine
structure. A compiler transforms it to another (physical) machine, with the
result that many assumptions about the machine's behavior won't hold any more.
Besides that, PicoLisp primitive functions evaluate their arguments
independently and are not suited for being called from compiled code. Finally,
the gain in execution speed would probably not be worth the effort. Typical
PicoLisp applications often use single-pass code which is loaded, executed and
thrown away; a process that would be considerably slowed down by compilation.





Is it portable?



Yes and No. Though we wrote and tested PicoLisp originally only on Linux, it
now also runs on many other POSIX systems. The first versions were even fully
portable between DOS, SCO-Unix and Macintosh systems. But today we have Linux.
Linux itself is very portable, and you can get access to a Linux system almost
everywhere. So why bother?


The GUI is completely platform independent (Browser), and in the age of the
Internet an application server does not really need to be portable.





Is PicoLisp a web server?



Not really, but it evolved a great deal into that direction.


Historically it was the other way round: We had a plain X11 GUI for our
applications, and needed something platform independent. The solution was
obvious: Browsers are installed virtually everywhere. So we developed a protocol
which persuades a browser to function as a GUI front-end to our applications.
This is much simpler than to develop a full-blown web server.





I cannot find the LAMBDA keyword in PicoLisp



Because it isn't there. The reason is that it is redundant; it is equivalent
to the quote function in any aspect, because there's no distinction
between code and data in PicoLisp, and quote returns the whole
(unevaluated) argument list. If you insist on it, you can define your own
lambda:



: (def 'lambda quote)
-> lambda
: ((lambda (X Y) (+ X Y)) 3 4)
-> 7
: (mapcar (lambda (X) (+ 1 X)) (1 2 3 4 5))
-> (2 3 4 5 6)







Why do you use dynamic variable binding?



Dynamic binding is very powerful, because there is only one single,
dynamically changing environment active all the time. This makes it possible
(e.g. for program snippets, interspersed with application data and/or passed
over the network) to access the whole application context, freely, yet in a
dynamically controlled manner. And (shallow) dynamic binding is the fastest
method for a Lisp interpreter.


Lexical binding is more limited by definition, because each environment is
deliberately restricted to the visible (textual) static scope within its
establishing form. Therefore, most Lisps with lexical binding introduce "special
variables" to support dynamic binding as well, and constructs like
labels to extend the scope of variables beyond a single function.


In PicoLisp, function definitions are normal symbol values. They can be
dynamically rebound like other variables. As a useful real-world example, take
this little gem:



(de recur recurse
   (run (cdr recurse)) )




It implements anonymous recursion, by defining recur statically
and recurse dynamically. Usually it is very cumbersome to think up
a name for a function (like the following one) which is used only in a single
place. But with recur and recurse you can simply
write:



: (mapcar
   '((N)
      (recur (N)
         (if (=0 N)
            1
            (* N (recurse (- N 1))) ) ) )
   (1 2 3 4 5 6 7 8) )
-> (1 2 6 24 120 720 5040 40320)




Needless to say, the call to recurse does not have to reside in
the same function as the corresponding recur. Can you implement
anonymous recursion so elegantly with lexical binding?





Are there no problems caused by dynamic binding?



You mean the funarg problem, or problems that arise when a variable
might be bound to itself? For that reason we have a convention in
PicoLisp to use transient symbols (instead
of internal symbols)


    


  1. for all parameters and locals, when functional arguments or executable lists
are passed through the current dynamic bindings


  2. for a parameter or local, when that symbol might possibly be (directly or
indirectly) bound to itself, and the bound symbol's value is accessed in the
dynamic context.





This is a form of lexical scoping - though we still have dynamic
binding - of symbols, similar to the static keyword in
C.


In fact, these problems are a real threat, and may lead to mysterious bugs
(other Lisps have similar problems, e.g. with symbol capture in macros). They
can be avoided, however, when the above conventions are observed. As an example,
consider a function which doubles the value in a variable:



(de double (Var)
   (set Var (* 2 (val Var))) )




This works fine, as long as we call it as (double 'X), but will
break if we call it as (double 'Var). Therefore, the correct
implementation of double should be:



(de double ("Var")
   (set "Var" (* 2 (val "Var"))) )




If double is defined that way in a separate source file, and/or
isolated via the ==== function, then
the symbol Var is locked into a private lexical context
and cannot conflict with other symbols.


Admittedly, there are two disadvantages with this solution:


    


  1. The rules for when to use transient symbols are a bit complicated. Though it
is safe to use them even when not necessary, it will take more space then and be
more difficult to debug.


  2. The string-like syntax of transient symbols as variables may look strange to
alumni of other languages.




Fortunately, these pitfalls do not occur so very often, and seem more likely in
utilities than in production code, so that they can be easily encapsulated.





But with dynamic binding I cannot implement closures!



This is not true. Closures are a matter of scope, not of binding.


For a closure it is necessary to build and maintain a separate environment.
In a system with lexical bindings, this has to be done at each function
call, and for compiled code it is the most efficient strategy anyway, because it
is done once by the compiler, and can then be accessed as stack frames at
runtime.


For an interpreter, however, this is quite an overhead. So it should not be
done automatically at each and every function invocation, but only if needed.


You have several options in PicoLisp. For simple cases, you can take
advantage of the static scope of transient
symbols. For the general case, PicoLisp has built-in functions like bind or job, which dynamically manage statically scoped
environments.


Environments are first-class objects in PicoLisp, more flexible than
hard-coded closures, because they can be created and manipulated independently
from the code.


As an example, consider a currying function:



(de curry Args
   (list (car Args)
      (list 'list
         (lit (cadr Args))
         (list 'cons ''job
            (list 'cons
               (list 'lit (list 'env (lit (car Args))))
               (lit (cddr Args)) ) ) ) ) )




When called, it returns a function-building function which may be applied to
some argument:



: ((curry (X) (N) (* X N)) 3)
-> ((N) (job '((X . 3)) (* X N)))




or used as:



: (((curry (X) (N) (* X N)) 3) 4)
-> 12




In other cases, you are free to choose a shorter and faster solution. If (as
in the example above) the curried argument is known to be immutable:



(de curry Args
   (list
      (cadr Args)
      (list 'fill
         (lit (cons (car Args) (cddr Args)))
         (lit (cadr Args)) ) ) )




Then the function built above will just be:



: ((curry (X) (N) (* X N)) 3)
-> ((X) (* X 3))




In that case, the "environment build-up" is reduced by a simple (lexical)
constant substitution with zero runtime overhead.


Note that the actual curry
function is simpler and more pragmatic. It combines both strategies (to use
job, or to substitute), deciding at runtime what kind of function
to build.





Do you have macros?



Yes, there is a macro mechanism in PicoLisp, to build and immediately execute
a list of expressions. But it is seldom used. Macros are a kludge. Most things
where you need macros in other Lisps are directly expressible as functions in
PicoLisp, which (as opposed to macros) can be applied, passed around, and
debugged.


For example, Common Lisp's DO* macro, written as a function:



(de do* "Args"
   (bind (mapcar car (car "Args"))
      (for "A" (car "Args")
         (set (car "A") (eval (cadr "A"))) )
      (until (eval (caadr "Args"))
         (run (cddr "Args"))
         (for "A" (car "Args")
            (and (cddr "A") (set (car "A") (run @))) ) )
      (run (cdadr "Args")) ) )







Can I run threads?



This is not possible. Threads share memory and other resources (as opposed to
processes, which are better isolated from each other). Each thread has its own
stack for private data, but PicoLisp uses dynamic binding, where the stack holds
the saved values instead of the current values of symbols. As a
result, each running thread would overwrite the symbol bindings of other
threads.


Instead, PicoLisp uses separate processes - and interprocess communication -
for parallel execution, or coroutines as a kind of cooperative threads
running a controlled way and doing all necessary housekeeping.


Another advantage of separate processes over threads: They can be distributed
across multiple machines, and therefore scale better.





Why are there no strings?



Because PicoLisp has something better: Transient symbols. They look and behave like
strings in any respect, but are nevertheless true symbols, with a value and a
property list.


This leads to interesting opportunities. The value, for example, can point to
other data that represent the string's translation. This is used extensively for
localization. When a program calls



   (prinl "Good morning!")




then changing the value of the symbol "Good morning!" to its
translation will change the program's output at runtime.


Transient symbols are also quite memory-conservative. As they are stored in
normal heap cells, no additional overhead for memory management is induced. The
cell holds the symbol's value in its CDR, and the tail in its CAR. If the string
is not longer than 7 bytes, it fits (on the 64-bit version) completely into the
tail, and a single cell suffices. Up to 15 bytes take up two cells, 23 bytes
three etc., so that long strings are not very efficient (needing twice the
memory on the average), but this disadvantage is made up by simplicity and
uniformity. And lots of extremely long strings are not the common case, as they
are split up anyway during processing, and stored as plain byte sequences in
external files and databases.


Because transient symbols are temporarily interned (while loading the current source file), they are
shared within the same source and occupy that space only once, even if they
occur multiple times within the same file.





What about arrays?



PicoLisp has no array or vector data type. Instead, lists must be used for
any type of sequentially arranged data.


We believe that arrays are usually overrated. Textbook wisdom tells that they
have a constant access time O(1) when the index is known. Many other operations
like splits or insertions are rather expensive. Access with a known (numeric)
index is not really typical for Lisp, and even then the advantage of an array is
significant only if it is relatively long. Holding lots of data in long arrays,
however, smells quite like a program design error, and we suspect that often
more structured representations like trees or interconnected objects would be
better.


In practice, most arrays are rather short, or the program can be designed in
such a way that long arrays (or at least an indexed access) are avoided.


Using lists, on the other hand, has advantages. We have so many concerted
functions that uniformly operate on lists. There is no separate data type that
has to be handled by the interpreter, garbage collector, I/O, database and so
on. Lists can be made circular. And lists don't cause memory fragmentation.





How to do floating point arithmetic?



PicoLisp does not support real floating point numbers. You can do all kinds
of floating point calculations by calling existing library functions via
native, inline-C code, and/or by
loading the "@lib/math.l" library.


But PicoLisp has something even (arguably) better: Scaled fixpoint numbers, with unlimited precision.


The reasons for this design decision are manifold. Floating point numbers
smack of imperfection, they don't give "exact" results, have limited precision
and range, and require an extra data type. It is hard to understand what really
goes on (How many digits of precision do we have today? Are perhaps 10-byte
floats used for intermediate results? How does rounding behave?).


For fixpoint support, the system must handle just integer arithmetic, I/O and
string conversions. The rest is under programmer's control and responsibility
(the essence of PicoLisp).


Carefully scaled fixpoint calculations can do anything floating point can do.





What happens when I locally bind a symbol which has a function definition?



That's not a good idea. The next time that function gets executed within the
dynamic context the system may crash. Therefore we have a convention to use an
upper case first letter for locally bound symbols:



(de findCar (Car List)
   (when (member Car (cdr List))
      (list Car (car List)) ) )



;-)





Would it make sense to build PicoLisp in hardware?



At least it should be interesting. It would be a machine executing list
(tree) structures instead of linear instruction sequences. "Instruction
prefetch" would look down the CAR- and CDR-chains, and perhaps need only a
single cache for both data and instructions.


Primitive functions like set, val, if
and while, which are written in C or assembly language
now, would be implemented in microcode. Plus a few I/O functions for hardware
access. EVAL itself would be a microcode subroutine.


Only a single heap and a single stack is needed. They grow towards each
other, and cause garbage collection if they get too close. Heap compaction is
trivial due to the single cell size.


There would be no assembly-language. The lowest level (above the hardware and
microcode levels) are s-expressions: The machine language is Lisp.





I get a segfault if I ...



It is easy to produce a segfault in PicoLisp. Just set a symbol to a value
which is not a function, and call it:



: (setq foo 1)
-> 1
: (foo)
Segmentation fault



There is another example in the Evaluation section of the reference manual.


PicoLisp is a pragmatic language. It doesn't check at runtime for all
possible error conditions which won't occur during normal usage. Such errors are
usually detected quickly at the first test run, and checking for them after that
would just produce runtime overhead.


Catching the segmentation violation and bus fault signals is also not a good
idea, because the Lisp heap is most probably be damaged afterwards, possibly
creating further havoc if execution continues.


It is recommended to inspect the code periodically with lint. It will detect many potential errors.
And, most of these errors are avoided by following the PicoLisp naming conventions.





Where can I ask questions?



The best place is the PicoLisp Mailing
List (see also The Mail
Archive and Gmane.org), or the
IRC #picolisp channel on
FreeNode.net.



picoLisp/doc/tut.html0000644000175000017500000025134313407151763013226 0ustar  abuabu



PicoLisp Tutorial



abu@software-lab.de


A PicoLisp Tutorial



(c) Software Lab. Alexander Burger


About this document



This document demonstrates some aspects of the PicoLisp system in detail and
example. For a general description of the PicoLisp kernel please look at the PicoLisp Reference.


This is not a Lisp tutorial, as it assumes some basic knowledge of
programming, Lisp, and even PicoLisp. Please read these sections before coming
back here: Introduction and The PicoLisp Machine. This tutorial concentrates on the
specificities of PicoLisp, and its differences with other Lisp dialects.


Now let's start



If not stated otherwise, all examples assume that PicoLisp was started from a
global installation (see Installation) from the
shell prompt as



$ pil +
:




It loads the PicoLisp base system and the debugging environment, and waits
for you to enter input lines at the interpreter prompt (:). You can
terminate the interpreter and return to the shell at any time, by either hitting
the Ctrl-D key, or by executing the function (bye).


Please note that special handling is done during character input. This one is
incompatible with rlwrap for example but is more powerful. It
supports vi-style command-line editing (typos fixes and history
with ESC, h, j, k and l, or
the arrow keys if supported by the terminal).


If you prefer to use Emacs, please use the picolisp-mode bundled in the "el/"
directory (that is "@lib/el" for a local installation, or some system dependent
directory for a global installation).


If you feel that you absolutely have to use an IDE, rlwrap or
another input front-end, please create an empty "~/.pil/editor" file. This
effectively disables the command line editor. Note that in this case, however,
you will not have the TAB symbol completion feature available during command
line editing.


Table of content



If you are new to PicoLisp, you might want to read the following sections in
the given order, as some of them assume knowledge about previous ones. Otherwise
just jump anywhere you are interested in.








Command Line Editing



PicoLisp permanently reads input from the current input channel (i.e. the
console in interactive mode), evaluates it, and prints the result to the current
output channel. This is called a "read-eval-print-loop" (REPL).


'vi'-style



This is the default line editor, as it needs less system resources and works
also on dumb terminals. It is similar to - though simpler than - the 'vi' edit
modes of the 'korn' and 'bash' shells. For an analog 'emacs' style editor,
please see below.


It is very helpful - though not absolutely necessary - when you know how to
use the vi text editor.


To alleviate the task of manual line input, a command line editor is provided
which is similar to (though much simpler than) the readline feature
of the bash shell. Only a subset of the vi mode is
supported, which is restricted to single-key commands (the "real"
vi supports multi-key commands and the modification of most
commands with count prefixes). It is loaded at startup in debug mode, you find
its source in "lib/led.l".


You can enter lines in the normal way, correcting mistypes with the BACKSPACE
key, and terminating them with the ENTER key. This is the Insert Mode.


If you hit ESC, you get into Command Mode. Now you can navigate
horizontally in the current input line, or vertically in the history of
previously entered lines, with key commands borrowed from the vi
editor (only h, j, k and l,
or the arrow keys if supported by the terminal). Note, however, that there is
always only a single line visible.


Let's say you did some calculation



: (* (+ 2 3) (- 7 2))
-> 25
:




If you want to repeat a modified version of this command, using
8 instead of 7, you don't have to re-type the
whole command, but type


    

  • ESC to get into Command Mode

  • k to get one line "up"

  • f and 7 to "find" the character 7

  • r and 8 to "replace" with 8




Then you hit ENTER to execute the modified line. Instead of jumping to the
7 with the "find" command, you may also type l (move
"right") repeatedly till you reach the correct position.


The key commands in the Command Mode are listed below. Some commands
change the mode back to Insert Mode as indicated in parentheses. Deleting
or changing a "word" take either the current atom (number or symbol), or a whole
expression when the cursor is at a left parenthesis.


    

  • k - Go up one line

  • j - Go down one line

  • l - Go right one character

  • h - Go left one character

  • w - Go right one word

  • e - Go to next word end

  • b - Go back (left) one word

  • 0 - Go to the beginning of the line

  • $ - Go to the end of the line

  • i - Enter Insert Mode at the cursor position

  • a - Append (Insert Mode) after the cursor position

  • A - Append (Insert Mode) at the end of the line

  • I - Insert (Insert Mode) at the beginning of the line

  • x - Delete the character at the cursor position

  • X - Delete the character left of the cursor position

  • r - Replace the character at the cursor position with the next key

  • s - Substitute the character at the cursor position (Insert Mode)

  • S - Substitute the whole line (Insert Mode)

  • d - Delete the word at the cursor position (Insert Mode)

  • D - Delete the rest of the line

  • c - Change the word at the cursor position (Insert Mode)

  • C - Change the rest of the line (Insert Mode)

  • f - Find next key in the rest of the current line

  • p - Paste data deleted with x, X, d or D after the cursor position

  • P - Paste data deleted with x, X, d or D before the cursor position

  • / - Accept an input pattern and search the history for it

  • n - Search for next occurrence of pattern (as entered with /)

  • N - Search for previous occurrence of pattern

  • % - Go to matching parenthesis

  • ~ - Convert character to opposite (lower or upper) case and move right

  • u - Undo the last change (one level only)

  • U - Undo all changes of the current line

  • g - Display current contents of cut buffer (not in vi)




Notes:

    


  • The d command corresponds to the dw command of the
vi editor, and c corresponds to cw.


  • Search patterns may contain "@" characters as wildcards.


  • Lines shorter than 3 characters, lines beginning with a space character, or
duplicate lines are not entered into the history.


  • The history is stored in the file ".pil/history" in the user's home
directory. The length of the history is limited to 1000 lines.





The following two key-combinations work both in Insert and Command Mode:


    


  • Ctrl-D will immediately terminate the current process.


  • Ctrl-X discards all input, abandons further processing, and
returns to the interpreter's top level (equivalent to invoking quit). This is also useful when the program
stopped at a breakpoint (see single-stepping Debugging), or
after program execution was interrupted with Ctrl-C.





Besides these two keys, in Insert Mode only the following keys have a
special meaning:


    


  • BACKSPACE (Ctrl-H) and DEL erase the character to the left


  • Ctrl-V inserts the next key literally


  • Ctrl-E lets you edit
the history


  • Ctrl-F saves the history


  • TAB performs symbol and/or path completion: When a symbol (or path) name is
entered partially and TAB is pressed subsequently, all internal symbols (and/or
path names in the file system) matching the partial input are shown in sequence.


  • ESC terminates Input Mode and enters Command Mode





'emacs'-style



You can switch the command line editor to an 'emacs' style, if you call the
function (em) (i.e. without arguments). A single call is enough.
Alternatively, you could invoke PicoLisp at least once with the -em
command line option



$ pil -em +
:




The style will be remembered in a file "~/.pil/editor", and used in all
subsequent PicoLisp sessions.


To switch back to 'vi' style, call (vi), use the
-vi command line option, or simply remove "~/.pil/editor".



Conclusion



Please take some time to experiment and to get used to command line editing.
It will make life much easier in the future :-)





Browsing



PicoLisp provides some functionality for inspecting pieces of data and code
within the running system.


Basic tools


The really basic tools are of course available and their name alone is enough
to know:
print,
size
...


But you will appreciate some more powerful tools like:

  • match, a predicate which
    compares S-expressions with bindable wildcards when matching,
    • 




Inspect a symbol with show



The most commonly used tool is probably the show function. It takes a symbolic argument,
and shows the symbol's name (if any), followed by its value, and then the
contents of the property list on the following lines (assignment of such things
to a symbol can be done with set,
setq, and put).



: (setq A '(This is the value))  # Set the value of 'A'
-> (This is the value)
: (put 'A 'key1 'val1)           # Store property 'key1'
-> val1
: (put 'A 'key2 'val2)           # and 'key2'
-> val2
: (show 'A)                      # Now 'show' the symbol 'A'
A (This is the value)
   key2 val2
   key1 val1
-> A




show accepts an arbitrary number of arguments which are
processed according to the rules of get, resulting in a symbol which is showed then.



: (put 'B 'a 'A)        # Put 'A' under the 'a'-property of 'B'
-> A
: (setq Lst '(A B C))   # Create a list with 'B' as second argument
-> (A B C)
: (show Lst 2 'a)       # Show the property 'a of the 2nd element of 'Lst'
A (This is the value)   # (which is 'A' again)
   key2 val2
   key1 val1
-> A




Inspect and edit with edit



Similar to show is edit. It takes an arbitrary number of symbolic
arguments, writes them to a temporary file in a format similar to
show, and starts the vim editor with that file.



: (edit 'A 'B)




The vim window will look like



A (This is the value)
key1 val1
key2 val2

(=======)

B NIL
a A  # (This is the value)

(=======)




Now you can modify values or properties. You should not touch the
parenthesized hyphens, as they serve as delimiters. If you position the cursor
on the first character of a symbol name and type 'K' ("Keyword
lookup"), the editor will be restarted with that symbol added to the editor
window. 'Q' (for "Quit") will bring you back to the previous view.


And, pressing 'Q' at the first (or, top-level) view will return you to the
REPL with any changes you made in your 'edit' session communicated back to the
REPL session.


edit is also very useful to browse in a database. You can follow
the links between objects with 'K', and even - e.g. for low-level
repairs - modify the data (but only if you are really sure about what you are
doing, and don't forget to commit
when you are done).


Built-in pretty print with pp



The pretty-print function pp
takes a symbol that has a function defined (or two symbols that specify message
and class for a method definition), and displays that definition in a formatted
and indented way.



: (pp 'pretty)
(de pretty (X N)
   (setq N (abs (space (or N 0))))
   (while (and (pair X) (== 'quote (car X)))
      (prin "'")
      (pop 'X) )
   (cond
      ...
      (T (prtty0 X N)) ) )
-> pretty




The style is the same as we use in source files:


    


  • The indentation level is three spaces


  • If a list is too long (to be precise: if its size is greater than 12), pretty-print the CAR
on the current line, and each element of the CDR recursively on its own line.


  • A closing parenthesis a preceded by a space if the corresponding open
parenthesis is not on the same line





Inspect elements one by one with more



more is a simple tool that displays
the elements of a list one by one. It stops after each element and waits for
input. If you just hit ENTER, more continues with the next element,
otherwise (usually I type a dot (.) followed by ENTER) it
terminates.



: (more (1 2 3 4 5 6))
1                          # Hit ENTER
2.                         # Hit '.' and ENTER
-> T                       # stopped




Optionally more takes a function as a second argument and
applies that function to each element (instead of the default print). Here, often show or
pp (see below) is used.



: (more '(A B))            # Step through 'A' and 'B'
A
B
-> NIL
: (more '(A B) show)       # Step through 'A' and 'B' with 'show'
A (This is the value)      # showing 'A'
   key2 val2
   key1 val1
                           # Hit ENTER
B NIL                      # showing 'B'
   a A
-> NIL




Search through available symbols with what



The what function returns a list of
all internal symbols in the system which match a given pattern (with
'@' wildcard characters).



: (what "prin@")
-> (prin print prinl print> printsp println)




Search through values or properties of symbols with who



The function who returns "who
contains that", i.e. a list of symbols that contain a given argument
somewhere in their value or property list.



: (who 'print)
-> (query pretty pp msg more "edit" view show (print> . +Date) rules select
(print> . +relation))



A dotted pair indicates either a method definition or a property entry. So
(print> . +relation) denotes the print> method of
the +relation class.


who can be conveniently combined with more and
pp:



: (more (who 'print) pp)
(de query ("Q" "Dbg")  # Pretty-print these functions one by one
   (use "R"
      (loop
         (NIL (prove "Q" "Dbg"))
         (T (=T (setq "R" @)) T)
         (for X "R"
            (space)
            (print (car X))
            (print '=)
            (print (cdr X))
            (flush) )
         (T (line)) ) ) )

(de pretty (X N)
   ...




The argument to who may also be a pattern list (see match):



: (who '(print @ (val @)))
-> (show)

: (more (who '(% @ 7)) pp)
(de day (Dat Lst)
   (when Dat
      (get
         (or Lst *DayFmt)
         (inc (% (inc Dat) 7)) ) ) )

(de _week (Dat)
   (/ (- Dat (% (inc Dat) 7)) 7) )




Find what classes can accept a given message with can



The function can returns a list
which indicates which classes can accept a given message. Again, this
list is suitable for iteration with pp:



: (can 'del>)                                   # Which classes accept 'del>' ?
-> ((del> . +List) (del> . +Entity) (del> . +relation))

: (more (can 'del>) pp)                         # Inspect the methods with 'pp'
(dm (del> . +List) (Obj Old Val)
   (and ((<> Old Val) (delete Val Old)) )

(dm (del> . +Entity) (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> . +relation) (Obj Old Val)
   (and ((<> Old Val) Val) )




Inspect dependencies with dep



dep shows the dependencies in a
class hierarchy. That is, for a given class it displays the tree of its
(super)class(es) above it, and the tree of its subclasses below it.


To view the complete hierarchy of input fields, we start with the root class
+relation:



: (dep '+relation)
+relation
   +Bag
   +Any
   +Blob
   +Link
      +Joint
   +Bool
   +Symbol
      +String
   +Number
      +Time
      +Date
-> +relation




If we are interested in +Link:



: (dep '+Link)
   +relation
+Link
   +Joint
-> +Link




This says that +Link is a subclass of +relation, and has a single subclass
(+Joint).





Defining Functions



Most of the time during programming is spent defining functions (or methods).
In the following we will concentrate on functions, but most will be true for
methods as well except for using dm
instead of de.


Functions with no argument



The notorious "Hello world" function must be defined:



: (de hello ()
   (prinl "Hello world") )
-> hello




The () in the first line indicates a function without arguments.
The body of the function is in the second line, consisting of a single
statement. The last line is the return value of de, which here is
the defined symbol. From now on we will omit the return values of examples when
they are unimportant.


Now you can call this function this way:



: (hello)
Hello world




Functions with one argument



A function with an argument might be defined this way:



: (de hello (X)
   (prinl "Hello " X) )
# hello redefined
-> hello




PicoLisp informs you that you have just redefined the function. This might be
a useful warning in case you forgot that a bound symbol with that name already
existed.



: (hello "world")
Hello world





: (hello "Alex")
Hello Alex




Preventing arguments evaluation and variable number of arguments



Normally, PicoLisp evaluates the arguments before it passes them to a
function:



: (hello (+ 1 2 3))
Hello 6





: (setq A 1  B 2)       # Set 'A' to 1 and 'B' to 2
-> 2
: (de foo (X Y)         # 'foo' returns the list of its arguments
   (list X Y) )
-> foo
: (foo A B)             # Now call 'foo' with 'A' and 'B'
-> (1 2)                # -> We get a list of 1 and 2, the values of 'A' and 'B'




In some cases you don't want that. For some functions (setq for example) it is better if the function
gets all arguments unevaluated, and can decide for itself what to do with them.


For such cases you do not define the function with a list of
parameters, but give it a single atomic parameter instead. PicoLisp will
then bind all (unevaluated) arguments as a list to that parameter.



: (de foo X
   (list (car X) (cadr X)) )        # 'foo' lists the first two arguments

: (foo A B)                         # Now call it again
-> (A B)                            # -> We don't get '(1 2)', but '(A B)'

: (de foo X
   (list (car X) (eval (cadr X))) ) # Now evaluate only the second argument

: (foo A B)
-> (A 2)                            # -> We get '(A 2)'




Mixing evaluated arguments and variable number of unevaluated arguments



As a logical consequence, you can combine these principles. To define a
function with 2 evaluated and an arbitrary number of unevaluated arguments:



: (de foo (X Y . Z)     # Evaluate only the first two args
   (list X Y Z) )

: (foo A B C D E)
-> (1 2 (C D E))        # -> Get the value of 'A' and 'B' and the remaining list




Variable number of evaluated arguments



More common, in fact, is the case where you want to pass an arbitrary number
of evaluated arguments to a function. For that, PicoLisp recognizes the
symbol @ as a single atomic parameter and remembers all evaluated
arguments in an internal frame. This frame can then be accessed sequentially
with the args, next, arg and rest functions.



: (de foo @
   (list (next) (next)) )     # Get the first two arguments

: (foo A B)
-> (1 2)




Again, this can be combined:



: (de foo (X Y . @)
   (list X Y (next) (next)) ) # 'X' and 'Y' are fixed arguments

: (foo A B (+ 3 4) (* 3 4))
-> (1 2 7 12)                 # All arguments are evaluated




These examples are not very useful, because the advantage of a variable
number of arguments is not used. A function that prints all its evaluated
numeric arguments, each on a line followed by its squared value:



: (de foo @
   (while (args)                            # Check if there are some args left
      (println (next) (* (arg) (arg))) ) )  # Call the last arg (next) returned

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
5 25
6 36
1234 1522756
81 6561
-> 6561




This next example shows the behaviour of args and
rest:



: (de foo @
   (while (args)
      (next)
      (println (arg) (args) (rest)) ) )
: (foo 1 2 3)
1 T (2 3)
2 T (3)
3 NIL NIL




Finally, it is possible to pass all these evaluated arguments to another
function, using pass:



: (de foo @
   (pass println 9 8 7)       # First print all arguments preceded by 9, 8, 7
   (pass + 9 8 7) )           # Then add all these values

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
9 8 7 5 6 1234 81             # Printing ...
-> 1350                       # Return the result




Anonymous functions without the lambda keyword


There's no distinction between code and data in PicoLisp,
quote will do what you want (see
also this FAQ entry).



: ((quote (X) (* X X)) 9)
-> 81





: (setq f '((X) (* X X)))  # This is equivalent to (de f (X) (* X X))
-> ((X) (* X X))
: f
-> ((X) (* X X))
: (f 3)
-> 9







Debugging



There are two major ways to debug functions (and methods) at runtime:
Tracing and single-stepping.


In this section we will use the REPL to explore the debugging facilities, but
in the Scripting section, you will learn how to launch
PicoLisp scripts with some selected functions debugged:



$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +




Tracing



Tracing means letting functions of interest print their name and arguments
when they are entered, and their name again and the return value when they are
exited.


For demonstration, let's define the unavoidable factorial function (or just
load the file "@doc/fun.l"):



(de fact (N)
   (if (=0 N)
      1
      (* N (fact (dec N))) ) )




With trace we can put it in trace
mode:



: (trace 'fact)
-> fact




Calling fact now will display its execution trace.



: (fact 3)
 fact : 3
  fact : 2
   fact : 1
    fact : 0
    fact = 1
   fact = 1
  fact = 2
 fact = 6
-> 6




As can be seen here, each level of function call will indent by an additional
space. Upon function entry, the name is separated from the arguments with a
colon (:), and upon function exit with an equals sign
(=) from the return value.


trace works by modifying the function body, so generally it
works only for functions defined as lists (lambda expressions, see Evaluation). Tracing a built-in function (SUBR) is
possible, however, when it is a function that evaluates all its arguments.


So let's trace the functions =0 and
*:



: (trace '=0)
-> =0
: (trace '*)
-> *




If we call fact again, we see the additional output:



: (fact 3)
 fact : 3
  =0 : 3
  =0 = NIL
  fact : 2
   =0 : 2
   =0 = NIL
   fact : 1
    =0 : 1
    =0 = NIL
    fact : 0
     =0 : 0
     =0 = 0
    fact = 1
    * : 1 1
    * = 1
   fact = 1
   * : 2 1
   * = 2
  fact = 2
  * : 3 2
  * = 6
 fact = 6
-> 6




To reset a function to its untraced state, call untrace:



: (untrace 'fact)
-> fact
: (untrace '=0)
-> =0
: (untrace '*)
-> *




or simply use mapc:



: (mapc untrace '(fact =0 *))
-> *




Single-stepping



Single-stepping means to execute a function step by step, giving the
programmer an opportunity to look more closely at what is happening. The
function debug inserts a breakpoint
into each top-level expression of a function. When the function is called, it
stops at each breakpoint, displays the expression it is about to execute next
(this expression is also stored into the global variable ^) and enters a read-eval-loop. The programmer can
then


    


  • inspect the current environment by typing variable names or calling
functions


  • execute (d) to recursively debug the
next expression (looping through subexpressions of this expression)


  • execute (e) to evaluate the next
expression, to see what will happen without actually advancing on


  • type ENTER (that is, enter an empty line) to leave the read-eval loop and
continue with the next expression





Thus, in the simplest case, single-stepping consists of just hitting ENTER
repeatedly to step through the function.


To try it out, let's look at the stamp system function. You may need to have a
look at


    

  • =T (T test),
    • 


  • date and time (grab system date and time)


  • default (conditional
assignments)


  • pack (kind of concatenation), and


  • dat$ and tim$ (date and time formats)
    • 




to understand this definition.



: (pp 'stamp)
(de stamp (Dat Tim)
   (and (=T Dat) (setq Dat (date T)))
   (default Dat (date) Tim (time T))
   (pack (dat$ Dat "-") " " (tim$ Tim T)) )
-> stamp





: (debug 'stamp)                       # Debug it
-> T
: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))     # stopped at first expression
!                                      # ENTER
(default Dat (date) Tim (time T))      # second expression
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # third expression
! Tim                                  # inspect 'Tim' variable
-> 41908
! (time Tim)                           # convert it
-> (11 38 28)
!                                      # ENTER
-> "2004-10-29 11:38:28"               # done, as there are only 3 expressions




Now we execute it again, but this time we want to look at what's happening
inside the second expression.



: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))
!                                      # ENTER
(default Dat (date) Tim (time T))
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # here we want to look closer
! (d)                                  # debug this expression
-> T
!                                      # ENTER
(dat$ Dat "-")                         # stopped at first subexpression
! (e)                                  # evaluate it
-> "2004-10-29"
!                                      # ENTER
(tim$ Tim T)                           # stopped at second subexpression
! (e)                                  # evaluate it
-> "11:40:44"
!                                      # ENTER
-> "2004-10-29 11:40:44"               # done




The breakpoints still remain in the function body. We can see them when we
pretty-print it:



: (pp 'stamp)
(de stamp (Dat Tim)
   (! and (=T Dat) (setq Dat (date T)))
   (! default Dat (date) Tim (time T))
   (! pack
      (! dat$ Dat "-")
      " "
      (! tim$ Tim T) ) )
-> stamp




To reset the function to its normal state, call unbug:



: (unbug 'stamp)




Often, you will not want to single-step a whole function. Just use
edit (see above) to insert a single breakpoint (the exclamation
mark followed by a space) as CAR of an expression, and run your program.
Execution will then stop there as described above; you can inspect the
environment and continue execution with ENTER when you are done.





Functional I/O



Input and output in PicoLisp is functional, in the sense that there are not
variables assigned to file descriptors, which need then to be passed to I/O
functions for reading, writing and closing. Instead, these functions operate on
implicit input and output channels, which are created and maintained as dynamic
environments.


Standard input and standard output are the default channels. Try reading a
single expression:



: (read)
(a b c)        # Console input
-> (a b c)




To read from a file, we redirect the input with in. Note that comments and whitespace are
automatically skipped by read:



: (in "@doc/fun.l" (read))
-> (de fact (N) (if (=0 N) 1 (* N (fact (dec N)))))




The skip function can also be used
directly. To get the first non-white character in the file with char:



: (in "@doc/fun.l" (skip "#") (char))
-> "("




from searches through the input
stream for given patterns. Typically, this is not done with Lisp source files
(there are better ways), but for a simple example let's extract all items
immediately following fact in the file,



: (in "@doc/fun.l" (while (from "fact ") (println (read))))
(N)
(dec N)




or the word following "(de " with till:



: (in "@doc/fun.l" (from "(de ") (till " " T))
-> "fact"




 To read the contents of a whole file (or the rest of it starting from the
current position):



: (in "f.l" (till NIL T))
-> "... file contents ..."





With line, a line of characters is
read, either into a single transient symbol
(the type used by PicoLisp for strings),



: (in "@doc/tut.html" (line T))
-> "<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://..."




or into a list of symbols (characters):



: (in "@doc/tut.html" (line))
-> ("<" "!" "D" "O" "C" "T" "Y" "P" "E" " " "H" "T" "M" "L" ...




line is typically used to read tabular data from a file.
Additional arguments can split the line into fixed-width fields, as described in
the reference manual. If, however, the
data are of variable width, delimited by some special character, the split function can be used to extract the
fields. A typical way to import the contents of such a file is:



(load "@lib/import.l")

(in '("bin/utf2" "importFile.txt")              # Pipe: Convert to UTF-8
   (until (eof)                                 # Process whole file
      (let L (split (line) "^I")                # TAB-delimited data
         ... use 'getStr', 'getNum' etc ...     # process them




Some more examples with echo:



(in "a"                                         # Copy the first 40 Bytes
   (out "b"                                     # from file "a" to file "b"
      (echo 40) ) )

(in "@doc/tut.html"                             # Show the HTTP-header
   (line)
   (echo "<body>") )

(out "file.mac"                                 # Convert to Macintosh
   (in "file.txt"                               # from Unix or DOS format:
      (while (char)
         (prin
            (case @
               ("^M" NIL)                       # ignore CR
               ("^J" "^M")                      # convert LF to CR
               (T @) ) ) ) ) )                  # otherwise no change

(out "c"                                        # Merge the contents of "a"
   (in "b"                                      # and "b" into "c"
      (in "a"
         (while (read)                          # Read an item from "a",
            (println @ (in -1 (read))) ) ) ) )  # print it with an item from "b"







Scripting



There are two possibilities to get the PicoLisp interpreter into doing useful
work: via command line arguments, or as a stand-alone script.


Command line arguments for the PicoLisp interpreter



The command line can specify either files for execution, or arbitrary Lisp
expressions for direct evaluation (see Invocation):
if an argument starts with a hyphen, it is evaluated, otherwise it is loaded as a file. A typical invocation might
look like:



$ pil app/file1.l -main app/file2.l +




It loads the debugging environment, an application source file, calls the
main function, and then loads another application source. In a typical
development and debugging session, this line is often modified using the shell's
history mechanisms, e.g. by inserting debugging statements:



$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +




Another convenience during debugging and testing is to put things into the
command line (shell history) which would otherwise have to be done each time in
the application's user interface:



$ pil app/file1.l -main app/file2.l -go -'login "name" "password"' +




The final production release of an application usually includes a shell
script, which initializes the environment, does some bookkeeping and cleanup,
and calls the application with a proper command line. It is no problem if the
command line is long and complicated.


For small utility programs, however, this is overkill. Enter full PicoLisp
scripts.


PicoLisp scripts


It is better to write
a single executable file using the mechanisms of "interpreter files". If the
first two characters in an executable file are "#!", the operating
system kernel will pass this file to an interpreter program whose pathname is
given in the first line (optionally followed by a single argument). This is fast
and efficient, because the overhead of a subshell is avoided.


Let's assume you installed PicoLisp in the directory "/home/foo/picolisp/",
and put links to the executable and the installation directory as:



$ ln -s /home/foo/picolisp /usr/lib/picolisp
$ ln -s /usr/lib/picolisp/bin/picolisp /usr/bin/picolisp



Then a simple hello-world script might look like:



#!/usr/bin/picolisp /usr/lib/picolisp/lib.l
(prinl "Hello world!")
(bye)




If you write this into a text file, and use chmod to set it to
"executable", it can be executed like any other command. Note that (because
# is the comment character in PicoLisp) the first line will not be
interpreted, and you can still use that file as a normal command line argument
to PicoLisp (useful during debugging).


Grab command line arguments from PicoLisp scripts



The fact that a hyphen causes evaluation of command line arguments can be
used to simulate something like command line options. The following script
defines two functions a and f, and then calls
(load T) to process the rest of the
command line (which otherwise would be ignored because of the (bye) statement):



#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(de a ()
   (println '-a '-> (opt)) )

(de f ()
   (println '-f '-> (opt)) )

(load T)
(bye)



(opt retrieves the next command line
option)


Calling this script (let's say we named it "testOpts") gives:



$ ./testOpts -f abc
-f -> "abc"
$ ./testOpts -a xxx  -f yyy
-a -> "xxx"
-f -> "yyy"




We have to be aware of the fact, however, that the aggregation of arguments
like



$ ./testOpts -axxx  -fyyy




or



$ ./testOpts -af yyy




cannot be achieved with this simple and general mechanism of command line
processing.


Run scripts from arbitrary places on the host file system



Utilities are typically used outside the context of the PicoLisp environment.
All examples above assumed that the current working directory is the PicoLisp
installation directory, which is usually all right for applications developed in
that environment. Command line file arguments like "app/file1.l" will be
properly found.


To allow utilities to run in arbitrary places on the host file system, the
concept of home directory substitution was introduced. The interpreter
remembers internally at start-up the pathname of its first argument (usually
"lib.l"), and substitutes any leading "@" character in subsequent
file names with that pathname. Thus, to run the above example in some other
place, simply write:



$ /home/foo/picolisp/pil @app/file1.l -main @app/file2.l +




that is, supply a full path name to the initial command (here 'pil'), or put
it into your PATH variable, and prefix each file which has to be
loaded from the PicoLisp home directory with a @ character.
"Normal" files (not prefixed by @) will be opened or created
relative to the current working directory as usual.


Stand-alone scripts will often want to load additional modules from the
PicoLisp environment, beyond the "lib.l" we provided in the first line of the
hello-world script. Typically, at least a call to



(load "@lib/misc.l")




(note the home directory substitution) will be included near the beginning of
the script.


As a more complete example, here is a script which extracts the date, name
and size of the latest official PicoLisp release version from the download web
site, and prints it to standard output:



#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(load "@lib/misc.l" "@lib/http.l")

(use (@Date @Name @Size)
   (when
      (match
         '(@Date ~(chop " - <a href=\"") @Name "\"" ">"
             @Name ~(chop "</a> (") @Size )
         (client "software-lab.de" 80 "down.html"
            (from "Release Archive")
            (from "<li>")
            (till ",") ) )
      (prinl @Name)
      (prinl @Date " -- " @Size) ) )

(bye)




Editing scripts



We recommend that you have a terminal window open, and try the examples by
yourself. You may either type them in, directly to the PicoLisp interpreter, or
edit a separate source file (e.g. "@doc/fun.l") in a second
terminal window and load it into PicoLisp with



: (load "@doc/fun.l")




each time you have modified and saved it.


Editing scripts with vi



Once a function is loaded from a source file, you can call 'vim' directly on
that function with



: (vi 'fact)




The function 'vi' opens the appropriate source file, and jumps to the right
line where 'fact' is defined. When you modify it, you can simply call 'ld' to
(re)load that source file



: (ld)






Objects and Classes



The PicoLisp object model is very simple, yet flexible and powerful. Objects
as well as classes are both implemented as symbols. In fact, there is no formal
difference between objects and classes; classes are more a conceptual design
consideration in the head of the programmer than a physical reality.


Having said this, we declare that normally:


    

  1. A Class
   
      
   
    • Has a name (interned symbol)
   
    • Has method definitions and superclass(es) in the value
   
    • May have class variables (attributes) in the property list
   
    

  2. An Object
   
      
   
    • Has no name (anonymous symbol) or is an external symbol
   
    • Has class(es) (and optionally method definitions) in the value
   
    • Has instance variables (attributes) in the property list
   
    




So the main difference between classes and objects is that the former ones
usually are internal symbols. By convention, their names start with a
'+'. Sometimes it makes sense, however, to create named objects (as
global singletons, for example), or even anonymous classes.


Both classes and objects have a list in their value, consisting of method
definitions (often empty for objects) and (super)class(es). And both classes and
objects have local data in their property lists (often empty for classes). This
implies, that any given object (as an instance of a class) may have private
(object-local) methods defined.


It is rather difficult to contrive a simple OOP example. We constructed a
hierarchy of geometric shapes, with a base class +Shape and two
subclasses +Rectangle and +Circle.


The source code is included as "@doc/shape.l" in the PicoLisp distribution, so you
don't have to type it in. Just load
the file, or start it from the shell as:



$ pil @doc/shape.l +




Let's look at it piece by piece. Here's the base class:



(class +Shape)
# x y

(dm T (X Y)
   (=: x X)
   (=: y Y) )

(dm move> (DX DY)
   (inc (:: x) DX)
   (inc (:: y) DY) )




The first line '(class +Shape)' defines the symbol
+Shape as a class without superclasses. The following method
definitions will go to that class.


The comment '# x y' in the second line is just a convention, to
indicate what instance variables (properties) that class uses. As PicoLisp is a
dynamic language, a class can be extended at runtime with any number of
properties, and there is nothing like a fixed object size or structure. This
comment is a hint of what the programmer thinks to be essential and typical for
that class. In the case of +Shape, x and
y are the coordinates of the shape's origin.


Then we have two method definitions, using the keyword dm for "define method". The first method is
special, in that its name is T. Each time a new object is created,
and a method with that name is found in its class hierarchy, that method will be
executed. Though this looks like a "constructor" in other programming languages,
it should probably better be called "initializer". The T method of
+Shape takes two arguments X and Y, and
stores them in the object's property list.


The second method move> changes the object's origin by adding
the offset values DX and DY to the object's origin.


Now to the first derived class:



(class +Rectangle +Shape)
# dx dy

(dm T (X Y DX DY)
   (super X Y)
   (=: dx DX)
   (=: dy DY) )

(dm area> ()
   (* (: dx) (: dy)) )

(dm perimeter> ()
   (* 2 (+ (: dx) (: dy))) )

(dm draw> ()
   (drawRect (: x) (: y) (: dx) (: dy)) )




+Rectangle is defined as a subclass of +Shape.
The comment '# dx dy' indicates that +Rectangle has a
width and a height in addition to the origin coordinates inherited from
+Shape.


The T method passes the origin coordinates X and
Y to the T method of the superclass
(+Shape), then stores the width and height parameters into
dx and dy.


Next we define the methods area> and
perimeter> which do some obvious calculations, and a method
draw> which is supposed to draw the shape on the screen by
calling some hypothetical function drawRect.


Finally, we define a +Circle class in an analog way, postulating
the hypothetical function drawCircle:



(class +Circle +Shape)
# r

(dm T (X Y R)
   (super X Y)
   (=: r R) )

(dm area> ()
   (*/ (: r) (: r) 31415927 10000000) )

(dm perimeter> ()
   (*/ 2 (: r) 31415927 10000000) )

(dm draw> ()
   (drawCircle (: x) (: y) (: r)) )




Now we can experiment with geometrical shapes. We create a rectangle at point
(0,0) with a width of 30 and a height of 20, and keep it in the variable
R:



: (setq R (new '(+Rectangle) 0 0 30 20))  # New rectangle
-> $134432824                             # returned anonymous symbol
: (show R)
$134432824 (+Rectangle)                   # Show the rectangle
   dy 20
   dx 30
   y 0
   x 0




We see that the symbol $134432824 has a list of classes
'(+Rectangle)' in its value, and the coordinates, width and height
in its property list.


Sending messages to that object



: (area> R)                               # Calculate area
-> 600
: (perimeter> R)                          # and perimeter
-> 100




will return the values for area and perimeter, respectively.


Then we move the object's origin:



: (move> R 10 5)                          # Move 10 right and 5 down
-> 5
: (show R)
$134432824 (+Rectangle)
   y 5                                    # Origin changed (0,0) -> (10,5)
   x 10
   dy 20
   dx 30




Though a method move> wasn't defined for the
+Rectangle class, it is inherited from the +Shape
superclass.


Similarly, we create and use a circle object:



: (setq C (new '(+Circle) 10 10 30))      # New circle
-> $134432607                             # returned anonymous symbol
: (show C)
$134432607 (+Circle)                      # Show the circle
   r 30
   y 10
   x 10
-> $134432607
: (area> C)                               # Calculate area
-> 2827
: (perimeter> C)                          # and perimeter
-> 188
: (move> C 10 5)                          # Move 10 right and 5 down
-> 15
: (show C)
$134432607 (+Circle)                      # Origin changed (10,10) -> (20,15)
   y 15
   x 20
   r 30




It is also easy to send messages to objects in a list:



: (mapcar 'area> (list R C))              # Get list of areas
-> (600 2827)
: (mapc
   '((Shape) (move> Shape 10 10))         # Move all 10 right and down
   (list R C) )
-> 25
: (show R)
$134431493 (+Rectangle)
   y 15
   x 20
   dy 20
   dx 30
-> $134431493
: (show C)
$134431523 (+Circle)
   y 25
   x 30
   r 30




Assume that we want to extend our shape system. From time to time, we need
shapes that behave exactly like the ones above, but are tied to a fixed
position. That is, they do not change their position even if they receive a
move> message.


One solution would be to modify the move> method in the
+Shape class to a no-operation. But this would require to duplicate
the whole shape hierarchy (e.g. by defining +FixedShape,
+FixedRectangle and +FixedCircle classes).


The PicoLisp Way is the use of Prefix Classes through multiple
inheritance. It uses the fact that searching for method definitions is a
depth-first, left-to-right search of the class tree. We define a prefix class:



: (class +Fixed)

(dm move> (DX DY))  # A do-nothing method




We can now create a fixed rectangle, and try to move it:



: (setq R (new '(+Fixed +Rectangle) 0 0 30 20))    # '+Fixed' prefix class
-> $134432881
: (move> R 10 5)                                   # Send 'move>' message
-> NIL
: (show R)
$134432881 (+Fixed +Rectangle)
   dy 20
   dx 30
   y 0                                             # Did not move!
   x 0




We see, prefix classes can surgically change the inheritance tree for
selected objects or classes.


Alternatively, if fixed rectangles are needed often, it might make sense to
define a new class +FixRect:



: (class +FixRect +Fixed +Rectangle)
-> +FixRect




and then use it directly:



: (setq R (new '(+FixRect) 0 0 30 20))
-> $13455710







Persistence (External Symbols)



PicoLisp has persistent objects built-in as a first class data type. With
"first class" we mean not just the ability of being passed around, or returned
from functions (that's a matter of course), but that they are a primary data
type with their own interpreter tag bits. They are, in fact, a special type of
symbolic atoms (called "External Symbols"), that
happen to be read from pool file(s) when accessed, and written back
automatically when modified.


In all other aspects they are normal symbols. They have a value, a property
list and a name.


The name cannot be directly controlled by the programmer, as it is assigned
when the symbol is created. It is an encoded index of the symbol's location in
its database file. In its visual representation (output by the print functions and input by the read functions) it is surrounded by braces.


To make use of external symbols, you need to open a database first:



: (pool "test.db")




If a file with that name did not exist, it got created now. Also created at
the same moment was {1}, the very first symbol in the file. This
symbol is of great importance, and is handled especially by PicoLisp. Therefore
a global constant *DB exists, which
points to that symbol {1}, which should be used exclusively to
access the symbol {1}, and which should never be modified by the
programmer.



: *DB                   # The value of '*DB'
-> {1}                  # is '{1}'
: (show *DB)
{1} NIL                 # Value of '{1}' is NIL, property list empty




Now let's put something into the value and property list of {1}.



: (set *DB "Hello world")  # Set value of '{1}' to a transient symbol (string)
-> "Hello world"
: (put *DB 'a 1)           # Property 'a' to 1
-> 1
: (put *DB 'b 2)           # Property 'b' to 2
-> 2
: (show *DB)               # Now show the symbol '{1}'
{1} "Hello world"
   b 2
   a 1




Note that instead of '(set *DB "Hello world")', we might
also have written '(setq {1} "Hello world")', and instead of
'(put *DB 'a 1)' we might have written '(put '{1} 'a
1)'. This would have the same effect, but as a rule external symbols
should never be be accessed literally in application programs, because the
garbage collector might not be able to free these symbols and all symbols
connected to them (and that might well be the whole database). It is all right,
however, to access external symbols literally during interactive debugging.


Now we can create our first own external symbol. This can be done with
new when a T argument is
supplied:



: (new T)
-> {2}               # Got a new symbol




We store it in the database root {1}:



: (put *DB 'newSym '{2})   # Literal '{2}' (ok during debugging)
-> {2}
: (show *DB)
{1} "Hello world"
   newSym {2}              # '{2}' is now stored in '{1}'
   b 2
   a 1




Put some property value into '{2}'



: (put *DB 'newSym 'x 777) # Put 777 as 'x'-property of '{2}'
-> 777
: (show *DB 'newSym)       # Show '{2}' (indirectly)
{2} NIL
   x 777
-> {2}
: (show '{2})              # Show '{2}' (directly)
{2} NIL
   x 777




All modifications to - and creations of - external symbols done so far are
not written to the database yet. We could call rollback (or simply exit PicoLisp) to undo
all the changes. But as we want to keep them:



: (commit)           # Commit all changes
-> T
: (bye)              # Exit picolisp
$                    # back to the shell




So, the next time when ..



$ pil +                 # .. we start PicoLisp
: (pool "test.db")      # and open the database file,
-> T
: (show *DB)            # our two symbols are there again
{1} "Hello world"
   newSym {2}
   b 2
   a 1
-> {1}
: (show *DB 'newSym)
{2} NIL
   x 777
-> {2}







Database Programming



To a database, there is more than just persistence. PicoLisp includes an
entity/relation class framework (see also Database)
which allows a close mapping of the application data structure to the database.


We provided a simple yet complete database and GUI demo application in
@doc/family.tgz and @doc/family64.tgz. Please unpack the first one if
you use a 32-bit system, and the second one on a 64-bit system. Both contain the
sources in @doc/family.l, and an initial
database in the "family/" subdirectory.


To use it, please unpack it first in your current working directory, then
start it up in the following way:



$ pil family.l -main +
:




This loads the source file, initializes the database by calling the
main function, and prompts for user input.


The data model is small and simple. We define a class +Person
and two subclasses +Man and +Woman.



(class +Person +Entity)




+Person is a subclass of the +Entity system class. Usually all objects in
a database are of a direct or indirect subclass of +Entity. We can then define the relations to
other data with the rel function.



(rel nm (+Need +Sn +Idx +String))      # Name




This defines the name property (nm) of a person. The second
argument to rel is always a list of relation classes (subclasses of
+relation), optionally followed
by further arguments, causing relation daemon objects to be created and stored
in the class definition. These daemon objects control the entity's behavior
later at runtime.


Relation daemons are a kind of metadata, controlling the interactions
between entities, and maintaining database integrity. Like other classes,
relation classes can be extended and refined, and in combination with proper
prefix classes a fine-grained description of the application's structure can be
produced.


Besides primitive relation classes, like +Number,
+String or +Date, there are


    


  • relations between entities, like +Link (unidirectional link),
+Joint (bidirectional link) or +Hook (object-local
index trees)


  • relations that bundle other relations into a single unit (+Bag)


  • a +List prefix class


  • a +Blob class for "binary large objects"


  • prefix classes that maintain index trees, like +Key (unique
index), +Ref (non-unique index) or +Idx (full text
index)


  • prefix classes which in turn modify index class behavior, like
+Sn (modified soundex algorithm [knuth73]
for tolerant searches)


  • a +Need prefix class, for existence checks


  • a +Dep prefix class controlling dependencies between other
relations





In the case of the person's name (nm) above, the relation object
is of type (+Need +Sn +Idx +String). Thus, the name of each person
in this demo database is a mandatory attribute (+Need), searchable
with the soundex algorithm (+Sn) and a full index
(+Idx) of type +String.



(rel pa (+Joint) kids (+Man))          # Father
(rel ma (+Joint) kids (+Woman))        # Mother
(rel mate (+Joint) mate (+Person))     # Partner




The attributes for father (pa), Mother
(ma) and partner (mate) are all defined as
+Joints. A +Joint is probably the most powerful
relation mechanism in PicoLisp; it establishes a bidirectional link between two
objects.


The above declarations say that the father (pa) attribute
points to an object of type +Man, and is joined with that object's
kids attribute (which is a list of joints back to all his
children).


The consistency of +Joints is maintained automatically by the
relation daemons. These become active whenever a value is stored to a person's
pa, ma, mate or kids
property.


For example, interesting things happen when a person's mate is
changed to a new value. Then the mate property of the old mate's
object is cleared (she has no mate after that). Now when the person pointed to
by the new value already has a mate, then that mate's mate property
gets cleared, and the happy new two mates now get their joints both set
correctly.


The programmer doesn't have to care about all that. He just declares these
relations as +Joints.


The last four attributes of person objects are just static data:



(rel job (+Ref +String))               # Occupation
(rel dat (+Ref +Date))                 # Date of birth
(rel fin (+Ref +Date))                 # Date of death
(rel txt (+String))                    # Info




They are all searchable via a non-unique index (+Ref). Date
values in PicoLisp are just numbers, representing the day number (starting first
of March of the year zero).


A method url> is defined:



(dm url> ()
   (list "!person" '*ID This) )




It is needed later in the GUI, to cause a click on a link to switch to that
object.


The classes +Man and +Woman are subclasses of
+Person:



(class +Man +Person)
(rel kids (+List +Joint) pa (+Person)) # Children

(class +Woman +Person)
(rel kids (+List +Joint) ma (+Person)) # Children




They inherit everything from +Person, except for the
kids attribute. This attribute joins with the pa or
ma attribute of the child, depending on the parent's gender.


That's the whole data model for our demo database application.


It is followed by a call to dbs
("database sizes"). This call is optional. If it is not present, the whole
database will reside in a single file, with a block size of 256 bytes. If it is
given, it should specify a list of items, each having a number in its CAR, and a
list in its CDR. The CARs taken together will be passed later to pool, causing an individual database file with that
size to be created. The CDRs tell what entity classes (if an item is a symbol)
or index trees (if an item is a list with a class in its CAR and a list of
relations in its CDR) should be placed into that file.



A handful of access functions is provided, that know about database
relationships and thus allows higher-level access modes to the external symbols
in a database.


For one thing, the B-Trees created and maintained by the index daemons can be
used directly. Though this is rarely done in a typical application, they form
the base mechanisms of other access modes and should be understood first.


The function tree returns the tree
structure for a given relation. To iterate over the whole tree, the functions
iter and scan can be used:



(iter (tree 'dat '+Person) '((P) (println (datStr (get P 'dat)) (get P 'nm))))
"1770-08-03" "Friedrich Wilhelm III"
"1776-03-10" "Luise Augusta of Mecklenburg-Strelitz"
"1797-03-22" "Wilhelm I"
...




They take a function as the first argument. It will be applied to all objects
found in the tree (to show only a part of the tree, an optional begin- and
end-value can be supplied), producing a simple kind of report.


More useful is collect; it
returns a list of all objects that fall into a range of index values:



: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31))
-> ({2-M} {2-L} {2-E})




This returns all persons born between 1982 and 1988. Let's look at them with
show:



: (more (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31)) show)
{2-M} (+Man)
   nm "William"
   dat 724023
   ma {2-K}
   pa {2-J}
   job "Heir to the throne"

{2-L} (+Man)
   nm "Henry"
   dat 724840
   ma {2-K}
   pa {2-J}
   job "Prince"

{2-E} (+Woman)
   nm "Beatrice"
   dat 726263
   ma {2-D}
   job "Princess"
   pa {2-B}




If you are only interested in a certain attribute, e.g. the name, you can
return it directly:



: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31) 'nm)
-> ("William" "Henry" "Beatrice")




To find a single object in the database, the function db is used:



: (db 'nm '+Person "Edward")
-> {2-;}




If the key is not unique, additional arguments may be supplied:



: (db 'nm '+Person "Edward"  'job "Prince"  'dat (date 1964 3 10))
-> {2-;}




The programmer must know which combination of keys will suffice to specify
the object uniquely. The tree search is performed using the first value
("Edward"), while all other attributes are used for filtering. Later, in
the Pilog section, we will show how more general (and
possibly more efficient) searches can be performed.





User Interface (GUI) Programming



The only types of GUI supported by the PicoLisp application server framework
is either dynamically generated (but static by nature) HTML, or an interactive
XHTML/CSS framework with the optional use of JavaScript.


Before we explain the GUI of our demo database application, we present a
minimal example for a plain HTML-GUI in @doc/hello.l. Start the application server as:



$ pil @lib/http.l  --server 8080 @doc/hello.l  -wait




Now point your browser to the address 'http://localhost:8080'. You should see a
very simple HTML page. You can come back here with the browser's BACK button.


You can call the page repeatedly, or concurrently with many clients if you
like. To terminate the server, you have to send it a TERM signal (e.g.
'killall pil'), or type the Ctrl-C key in the console
window.


In our demo database application, a single function person is
responsible for the whole GUI. Again, please look at @doc/family.l.


To start the database and the application server, call:



$ pil family.l -main -go +




As before, the database is opened with main. The function
go is also defined in @doc/family.l:



(de go ()
   (server 8080 "!person") )




It starts the HTTP server listening on TCP port 8080 (we did a similar thing
in our minimal GUI example above directly on the command line). Each connect to
that port will cause the function person to be invoked.


Again, point your browser to the address 'http://localhost:8080'.


You should see a new browser window with an input form created by the
function person. We provided an initial database in "family/[1-4]".
You can navigate through it by clicking on the pencil icons besides the input
fields.


The chart with the children data can be scrolled using the down
(v) and up (^) buttons.


A click on the button "Select" below opens a search dialog. You can scroll
through the chart as before. Again, a click on a pencil will jump to that
person. You can abort the dialog with a click on the "Cancel"-button.


The search fields in the upper part of the dialog allow a conjunctive search.
If you enter "Edward" in the "Name" field and click "Search", you'll see all
persons having the string "Edward" in their name. If you also enter "Duke" in
the "Occupation" field, the result list will reduce to only two entries.


To create a new person, press the "New Man" or "New Woman" button. A new
empty form will be displayed. Please type a name into the first field, and
perhaps also an occupation and birth date. Any change of contents should be
followed by a press on the "Done" button, though any other button (also Scroll
or Select-buttons) will also do.


To assign a father attribute, you can either type a name directly into
the field (if that person already exists in the database and you know the exact
spelling), or use the "Set"-button (->) to the left of that
field to open the search dialog. If you type in the name directly, your input
must exactly match upper and lower case.


Alternatively, you may create a new person and assign a child in the
"Children" chart.


On the console where you started PicoLisp, there should a prompt have
appeared just when the browser connected. You can debug the application
interactively while it is running. For example, the global variable
*Top always contains the top level GUI object:



: (show *Top)




To take a look at the first field on the form:



: (show *Top 'gui 1)




A production application would be started in a slightly different way:



$ pil family.l -main -go -wait




In that case, no debug prompt will appear. In both cases, however, two
pil processes will be running now. One is the initial server
process which will continue to run until it is killed. The other is a child
process holding the state of the GUI in the browser. It will terminate some time
after the browser is closed, or when (bye) or a Ctrl-D is entered at the
PicoLisp prompt.


Now back to the explanation of the GUI function person:



(de person ()
   (app)
   (action
      (html 0 (get (default *ID (val *DB)) 'nm) "@lib.css" NIL
         (form NIL
            (<h2> (<id> (: nm)))




For an in-depth explanation of that startup code, please refer to the guide
to PicoLisp Application Development.


All components like fields and buttons are controlled by form.
The function gui creates a single GUI component and takes the type
(a list of classes) and a variable number of arguments depending on the needs of
these classes.



   (gui '(+E/R +TextField) '(nm : home obj) 40 "Name")




This creates a +TextField with the label "Name" and a length of
40 characters. The +E/R (: Entity/Relation) prefix class connects
that field to a database object, the nm attribute of a person in
this case, so that the person's name is displayed in that text field, and any
changes entered into that field are propagated to the database automatically.



   (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman)))




A +ClassField displays and changes the class of an object, in
this case the person's sex from +Man to +Woman and
vice versa.


As you see, there is no place where explicit accesses to the database have to
be programmed, no select or update. This is all
encapsulated in the GUI components, mainly in the +E/R prefix
class. The above function person is fully functional as we present
it and allows creation, modification and deletion of person objects in the
database.


The two buttons on the bottom right generate simple reports:


The first one shows all contemporaries of the person that is currently
displayed, i.e. all persons who did not die before, or were not born after that
person. This is a typical PicoLisp report, in that in addition to the report's
HTML page, a temporary file may be generated, suitable for download (and import
into a spread sheet), and from which a PDF can be produced for print-out.


In PicoLisp, there is not a real difference between a plain HTML-GUI and a
report. Again, the function html is used to generate the page.


The second report is much simpler. It produces a recursive structure of the
family.


In both reports, links to the person objects are created which allow easy
navigation through the database.





Pilog -- PicoLisp Prolog



This sections explains some cases of using Pilog in typical application
programming, in combination with persistent objects and databases. Please refer
to the Pilog section of the PicoLisp Reference for
the basic usage of Pilog.


Again, we use our demo application @doc/family.l that was introduced in the Database Programming section.


Normally, Pilog is used either interactively to query the database during
debugging, or in applications to generate export data and reports. In the
following examples we use the interactive query front-end functions ? and select. An application will use goal and prove directly, or use convenience functions
like pilog or solve.


All Pilog access to external symbols is done via the two predicates db/3 and select/3.


    


  • db/3 corresponds to the Lisp-level
functions db and collect, as it derives its data from a
single relation. It can be used for simple database queries.


  • select/3 provides for
self-optimizing parallel access to an arbitrary number of relations. There is
also a Lisp front-end function select, for convenient calls to the Pilog
select predicate.





A predicate show/1 is pre-defined
for debugging purposes (a simple glue to the Lisp-level function
show, see Browsing). Searching with db/3 for all persons having the string "Edward"
in their name:



: (? (db nm +Person "Edward" @P) (show @P))
{2-;} (+Man)
   nm "Edward"
   ma {2-:}
   pa {2-A}
   dat 717346
   job "Prince"
 @P={2-;}
{2-1B} (+Man)
   nm "Albert Edward"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   job "Prince"
   mate {2-f}
   fin 680370
   dat 664554
 @P={2-1B}
...               # more results




To search for all persons with "Edward" in their name who are married to
somebody with occupation "Queen":



: (? (db nm +Person "Edward" @P) (val "Queen" @P mate job) (show @P))
{2-1B} (+Man)
   mate {2-f}
   nm "Albert Edward"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   job "Prince"
   fin 680370
   dat 664554
 @P={2-1B}
-> NIL            # only one result




If you are interested in the names of "Albert Edward"'s children:



: (? (db nm +Person "Albert Edward" @P) (lst @K @P kids) (val @Kid @K nm))
 @P={2-1B} @K={2-1C} @Kid="Beatrice Mary Victoria"
 @P={2-1B} @K={2-1D} @Kid="Leopold George Duncan"
 @P={2-1B} @K={2-1E} @Kid="Arthur William Patrick"
 @P={2-1B} @K={2-1F} @Kid="Louise Caroline Alberta"
 @P={2-1B} @K={2-1G} @Kid="Helena Augusta Victoria"
 @P={2-1B} @K={2-1H} @Kid="Alfred Ernest Albert"
 @P={2-1B} @K={2-1I} @Kid="Alice Maud Mary"
 @P={2-1B} @K={2-g} @Kid="Victoria Adelaide Mary"
 @P={2-1B} @K={2-a} @Kid="Edward VII"
-> NIL




db/3 can do a direct index access
only for a single attribute (nm of +Person above). To
search for several criteria at the same time, select/3 has to be used:



: (?
   (select (@P)
      ((nm +Person "Edward") (nm +Person "Augusta" pa))  # Generator clauses
      (tolr "Edward" @P nm)                              # Filter clauses
      (tolr "Augusta" @P kids nm) )
   (show @P) )
{2-1B} (+Man)
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   mate {2-f}
   nm "Albert Edward"
   job "Prince"
   fin 680370
   dat 664554
 @P={2-1B}
-> NIL




select/3 takes a list of
generator clauses which are used to retrieve objects from the database, and a
number of normal Pilog filter clauses. In the example above the generators are


    


  • (nm +Person "Edward") to generate persons with "Edward" in
their names, and


  • (nm +Person "Augusta" pa) to find persons with "Augusta"
in their names and generate persons using the pa ("father")
attribute.





All persons generated are possible candidates for our selection. The
nm index tree of +Person is traversed twice in
parallel, optimizing the search in such a way that successful hits get higher
priority in the search, depending on the filter clauses. The process will stop
as soon as any one of the generators is exhausted. Note that this is different
from the standard Prolog search algorithm.


The filter clauses in this example both use the pre-defined predicate
tolr/3 for tolerant string
matches (according either to the soundex algorithm (see the section Database Programming) or to substring matches), and filter
objects that


    


  • match "Edward" in their name: (tolr "Edward" @P nm), and


  • match "Augusta" in one of their kids' names: (tolr "Augusta" @P
kids nm)





A more typical and extensive example for the usage of select can
be found in the qPerson function in @doc/family.l. It is used in the search dialog of the
demo application, and searches for a person with the name, the parents' and
partner's names, the occupation and a time range for the birth date. The
relevant index trees in the database are searched (actually only those trees
where the user entered a search key in the corresponding dialog field), and a
logical AND of the search attributes is applied to the result.


For example, press the "Select" button, enter "Elizabeth" into the "Mother"
search field and "Phil" in the "Partner" search field, meaning to look for all
persons whose mother's name is like "Elizabeth" and whose partner's name is like
"Phil". As a result, two persons ("Elizabeth II" and "Anne") will show up.


In principle, db/3 can be seen as a
special case of select/3. The
following two queries are equivalent:



: (? (db nm +Person "Edward" @P))
 @P={2-;}
 @P={2-1B}
 @P={2-R}
 @P={2-1K}
 @P={2-a}
 @P={2-T}
-> NIL
: (? (select (@P) ((nm +Person "Edward"))))
 @P={2-;}
 @P={2-1B}
 @P={2-R}
 @P={2-1K}
 @P={2-a}
 @P={2-T}
-> NIL







Poor Man's SQL



select



For convenience, a select Lisp
glue function is provided as a front-end to the select predicate.
Note that this function does not evaluate its arguments (it is intended for
interactive use), and that it supports only a subset of the predicate's
functionality. The syntax resembles SELECT in the SQL language, for example:



# SELECT * FROM Person
: (select +Person)  # Step through the whole database
{2-o} (+Man)
   nm "Adalbert Ferdinand Berengar Viktor of Prussia"
   dat 688253
   ma {2-j}
   pa {2-h}
   fin 711698

{2-1B} (+Man)
   nm "Albert Edward"
   dat 664554
   job "Prince"
   mate {2-f}
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   fin 680370
...





# SELECT * FROM Person WHERE nm LIKE "%Edward%"
: (select +Person nm "Edward")  # Show all Edwards
{2-;} (+Man)
   nm "Edward"
   dat 717346
   job "Prince"
   ma {2-:}
   pa {2-A}

{2-1B} (+Man)
   nm "Albert Edward"
   dat 664554
   job "Prince"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   mate {2-f}
   fin 680370
...





# SELECT nm, dat FROM Person WHERE nm LIKE "%Edward%"
: (select nm dat +Person nm "Edward")
"Edward" "1964-03-10" {2-;}
"Albert Edward" "1819-08-26" {2-1B}
"George Edward" NIL {2-R}
"Edward Augustus Hanover" NIL {2-1K}
...





# SELECT dat, fin, p1.nm, p2.nm
#    FROM Person p1, Person p2
#    WHERE p1.nm LIKE "%Edward%"
#    AND p1.job LIKE "King%"
#    AND p1.mate = p2.mate  -- Actually, in a SQL model we'd need
#                           -- another table here for the join
: (select dat fin nm (mate nm) +Person nm "Edward" job "King")
"1894-06-23" "1972-05-28" "Edward VIII" "Wallace Simpson" {2-T}
"1841-11-09" NIL "Edward VII" "Alexandra of Denmark" {2-a}
-> NIL





update



In addition (just to stay with the SQL terminology ;-), there is also an
update function. It is a front-end
to the set!> and put!> transaction methods, and
should be used when single objects in the database have to be modified by hand.


In principle, it would also be possible to use the edit function to modify a database object. This
is not recommended, however, because edit does not know about
relations to other objects (like Links, Joints and index trees) and may easily
cause database corruption.


In the most general case, the value of a property in a database object is
changed with the put!> method. Let's look at "Edward" from the
previous examples:



: (show '{2-;})
{2R} (+Man)
   job "Prince"
   nm "Edward"
   dat 717346
   ma {2-:}
   pa {20A}
-> {2-;}




We might change the name to "Johnny" with put!>:



: (put!> '{2-;} 'nm "Johnny")
-> "Johnny"




However, an easier and less error-prone prone way - especially when more than
one property has to be changed - is using update. It presents the value (the list of
classes) and then each property on its own line, allowing the user to change it
with the command line editor.


Just hitting ENTER will leave that property unchanged. To modify it, you'll
typically hit ESC to get into command mode, and move the cursor to the point of
change.


For properties with nested list structures (+List +Bag),
update will recurse into the data structure.



: (update '{2-;})
{2-;} (+Man)      # ENTER
nm "Johnny"       # Modified the name to "Johnny"
ma {2-:}          # ENTER
pa {2-A}          # ENTER
dat 1960-03-10    # Modified the year from "1964" to "1960"
job "Prince"      # ENTER
-> {2-;}




All changes are committed immediately, observing the rules of database
synchronization so that any another user looking at the same object will have
his GUI updated correctly.


To abort update, hit Ctrl-X.


If only a single property has to be changed, update can be
called directly for that property:



: (update '{2-;} 'nm)
{2-;} nm "Edward"
...







References



[knuth73] Donald E. Knuth: ``The Art of Computer
Programming'', Vol.3, Addison-Wesley, 1973, p. 392



picoLisp/doc/app.html0000600000175000017500000031471713407156103013160 0ustar  abuabu



PicoLisp Application Development



    abu@software-lab.de

mattias@inogu.se


PicoLisp Application Development



(c) Software Lab. Alexander Burger, Mattias Sundblad


This document presents an introduction to writing browser-based applications
in PicoLisp.


It concentrates on the XHTML/CSS GUI-Framework (as opposed to the previous
Java-AWT, Java-Swing and Plain-HTML frameworks), which is easier to use, more
flexible in layout design, and does not depend on plug-ins, JavaScript, cookies
or CSS.


A plain HTTP/HTML GUI has various advantages: It runs on any browser, and can
be fully driven by scripts ("@lib/scrape.l").


To be precise: CSS can be used to enhance the layout. And browsers
with JavaScript will respond faster and smoother. But this framework
works just fine in browsers which do not know anything about CSS or JavaScript.
All examples were also tested using the w3m text browser.


For basic informations about the PicoLisp system please look at the PicoLisp Reference and the PicoLisp
Tutorial. Knowledge of HTML, and a bit of CSS and HTTP is assumed.


The examples assume that PicoLisp was started from a global installation (see
Installation).








Static Pages



You can use PicoLisp to generate static HTML pages. This does not make much
sense in itself, because you could directly write HTML code as well, but it
forms the base for interactive applications, and allows us to introduce the
application server and other fundamental concepts.




Hello World



To begin with a minimal application, please enter the following two lines
into a generic source file named "project.l" in the PicoLisp installation
directory.



########################################################################
(html 0 "Hello" "@lib.css" NIL
   "Hello World!" )
########################################################################




(We will modify and use this file in all following examples and experiments.
Whenever you find such a program snippet between hash ('#') lines, just copy and
paste it into your "project.l" file, and press the "reload" button of your
browser to view the effects)



Start the application server



Open a second terminal window, and start a PicoLisp application server



$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  +




No prompt appears. The server just sits, and waits for connections. You can
stop it later by hitting Ctrl-C in that terminal, or by executing
'killall pil' in some other window.


(In the following, we assume that this HTTP server is up and running)


Now open the URL 'http://localhost:8080' with your
browser. You should see an empty page with a single line of text.



How does it work?



The above line loads the debugger (via the '+' switch), the HTTP server code
("@lib/http.l"), the XHTML functions ("@lib/xhtml.l") and the input form
framework ("@lib/form.l", it will be needed later for interactive forms).


Then the -server function is called (a front-end to
server) with a port number and a default URL. It will listen on
that port for incoming HTTP requests in an endless loop. Whenever a GET request
arrives on port 8080, the file "project.l" will be (load)ed, causing the evaluation (= execution)
of all its Lisp expressions.


During that execution, all data written to the current output channel is sent
directly to the browser. The code in "project.l" is responsible to produce HTML
(or anything else the browser can understand).





URL Syntax



The PicoLisp application server uses a slightly specialized syntax when
communicating URLs to and from a client. The "path" part of an URL - which
remains when


    

  • the preceding protocol, host and port specifications,

  • and the trailing question mark plus arguments



are stripped off - is interpreted according so some rules. The most prominent
ones are:


    

  • If a path starts with an exclamation-mark ('!'), the rest (without the '!')
is taken as the name of a Lisp function to be called. All arguments following
the question mark are passed to that function.


  • If a path ends with ".l" (a dot and a lower case 'L'), it is taken as a Lisp
source file name to be (load)ed. This
is the most common case, and we use it in our example "project.l".


  • If the extension of a file name matches an entry in the global mime type
table *Mimes, the file is sent to the client with mime-type and
max-age values taken from that table.


  • Otherwise, the file is sent to the client with a mime-type of
"application/octet-stream" and a max-age of 1 second.





An application is free to extend or modify the *Mimes table with
the mime function. For example



(mime "doc" "application/msword" 60)




defines a new mime type with a max-age of one minute.


Argument values in URLs, following the path and the question mark, are
encoded in such a way that Lisp data types are preserved:


    

  • An internal symbol starts with a dollar sign ('$')

  • A number starts with a plus sign ('+')

  • An external (database) symbol starts with dash ('-')

  • A list (one level only) is encoded with underscores ('_')

  • Otherwise, it is a transient symbol (a plain string)





In that way, high-level data types can be directly passed to functions
encoded in the URL, or assigned to global variables before a file is loaded.





Security



It is, of course, a huge security hole that - directly from the URL - any
Lisp source file can be loaded, and any Lisp function can be called. For that
reason, applications must take care to declare exactly which files and functions
are to be allowed in URLs. The server checks a global variable *Allow, and - when its value is
non-NIL - denies access to anything that does not match its
contents.


Normally, *Allow is not manipulated directly, but set with the
allowed and allow functions



(allowed ("app/")
   "!start" "!stop" "@lib.css" "!psh" )




This is usually called at the beginning of an application, and allows access
to the directory "app/", to the functions 'start', 'stop' and 'psh', and to the
file "@lib.css".


Later in the program, *Allow may be dynamically extended with
allow



(allow "!foo")
(allow "newdir/" T)




This adds the function 'foo', and the directory "newdir/", to the set of
allowed items.



The ".pw" File



For a variety of security checks (most notably for using the psh
function, as in some later examples) it is necessary to create a file named
".pw" in the PicoLisp installation directory. This file should contain a single
line of arbitrary data, to be used as a password for identifying local
resources.


The recommeded way to create this file is to call the pw
function, defined in "@lib/http.l"



$ pil @lib/http.l -'pw 12' -bye




Please execute this command.





The html Function



Now back to our "Hello World" example. In principle, you could write
"project.l" as a sequence of print statements



########################################################################
(prinl "HTTP/1.0 200 OK^M")
(prinl "Content-Type: text/html; charset=utf-8")
(prinl "^M")
(prinl "<html>")
(prinl "Hello World!")
(prinl "</html>")
########################################################################




but using the html function is much more convenient.


Moreover, html is nothing more than a printing function.
You can see this easily if you connect a PicoLisp Shell (psh) to
the server process (you must have generated a ".pw" file for
this), and enter the html statement



$ /usr/lib/picolisp/bin/psh 8080
: (html 0 "Hello" "@lib.css" NIL "Hello World!")
HTTP/1.0 200 OK
Server: PicoLisp
Date: Fri, 29 Dec 2006 07:28:58 GMT
Cache-Control: max-age=0
Cache-Control: no-cache
Content-Type: text/html; charset=utf-8

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>Hello</title>
<base href="http://localhost:8080/"/>
<link rel="stylesheet" type="text/css" href="http://localhost:8080/@lib.css"/>
</head>
<body>Hello World!</body>
</html>
-> </html>
:  # (type Ctrl-D here to terminate PicoLisp)




These are the arguments to html:


    


  1. 0: A max-age value for cache-control (in seconds, zero means
"no-cache"). You might pass a higher value for pages that change seldom, or
NIL for no cache-control at all.


  2. "Hello": The page title.


  3. "@lib.css": A CSS-File name. Pass NIL if you do
not want to use any CSS-File, or a list of file names if you want to give more
than one CSS-File.


  4. NIL: A CSS style attribute specification (see the description
of CSS Attributes below). It will be passed to the
body tag.





After these four arguments, an arbitrary number of expressions may follow.
They form the body of the resulting page, and are evaluated according to a
special rule. This rule is slightly different from the
evaluation of normal Lisp expressions:


    


  • If an argument is an atom (a number or a symbol (string)), its value is
printed immediately.


  • Otherwise (a list), it is evaluated as a Lisp function (typically some form
of print statement).





Therefore, our source file might as well be written as:



########################################################################
(html 0 "Hello" "@lib.css" NIL
   (prinl "Hello World!") )
########################################################################




The most typical print statements will be some HTML-tags:



########################################################################
(html 0 "Hello" "@lib.css" NIL
   (<h1> NIL "Hello World!")
   (<br> "This is some text.")
   (ht:Prin "And this is a number: " (+ 1 2 3)) )
########################################################################




<h1> and <br> are tag functions.
<h1> takes a CSS attribute as its first argument.


Note the use of ht:Prin instead of prin.
ht:Prin should be used for all direct printing in HTML pages,
because it takes care to escape special characters.





CSS Attributes



The html function above, and many of the
HTML tag functions, accept a CSS attribute specification.
This may be either an atom, a cons pair, or a list of cons pairs. We demonstrate
the effects with the <h1> tag function.


An atom (usually a symbol or a string) is taken as a CSS class name



: (<h1> 'foo "Title")
<h1 class="foo">Title</h1>




For a cons pair, the CAR is taken as an attribute name, and the CDR as the
attribute's value



: (<h1> '(id . bar) "Title")
<h1 id="bar">Title</h1>




Consequently, a list of cons pairs gives a set of attribute-value pairs



: (<h1> '((id . "abc") (lang . "de")) "Title")
<h1 id="abc" lang="de">Title</h1>







Tag Functions



All pre-defined XHTML tag functions can be found in "@lib/xhtml.l". We
recommend to look at their sources, and to experiment a bit, by executing them
at a PicoLisp prompt, or by pressing the browser's "Reload" button after editing
the "project.l" file.


For a suitable PicoLisp prompt, either execute (in a separate terminal
window) the PicoLisp Shell (psh) command (works only if the
application server is running, and you did generate a ".pw"
file)



$ /usr/lib/picolisp/bin/psh 8080
:




or start the interpreter stand-alone, with "@lib/xhtml.l" loaded



$ pil @lib/http.l @lib/xhtml.l +
:




Note that for all these tag functions the above tag body
evaluation rule applies.



Simple Tags



Most tag functions are simple and straightforward. Some of them just print
their arguments



: (<br> "Hello world")
Hello world<br/>

: (<em> "Hello world")
<em>Hello world</em>




while most of them take a CSS attribute specification
as their first argument (like the <h1> tag above)



: (<div> 'main "Hello world")
<div class="main">Hello world</div>

: (<p> NIL "Hello world")
<p>Hello world</p>

: (<p> 'info "Hello world")
<p class="info">Hello world</p>




All of these functions take an arbitrary number of arguments, and may nest to
an arbitrary depth (as long as the resulting HTML is legal)



: (<div> 'main
   (<h1> NIL "Head")
   (<p> NIL
      (<br> "Line 1")
      "Line"
      (<nbsp>)
      (+ 1 1) ) )
<div class="main"><h1>Head</h1>
<p>Line 1<br/>
Line 2</p>
</div>





(Un)ordered Lists



HTML-lists, implemented by the <ol> and
<ul> tags, let you define hierarchical structures. You might
want to paste the following code into your copy of "project.l":



########################################################################
(html 0 "Unordered List" "@lib.css" NIL
   (<ul> NIL
      (<li> NIL "Item 1")
      (<li> NIL
         "Sublist 1"
         (<ul> NIL
            (<li> NIL "Item 1-1")
            (<li> NIL "Item 1-2") ) )
      (<li> NIL "Item 2")
      (<li> NIL
         "Sublist 2"
         (<ul> NIL
            (<li> NIL "Item 2-1")
            (<li> NIL "Item 2-2") ) )
      (<li> NIL "Item 3") ) )
########################################################################




Here, too, you can put arbitrary code into each node of that tree, including
other tag functions.



Tables



Like the hierarchical structures with the list functions, you can generate
two-dimensional tables with the <table> and
<row> functions.


The following example prints a table of numbers and their squares:



########################################################################
(html 0 "Table" "@lib.css" NIL
   (<table> NIL NIL NIL
      (for N 10                                    # A table with 10 rows
         (<row> NIL N (prin (* N N))) ) ) )     # and 2 columns
########################################################################




The first argument to <table> is the usual CSS attribute,
the second an optional title ("caption"), and the third an optional list
specifying the column headers. In that list, you may supply a list for a each
column, with a CSS attribute in its CAR, and a tag body in its CDR for the
contents of the column header.


The body of <table> contains calls to the
<row> function. This function is special in that each
expression in its body will go to a separate column of the table. If both for
the column header and the row function an CSS attribute is given, they will be
combined by a space and passed to the HTML <td> tag. This
permits distinct CSS specifications for each column and row.


As an extension of the above table example, let's pass some attributes for
the table itself (not recommended - better define such styles in a CSS file and
then just pass the class name to <table>), right-align both
columns, and print each row in an alternating red and blue color



########################################################################
(html 0 "Table" "@lib.css" NIL
   (<table>
      '((width . "200px") (style . "border: dotted 1px;"))    # table style
      "Square Numbers"                                        # caption
      '((align "Number") (align "Square"))                    # 2 headers
      (for N 10                                                  # 10 rows
         (<row> (xchg '(red) '(blue))                         # red or blue
            N                                                 # 2 columns
            (prin (* N N) ) ) ) ) )
########################################################################




If you wish to concatenate two or more cells in a table, so that a single
cell spans several columns, you can pass the symbol '-' for the
additional cell data to <row>. This will cause the data given
to the left of the '-' symbols to expand to the right.


You can also directly specify table structures with the simple
<th>, <tr> and <td> tag
functions.


If you just need a two-dimensional arrangement of components, the even
simpler <grid> function might be convenient:



########################################################################
(html 0 "Grid" "@lib.css" NIL
   (<grid> 3
      "A" "B" "C"
      123 456 789 ) )
########################################################################




It just takes a specification for the number of columns (here: 3) as its
first argument, and then a single expression for each cell. Instead of a number,
you can also pass a list of CSS attributes. Then the length of that list will
determine the number of columns. You can change the second line in the above
example to



   (<grid> '(NIL NIL right)




Then the third column will be right aligned.



Menus and Tabs



The two most powerful tag functions are <menu> and
<tab>. Used separately or in combination, they form a
navigation framework with


    

  • menu items which open and close submenus

  • submenu items which switch to different pages

  • tabs which switch to different subpages




The following example is not very useful, because the URLs of all items link
to the same "project.l" page, but it should suffice to demonstrate the
functionality:



########################################################################
(html 0 "Menu+Tab" "@lib.css" NIL
   (<div> '(id . menu)
      (<menu>
         ("Item" "project.l")                      # Top level item
         (NIL (<hr>))                              # Plain HTML
         (T "Submenu 1"                            # Submenu
            ("Subitem 1.1" "project.l")
            (T "Submenu 1.2"
               ("Subitem 1.2.1" "project.l")
               ("Subitem 1.2.2" "project.l")
               ("Subitem 1.2.3" "project.l") )
            ("Subitem 1.3" "project.l") )
         (T "Submenu 2"
            ("Subitem 2.1" "project.l")
            ("Subitem 2.2" "project.l") ) ) )
   (<div> '(id . main)
      (<h1> NIL "Menu+Tab")
      (<tab>
         ("Tab1"
            (<h3> NIL "This is Tab 1") )
         ("Tab2"
            (<h3> NIL "This is Tab 2") )
         ("Tab3"
            (<h3> NIL "This is Tab 3") ) ) ) )
########################################################################




<menu> takes a sequence of menu items. Each menu item is a
list, with its CAR either


    

  • NIL: The entry is not an active menu item, and the rest of the
list may consist of arbitrary code (usually HTML tags).


  • T: The second element is taken as a submenu name, and a click
on that name will open or close the corresponding submenu. The rest of the list
recursively specifies the submenu items (may nest to arbitrary depth).


  • Otherwise: The menu item specifies a direct action (instead of opening a
submenu), where the first list element gives the item's name, and the second
element the corresponding URL.





<tab> takes a list of subpages. Each page is simply a tab
name, followed by arbitrary code (typically HTML tags).


Note that only a single menu and a single tab may be active at the same time.





Interactive Forms



In HTML, the only possibility for user input is via <form>
and <input> elements, using the HTTP POST method to
communicate with the server.


"@lib/xhtml.l" defines a function called <post>, and a
collection of input tag functions, which allow direct programming of HTML forms.
We will supply only one simple example:



########################################################################
(html 0 "Simple Form" "@lib.css" NIL
   (<post> NIL "project.l"
      (<field> 10 '*Text)
      (<submit> "Save") ) )
########################################################################




This associates a text input field with a global variable *Text.
The field displays the current value of *Text, and pressing the
submit button causes a reload of "project.l" with *Text set to any
string entered by the user.


An application program could then use that variable to do something useful,
for example store its value in a database.


The problem with such a straightforward use of forms is that


    

  1. they require the application programmer to take care of maintaining lots of
global variables. Each input field on the page needs an associated variable for
the round trip between server and client.


  2. they do not preserve an application's internal state. Each POST request
spawns an individual process on the server, which sets the global variables to
their new values, generates the HTML page, and terminates thereafter. The
application state has to be passed along explicitly, e.g. using
<hidden> tags.


  3. they are not very interactive. There is typically only a single submit
button. The user fills out a possibly large number of input fields, but changes
will take effect only when the submit button is pressed.





Though we wrote a few applications in that style, we recommend the GUI
framework provided by "@lib/form.l". It does not need any variables for the
client/server communication, but implements a class hierarchy of GUI components
for the abstraction of application logic, button actions and data linkage.





Sessions



First of all, we need to establish a persistent environment on the server, to
handle each individual session (for each connected client).


Technically, this is just a child process of the server we started above, which does not terminate immediately after it sent its
page to the browser. It is achieved by calling the app function
somewhere in the application's startup code.



########################################################################
(app)  # Start a session

(html 0 "Simple Session" "@lib.css" NIL
   (<post> NIL "project.l"
      (<field> 10 '*Text)
      (<submit> "Save") ) )
########################################################################




Nothing else changed from the previous example. However, when you connect
your browser and then look at the terminal window where you started the
application server, you'll notice a colon, the PicoLisp prompt



$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  +
:




Tools like the Unix ps utility will tell you that now two
picolisp processes are running, the first being the parent of the
second.


If you enter some text, say "abcdef", into the text field in the browser
window, press the submit button, and inspect the Lisp *Text
variable,



: *Text
-> "abcdef"




you see that we now have a dedicated PicoLisp process, "connected" to the
client.


You can terminate this process (like any interactive PicoLisp) by hitting
Ctrl-D on an empty line. Otherwise, it will terminate by itself if
no other browser requests arrive within a default timeout period of 5 minutes.


To start a (non-debug) production version, the server is commonly started
without the '+' flag, and with -wait



$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  -wait




In that way, no command line prompt appears when a client connects.





Action Forms



Now that we have a persistent session for each client, we can set up an
active GUI framework.


This is done by wrapping the call to the html function with
action. Inside the body of html can be - in addition
to all other kinds of tag functions - one or more calls to form



########################################################################
(app)                                              # Start session

(action                                            # Action handler
   (html 0 "Form" "@lib.css" NIL                   # HTTP/HTML protocol
      (form NIL                                    # Form
         (gui 'a '(+TextField) 10)                 # Text Field
         (gui '(+Button) "Print"                   # Button
            '(msg (val> (: home a))) ) ) ) )
########################################################################




Note that there is no longer a global variable like *Text to
hold the contents of the input field. Instead, we gave a local, symbolic name
'a' to a +TextField component



         (gui 'a '(+TextField) 10)                 # Text Field




Other components can refer to it



            '(msg (val> (: home a)))




(: home) is always the form which contains this GUI component.
So (: home a) evaluates to the component 'a' in the
current form. As msg prints its
argument to standard error, and the val> method retrieves the
current contents of a component, we will see on the console the text typed into
the text field when we press the button.


An action without embedded forms - or a
form without a surrounding action - does not make much
sense by itself. Inside html and form, however, calls
to HTML functions (and any other Lisp functions, for that matter) can be freely
mixed.


In general, a typical page may have the form



(action                                            # Action handler
   (html ..                                        # HTTP/HTML protocol
      (<h1> ..)                                    # HTML tags
      (form NIL                                    # Form
         (<h3> ..)
         (gui ..)                                  # GUI component(s)
         (gui ..)
         .. )
      (<h2> ..)
      (form NIL                                    # Another form
         (<h3> ..)
         (gui ..)                                  # GUI component(s)
         .. )
      (<br> ..)
      .. ) )





The gui Function



The most prominent function in a form body is gui.
It is the workhorse of GUI construction.


Outside of a form body, gui is undefined.
Otherwise, it takes an optional alias name, a list of classes, and additional
arguments as needed by the constructors of these classes. We saw this example
before



         (gui 'a '(+TextField) 10)                 # Text Field



Here, 'a' is an alias name for a component of type
(+TextField). The numeric argument 10 is passed to the
text field, specifying its width. See the chapter on GUI
Classes for more examples.


During a GET request, gui is basically a front-end to
new. It builds a component, stores it in the internal structures of
the current form, and initializes it by sending the init>
message to the component. Finally, it sends it the show>
message, to produce HTML code and transmit it to the browser.


During a POST request, gui does not build any new components.
Instead, the existing components are re-used. So gui does not have
much more to do than sending the show> message to a component.



Control Flow



HTTP has only two methods to change a browser window: GET and POST. We employ
these two methods in a certain defined, specialized way:


    

  • GET means, a new page is being constructed. It is used when a page is
visited for the first time, usually by entering an URL into the browser's
address field, or by clicking on a link (which is often a submenu item or tab).


  • POST is always directed to the same page. It is triggered by a button
press, updates the corresponding form's data structures, and executes that
button's action code.





A button's action code can do almost anything: Read and modify the contents
of input fields, communicate with the database, display alerts and dialogs, or
even fake the POST request to a GET, with the effect of showing a completely
different document (See Switching URLs).


GET builds up all GUI components on the server. These components are objects
which encapsulate state and behavior of the HTML page in the browser. Whenever a
button is pressed, the page is reloaded via a POST request. Then - before any
output is sent to the browser - the action function takes control.
It performs error checks on all components, processes possible user input on the
HTML page, and stores the values in correct format (text, number, date, object
etc.) in each component.


The state of a form is preserved over time. When the user returns to a
previous page with the browser's BACK button, that state is reactivated, and may
be POSTed again.


The following silly example displays two text fields. If you enter some text
into the "Source" field, you can copy it in upper or lower case to the
"Destination" field by pressing one of the buttons



########################################################################
(app)

(action
   (html 0 "Case Conversion" "@lib.css" NIL
      (form NIL
         (<grid> 2
            "Source" (gui 'src '(+TextField) 30)
            "Destination" (gui 'dst '(+Lock +TextField) 30) )
         (gui '(+JS +Button) "Upper Case"
            '(set> (: home dst)
               (uppc (val> (: home src))) ) )
         (gui '(+JS +Button) "Lower Case"
            '(set> (: home dst)
               (lowc (val> (: home src))) ) ) ) ) )
########################################################################




The +Lock prefix class in the
"Destination" field makes that field read-only. The only way to get some text
into that field is by using one of the buttons.



Switching URLs



Because an action code runs before html has a chance to output
an HTTP header, it can abort the current page and present something different to
the user. This might, of course, be another HTML page, but would not be very
interesting as a normal link would suffice. Instead, it can cause the download
of dynamically generated data.


The next example shows a text area and two buttons. Any text entered into the
text area is exported either as a text file via the first button, or a PDF
document via the second button



########################################################################
(load "@lib/ps.l")

(app)

(action
   (html 0 "Export" "@lib.css" NIL
      (form NIL
         (gui '(+TextField) 30 8)
         (gui '(+Button) "Text"
            '(let Txt (tmp "export.txt")
               (out Txt (prinl (val> (: home gui 1))))
               (url Txt) ) )
         (gui '(+Button) "PDF"
            '(psOut NIL "foo"
               (a4)
               (indent 40 40)
               (down 60)
               (hline 3)
               (font (14 . "Times-Roman")
                  (ps (val> (: home gui 1))) )
               (hline 3)
               (page) ) ) ) ) )
########################################################################




(a text area is built when you supply two numeric arguments (columns and
rows) to a +TextField class)


The action code of the first button
creates a temporary file (i.e. a file named "export.txt" in the current
process's temporary space), prints the value of the text area (this time we did
not bother to give it a name, we simply refer to it as the form's first gui list
element) into that file, and then calls the url function with the file name.


The second button uses the PostScript library "@lib/ps.l" to create a
temporary file "foo.pdf". Here, the temporary file creation and the call to the
url function is hidden in the internal mechanisms of
psOut. The effect is that the browser receives a PDF document and
displays it.



Alerts and Dialogs



Alerts and dialogs are not really what they used to be ;-)


They do not "pop up". In this framework, they are just a kind of
simple-to-use, pre-fabricated form. They can be invoked by a button's action
code, and appear always on the current page, immediately preceding the form
which created them.


Let's look at an example which uses two alerts and a dialog. In the
beginning, it displays a simple form, with a locked text field, and two buttons



########################################################################
(app)

(action
   (html 0 "Alerts and Dialogs" "@lib.css" NIL
      (form NIL
         (gui '(+Init +Lock +TextField) "Initial Text" 20 "My Text")
         (gui '(+Button) "Alert"
            '(alert NIL "This is an alert " (okButton)) )
         (gui '(+Button) "Dialog"
            '(dialog NIL
               (<br> "This is a dialog.")
               (<br>
                  "You can change the text here "
                  (gui '(+Init +TextField) (val> (: top 1 gui 1)) 20) )
               (<br> "and then re-submit it to the form.")
               (gui '(+Button) "Re-Submit"
                  '(alert NIL "Are you sure? "
                     (yesButton
                        '(set> (: home top 2 gui 1)
                           (val> (: home top 1 gui 1)) ) )
                     (noButton) ) )
               (cancelButton) ) ) ) ) )
########################################################################




The +Init prefix class
initializes the "My Text" field with the string "Initial Text". As the field is
locked, you cannot modify this value directly.


The first button brings up an alert saying "This is an alert.". You can
dispose it by pressing "OK".


The second button brings up a dialog with an editable text field, containing
a copy of the value from the form's locked text field. You can modify this
value, and send it back to the form, if you press "Re-Submit" and answer "Yes"
to the "Are you sure?" alert.



A Calculator Example



Now let's forget our "project.l" test file for a moment, and move on to a
more substantial and practical, stand-alone, example. Using what we have learned
so far, we want to build a simple bignum calculator. ("bignum" because PicoLisp
can do only bignums)


It uses a single form, a single numeric input field, and lots of buttons. It
can be found in the PicoLisp distribution (e.g. under "/usr/share/picolisp/") in
"misc/calc.l", together with a directly executable wrapper script "misc/calc".


To use it, change to the PicoLisp installation directory, and start it as



$ misc/calc




or call it with an absolute path, e.g.



$ /usr/share/picolisp/misc/calc




If you like to get a PicoLisp prompt for inspection, start it instead as



$ pil misc/calc.l -main -go +




Then - as before - point your browser to 'http://localhost:8080'.


The code for the calculator logic and the GUI is rather straightforward. The
entry point is the single function calculator. It is called
directly (as described in URL Syntax) as the server's
default URL, and implicitly in all POST requests. No further file access is
needed once the calculator is running.


Note that for a production application, we inserted an allow-statement (as
recommended by the Security chapter)



(allowed NIL "!calculator" "@lib.css")




at the beginning of "misc/calc.l". This will restrict external access to that
single function.


The calculator uses three global variables, *Init,
*Accu and *Stack. *Init is a boolean flag
set by the operator buttons to indicate that the next digit should initialize
the accumulator to zero. *Accu is the accumulator. It is always
displayed in the numeric input field, accepts user input, and it holds the
results of calculations. *Stack is a push-down stack, holding
postponed calculations (operators, priorities and intermediate results) with
lower-priority operators, while calculations with higher-priority operators are
performed.


The function digit is called by the digit buttons, and adds
another digit to the accumulator.


The function calc does an actual calculation step. It pops the
stack, checks for division by zero, and displays an error alert if necessary.


operand processes an operand button, accepting a function and a
priority as arguments. It compares the priority with that in the top-of-stack
element, and delays the calculation if it is less.


finish is used to calculate the final result.


The calculator function has one numeric input field, with a
width of 60 characters



         (gui '(+Var +NumField) '*Accu 60)




The +Var prefix class
associates this field with the global variable *Accu. All changes
to the field will show up in that variable, and modification of that variable's
value will appear in the field.


The square root operator button has an
+Able prefix class



         (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730)
            '(setq *Accu (sqrt *Accu)) )





with an argument expression which checks that the current value in the
accumulator is positive, and disables the button if otherwise.


The rest of the form is just an array (grid) of buttons, encapsulating all
functionality of the calculator. The user can enter numbers into the input
field, either by using the digit buttons, or by directly typing them in, and
perform calculations with the operator buttons. Supported operations are
addition, subtraction, multiplication, division, sign inversion, square root and
power (all in bignum integer arithmetic). The 'C' button just
clears the accumulator, while the 'A' button also clears all
pending calculations.


All that in 53 lines of code!





Charts



Charts are virtual components,
maintaining the internal representation of two-dimensional data.


Typically, these data are nested lists, database selections, or some kind of
dynamically generated tabular information. Charts make it possible to view them
in rows and columns (usually in HTML tables), scroll up
and down, and associate them with their corresponding visible GUI components.


In fact, the logic to handle charts makes up a substantial part of the whole
framework, with large impact on all internal mechanisms. Each GUI component must
know whether it is part of a chart or not, to be able to handle its contents
properly during updates and user interactions.


Let's assume we want to collect textual and numerical data. We might create a
table



########################################################################
(app)

(action
   (html 0 "Table" "@lib.css" NIL
      (form NIL
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui '(+TextField) 20)
                  (gui '(+NumField) 10) ) ) )
         (<submit> "Save") ) ) )
########################################################################




with two columns "Text" and "Number", and four rows, each containing a
+TextField and a +NumField.


You can enter text into the first column, and numbers into the second.
Pressing the "Save" button stores these values in the components on the server
(or produces an error message if a string in the second column is not a legal
number).


There are two problems with this solution:


    

  1. Though you can get at the user input for the individual fields, e.g.


    
: (val> (get *Top 'gui 2))  # Value in the first row, second column
-> 123

    

there is no direct way to get the whole data structure as a single list.
Instead, you have to traverse all GUI components and collect the data.


  2. The user cannot input more than four rows of data, because there is no easy
way to scroll down and make space for more.





A chart can handle these things:



########################################################################
(app)

(action
   (html 0 "Chart" "@lib.css" NIL
      (form NIL
         (gui '(+Chart) 2)                         # Inserted a +Chart
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui 1 '(+TextField) 20)         # Inserted '1'
                  (gui 2 '(+NumField) 10) ) ) )    # Inserted '2'
         (<submit> "Save") ) ) )
########################################################################




Note that we inserted a +Chart component before the GUI
components which should be managed by the chart. The argument '2' tells the
chart that it has to expect two columns.


Each component got an index number (here '1' and '2') as the first argument
to gui, indicating the column into which this component should go
within the chart.


Now - if you entered "a", "b" and "c" into the first, and 1, 2, and 3 into
the second column - we can retrieve the chart's complete contents by sending it
the val> message



: (val> (get *Top 'chart 1))  # Retrieve the value of the first chart
-> (("a" 1) ("b" 2) ("c" 3))




BTW, a more convenient function is chart



: (val> (chart))  # Retrieve the value of the current chart
-> (("a" 1) ("b" 2) ("c" 3))




chart can be used instead of
the above construct when we want to access the "current" chart, i.e. the chart
most recently processed in the current form.



Scrolling



To enable scrolling, let's also insert two buttons. We use the pre-defined
classes +UpButton and
+DnButton



########################################################################
(app)

(action
   (html 0 "Scrollable Chart" "@lib.css" NIL
      (form NIL
         (gui '(+Chart) 2)
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui 1 '(+TextField) 20)
                  (gui 2 '(+NumField) 10) ) ) )
         (gui '(+UpButton) 1)                   # Inserted two buttons
         (gui '(+DnButton) 1)
         (----)
         (<submit> "Save") ) ) )
########################################################################




to scroll down and up a single (argument '1') line at a time.


Now it is possible to enter a few rows of data, scroll down, and continue. It
is not necessary (except in the beginning, when the scroll buttons are still
disabled) to press the "Save" button, because any button in the form will
send changes to the server's internal structures before any action is performed.



Put and Get Functions



As we said, a chart is a virtual component to edit two-dimensional data.
Therefore, a chart's native data format is a list of lists: Each sublist
represents a single row of data, and each element of a row corresponds to a
single GUI component.


In the example above, we saw a row like



   ("a" 1)




being mapped to



   (gui 1 '(+TextField) 20)
   (gui 2 '(+NumField) 10)




Quite often, however, such a one-to-one relationship is not desired. The
internal data structures may have to be presented in a different form to the
user, and user input may need conversion to an internal representation.


For that, a chart accepts - in addition to the "number of columns" argument -
two optional function arguments. The first function is invoked to 'put' the
internal representation into the GUI components, and the second to 'get' data
from the GUI into the internal representation.


A typical example is a chart displaying customers in a database. While the
internal representation is a (one-dimensional) list of customer objects, 'put'
expands each object to a list with, say, the customer's first and second name,
telephone number, address and so on. When the user enters a customer's name,
'get' locates the matching object in the database and stores it in the internal
representation. In the following, 'put' will in turn expand it to the GUI.


For now, let's stick with a simpler example: A chart that holds just a list
of numbers, but expands in the GUI to show also a textual form of each number
(in German).



########################################################################
(app)

(load "@lib/zahlwort.l")

(action
   (html 0 "Numerals" "@lib.css" NIL
      (form NIL
         (gui '(+Init +Chart) (1 5 7) 2
            '((N) (list N (zahlwort N)))
            car )
         (<table> NIL NIL '((NIL "Numeral") (NIL "German"))
            (do 4
               (<row> NIL
                  (gui 1 '(+NumField) 9)
                  (gui 2 '(+Lock +TextField) 90) ) ) )
         (gui '(+UpButton) 1)
         (gui '(+DnButton) 1)
         (----)
         (<submit> "Save") ) ) )
########################################################################




"@lib/zahlwort.l" defines the utility function zahlwort, which
is required later by the 'put' function. zahlwort accepts a number
and returns its wording in German.


Now look at the code



         (gui '(+Init +Chart) (1 5 7) 2
            '((N) (list N (zahlwort N)))
            car )




We prefix the +Chart class
with +Init, and pass it a list
of numbers (1 5 7) for the initial value of the chart. Then,
following the '2' (the chart has two columns), we pass a 'put' function



            '((N) (list N (zahlwort N)))




which takes a number and returns a list of that number and its wording, and a
'get' function



            car )




which in turn accepts such a list and returns a number, which happens to be
the list's first element.


You can see from this example that 'get' is the inverse function of 'put'.
'get' can be omitted, however, if the chart is read-only (contains no (or only
locked) input fields).


The field in the second column



                  (gui 2 '(+Lock +TextField) 90) ) ) )




is locked, because it displays the text
generated by 'put', and is not supposed to accept any user input.


When you start up this form in your browser, you'll see three pre-filled
lines with "1/eins", "5/fünf" and "7/sieben", according to the +Init argument (1 5 7).
Typing a number somewhere into the first column, and pressing ENTER or one of
the buttons, will show a suitable text in the second column.





GUI Classes



In previous chapters we saw examples of GUI classes like +TextField, +NumField or +Button, often in combination with
prefix classes like +Lock,
+Init or +Able. Now we take a broader look at the
whole hierarchy, and try more examples.


The abstract class +gui is the base of all GUI classes. A live
view of the class hierarchy can be obtained with the dep ("dependencies") function:



: (dep '+gui)
+gui
   +Img
   +field
      +Radio
      +TextField
         +UpField
         +PwField
         +BlobField
         +FileField
         +TimeField
         +DateField
         +MailField
         +AtomField
         +HttpField
         +LinesField
         +ClassField
         +TelField
         +numField
            +NumField
            +FixField
         +SymField
         +SexField
         +ListTextField
      +Checkbox
   +Button
      +BubbleButton
      +DelRowButton
      +DnButton
      +GoButton
      +UpButton
      +ChoButton
         +Choice
      +ClrButton
      +PickButton
         +DstButton
      +todoButton
         +RedoButton
         +UndoButton
      +ShowButton
   +JsField
-> +gui




We see, for example, that +DnButton is a subclass of +Button, which in turn is a subclass of
+gui. Inspecting +DnButton directly



: (dep '+DnButton)
   +Tiny
   +Rid
   +JS
   +Able
      +gui
   +Button
+DnButton
-> +DnButton




shows that +DnButton
inherits from +Tiny, +Rid, +Able and +Button. The actual definition of
+DnButton can be found in
"@lib/form.l"



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




In general, "@lib/form.l" is the ultimate reference to the framework, and
should be freely consulted. See also the form library
reference.





Input Fields



Input fields implement the visual display of application data, and allow -
when enabled - input and modification of these data.


On the HTML level, they can take the form of


    

  • Normal text input fields

  • Textareas

  • Checkboxes

  • Drop-down selections

  • Password fields

  • HTML links

  • Plain HTML text




Except for checkboxes, which are implemented by the Checkbox class, all these HTML representations are
generated by +TextField and
its content-specific subclasses like +NumField, +DateField etc. Their actual
appearance (as one of the above forms) depends on their arguments:


We saw already "normal" text fields. They are created with a single numeric
argument. This example creates an editable field with a width of 10 characters:



   (gui '(+TextField) 10)




If you supply a second numeric for the line count ('4' in this case), you'll
get a text area:



   (gui '(+TextField) 10 4)




Supplying a list of values instead of a count yields a drop-down selection
(combo box):



   (gui '(+TextField) '("Value 1" "Value 2" "Value 3"))




In addition to these arguments, you can pass a string. Then the field is
created with a label:



   (gui '(+TextField) 10 "Plain")
   (gui '(+TextField) 10 4 "Text Area")
   (gui '(+TextField) '("Value 1" "Value 2" "Value 3") "Selection")




Finally, without any arguments, the field will appear as a plain HTML text:



   (gui '(+TextField))




This makes mainly sense in combination with prefix classes like +Var and +Obj, to manage the contents of these
fields, and achieve special behavior as HTML links or scrollable chart values.



Numeric Input Fields



A +NumField returns a
number from its val> method, and accepts a number for its
set> method. It issues an error message when user input cannot
be converted to a number.


Large numbers are shown with a thousands-separator, as determined by the
current locale.



########################################################################
(app)

(action
   (html 0 "+NumField" "@lib.css" NIL
      (form NIL
         (gui '(+NumField) 10)
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "Set to 123"
            '(set> (: home gui 1) 123) ) ) ) )
########################################################################




A +FixField needs an
additional scale factor argument, and accepts/returns scaled fixpoint numbers.


The decimal separator is determined by the current locale.



########################################################################
(app)

(action
   (html 0 "+FixField" "@lib.css" NIL
      (form NIL
         (gui '(+FixField) 3 10)
         (gui '(+JS +Button) "Print value"
            '(msg (format (val> (: home gui 1)) 3)) )
         (gui '(+JS +Button) "Set to 123.456"
            '(set> (: home gui 1) 123456) ) ) ) )
########################################################################





Time & Date



A +DateField accepts and
returns a date value.



########################################################################
(app)

(action
   (html 0 "+DateField" "@lib.css" NIL
      (form NIL
         (gui '(+DateField) 10)
         (gui '(+JS +Button) "Print value"
            '(msg (datStr (val> (: home gui 1)))) )
         (gui '(+JS +Button) "Set to \"today\""
            '(set> (: home gui 1) (date)) ) ) ) )
########################################################################




The format displayed to - and entered by - the user depends on the current
locale (see datStr and expDat). You can change it, for example to



: (locale "DE" "de")
-> NIL




If no locale is set, the format is YYYY-MM-DD. Some pre-defined locales use
patterns like DD.MM.YYYY (DE), YYYY/MM/DD (JP), DD/MM/YYYY (UK), or MM/DD/YYYY
(US).


An error is issued when user input does not match the current locale's date
format.


Independent from the locale setting, a +DateField tries to expand
abbreviated input from the user. A small number is taken as that day of the
current month, larger numbers expand to day and month, or to day, month and
year:


    

  • "7" gives the 7th of the current month

  • "031" or "0301" give the 3rd of January of the current year

  • "311" or "3101" give the 31st of January of the current year

  • "0311" gives the 3rd of November of the current year

  • "01023" or "010203" give the first of February in the year 2003

  • and so on




Similar is the +TimeField. It accepts and returns a time value.



########################################################################
(app)

(action
   (html 0 "+TimeField" "@lib.css" NIL
      (form NIL
         (gui '(+TimeField) 8)
         (gui '(+JS +Button) "Print value"
            '(msg (tim$ (val> (: home gui 1)))) )
         (gui '(+JS +Button) "Set to \"now\""
            '(set> (: home gui 1) (time)) ) ) ) )
########################################################################




When the field width is '8', like in this example, time is displayed in the
format HH:MM:SS. Another possible value would be '5', causing
+TimeField to display its value as HH:MM.


An error is issued when user input cannot be converted to a time value.


The user may omit the colons. If he inputs just a small number, it should be
between '0' and '23', and will be taken as a full hour. '125' expands to
"12:05", '124517' to "12:45:17", and so on.



Telephone Numbers



Telephone numbers are represented internally by the country code (without a
leading plus sign or zero) followed by the local phone number (ideally separated
by spaces) and the phone extension (ideally separated by a hyphen). The exact
format of the phone number string is not enforced by the GUI, but further
processing (e.g. database searches) normally uses fold for better reproducibility.


To display a phone number, +TelField replaces the country code
with a single zero if it is the country code of the current locale, or prepends
it with a plus sign if it is a foreign country (see telStr).


For user input, a plus sign or a double zero is simply dropped, while a
single leading zero is replaced with the current locale's country code (see
expTel).



########################################################################
(app)
(locale "DE" "de")

(action
   (html 0 "+TelField" "@lib.css" NIL
      (form NIL
         (gui '(+TelField) 20)
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "Set to \"49 1234 5678-0\""
            '(set> (: home gui 1) "49 1234 5678-0") ) ) ) )
########################################################################





Checkboxes



A +Checkbox is
straightforward. User interaction is restricted to clicking it on and off. It
accepts boolean (NIL or non-NIL) values, and returns
T or NIL.



########################################################################
(app)

(action
   (html 0 "+Checkbox" "@lib.css" NIL
      (form NIL
         (gui '(+Checkbox))
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "On"
            '(set> (: home gui 1) T) )
         (gui '(+JS +Button) "Off"
            '(set> (: home gui 1) NIL) ) ) ) )
########################################################################







Field Prefix Classes



A big part of this framework's power is owed to the combinatorial flexibility
of prefix classes for GUI- and DB-objects. They allow to surgically override
individual methods in the inheritance tree, and can be combined in various ways
to achieve any desired behavior.


Technically, there is nothing special about prefix classes. They are just
normal classes. They are called "prefix" because they are intended to be written
before other classes in a class's or object's list of superclasses.


Usually they take their own arguments for their T method from
the list of arguments to the gui function.



Initialization



+Init overrides the
init> method for that component. The init>
message is sent to a +gui component when the page is loaded for the
first time (during a GET request). +Init takes an expression for the initial
value of that field.



   (gui '(+Init +TextField) "This is the initial text" 30)




Other classes which automatically give a value to a field are +Var (linking the field to a variable) and
+E/R (linking the field to a
database entity/relation).


+Cue can be used, for example
in "mandatory" fields, to give a hint to the user about what he is supposed to
enter. It will display the argument value, in angular brackets, if and only if
the field's value is NIL, and the val> method will
return NIL despite the fact that this value is displayed.


Cause an empty field to display "<Please enter some text here>":



   (gui '(+Cue +TextField) "Please enter some text here" 30)





Disabling and Enabling



An important feature of an interactive GUI is the context-sensitive disabling
and enabling of individual components, or of a whole form.


The +Able prefix class takes
an argument expression, and disables the component if this expression returns
NIL. We saw an example for its usage already in the square root button of the calculator example. Or, for
illustration purposes, imagine a button which is supposed to be enabled only
after Christmas



   (gui '(+Able +Button)
      '(>= (cdr (date (date))) (12 24))
      "Close this year"
      '(endOfYearProcessing) )




or a password field that is disabled as long as somebody is logged in



   (gui '(+Able +PwField) '(not *Login) 10 "Password")




A special case is the +Lock
prefix, which permanently and unconditionally disables a component. It takes no
arguments



   (gui '(+Lock +NumField) 10 "Count")




('10' and "Count" are for the +NumField), and creates a read-only
field.


The whole form can be disabled by calling disable with a non-NIL
argument. This affects all components in this form. Staying with the above
example, we can make the form read-only until Christmas



   (form NIL
      (disable (> (12 24) (cdr (date (date)))))  # Disable whole form
      (gui ..)
      .. )




Even in a completely disabled form, however, it is often necessary to
re-enable certain components, as they are needed for navigation, scrolling, or
other activities which don't affect the contents of the form. This is done by
prefixing these fields with +Rid
(i.e. getting "rid" of the lock).



   (form NIL
      (disable (> (12 24) (cdr (date (date)))))
      (gui ..)
      ..
      (gui '(+Rid +Button) ..)  # Button is enabled despite the disabled form
      .. )





Formatting



GUI prefix classes allow a fine-grained control of how values are stored in -
and retrieved from - components. As in predefined classes like +NumField or +DateField, they override the
set> and/or val> methods.


+Set takes an argument
function which is called whenever that field is set to some value. To convert
all user input to upper case



   (gui '(+Set +TextField) uppc 30)




+Val is the complement to
+Set. It takes a function which
is called whenever the field's value is retrieved. To return the square of a
field's value



   (gui '(+Val +NumField) '((N) (* N N)) 10)




+Fmt is just a combination of
+Set and +Val, and takes two functional arguments.
This example will display upper case characters, while returning lower case
characters internally



   (gui '(+Fmt +TextField) uppc lowc 30)




+Map does (like +Fmt) a two-way translation. It uses a
list of cons pairs for a linear lookup, where the CARs represent the displayed
values which are internally mapped to the values in the CDRs. If a value is not
found in this list during set> or val>, it is
passed through unchanged.


Normally, +Map is used in
combination with the combo box incarnation of text fields (see Input Fields). This example displays "One", "Two" and
"Three" to the user, but returns a number 1, 2 or 3 internally



########################################################################
(app)

(action
   (html 0 "+Map" "@lib.css" NIL
      (form NIL
         (gui '(+Map +TextField)
            '(("One" . 1) ("Two" . 2) ("Three" . 3))
            '("One" "Two" "Three") )
         (gui '(+Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################





Side Effects



Whenever a button is pressed in the GUI, any changes caused by action in the current environment (e.g.
the database or application state) need to be reflected in the corresponding GUI
fields. For that, the upd> message is sent to all components.
Each component then takes appropriate measures (e.g. refresh from database
objects, load values from variables, or calculate a new value) to update its
value.


While the upd> method is mainly used internally, it can be
overridden in existing classes via the +Upd prefix class. Let's print updated
values to standard error



########################################################################
(app)
(default *Number 0)

(action
   (html 0 "+Upd" "@lib.css" NIL
      (form NIL
         (gui '(+Upd +Var +NumField)
            '(prog (extra) (msg *Number))
            '*Number 8 )
         (gui '(+JS +Button) "Increment"
            '(inc '*Number) ) ) ) )
########################################################################





Validation



To allow automatic validation of user input, the chk> message
is sent to all components at appropriate times. The corresponding method should
return NIL if the value is all right, or a string describing the
error otherwise.


Many of the built-in classes have a chk> method. The +NumField class checks for legal
numeric input, or the +DateField for a valid calendar
date.


An on-the-fly check can be implemented with the +Chk prefix class. The following code only
accepts numbers not bigger than 9: The or expression first
delegates the check to the main +NumField class, and - if it does not
give an error - returns an error string when the current value is greater than
9.



########################################################################
(app)

(action
   (html 0 "+Chk" "@lib.css" NIL
      (form NIL
         (gui '(+Chk +NumField)
            '(or
               (extra)
               (and (> (val> This) 9) "Number too big") )
            12 )
         (gui '(+JS +Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################




A more direct kind of validation is built-in via the +Limit class. It controls the
maxlength attribute of the generated HTML input field component.
Thus, it is impossible to type more characters than allowed into the field.



########################################################################
(app)

(action
   (html 0 "+Limit" "@lib.css" NIL
      (form NIL
         (gui '(+Limit +TextField) 4 8)
         (gui '(+JS +Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################





Data Linkage



Although set> and val> are the official
methods to get a value in and out of a GUI component, they are not very often
used explicitly. Instead, components are directly linked to internal Lisp data
structures, which are usually either variables or database objects.


The +Var prefix class takes a
variable (described as the var data type - either a symbol or a
cons pair - in the Function Reference). In the
following example, we initialize a global variable with the value "abc", and let
a +TextField operate on it.
The "Print" button can be used to display its current value.



########################################################################
(app)

(setq *TextVariable "abc")

(action
   (html 0 "+Var" "@lib.css" NIL
      (form NIL
         (gui '(+Var +TextField) '*TextVariable 8)
         (gui '(+JS +Button) "Print"
            '(msg *TextVariable) ) ) ) )
########################################################################




+E/R takes an entity/relation
specification. This is a cons pair, with a relation in its CAR (e.g.
nm, for an object's name), and an expression in its CDR (typically
(: home obj), the object stored in the obj property of
the current form).


For an isolated, simple example, we create a temporary database, and access
the nr and nm properties of an object stored in a
global variable *Obj.



########################################################################
(when (app)                # On start of session
   (class +Tst +Entity)    # Define data model
   (rel nr (+Number))      # with a number
   (rel nm (+String))      # and a string
   (pool (tmp "db"))       # Create temporary DB
   (setq *Obj              # and a single object
      (new! '(+Tst) 'nr 1 'nm "New Object") ) )

(action
   (html 0 "+E/R" "@lib.css" NIL
      (form NIL
         (gui '(+E/R +NumField) '(nr . *Obj) 8)    # Linkage to 'nr'
         (gui '(+E/R +TextField) '(nm . *Obj) 20)  # Linkage to 'nm'
         (gui '(+JS +Button) "Show"                # Show the object
            '(out 2 (show *Obj)) ) ) ) )           # on standard error
########################################################################







Buttons



Buttons are, as explained in Control Flow, the only
way (via POST requests) for an application to communicate with the server.


Basically, a +Button takes


    

  • a label, which may be either a string or the name of an image file

  • an optional alternative label, shown when the button is disabled

  • and an executable expression.




Here is a minimal button, with just a label and an expression:



   (gui '(+Button) "Label" '(doSomething))




And this is a button displaying different labels, depending on the state:



   (gui '(+Button) "Enabled" "Disabled" '(doSomething))




To show an image instead of plain text, the label(s) must be preceeded by the
T symbol:



   (gui '(+Button) T "img/enabled.png" "img/disabled.png" '(doSomething))




The expression will be executed during action handling (see Action Forms), when this button was pressed.


Like other components, buttons can be extended and combined with prefix
classes, and a variety of predefined classes and class combinations are
available.



Dialog Buttons



Buttons are essential for the handling of alerts and
dialogs. Besides buttons for normal functions, like scrolling in charts or other side
effects, special buttons exist which can close an alert or dialog in
addition to doing their principal job.


Such buttons are usually subclasses of +Close, and most of them can be called
easily with ready-made functions like closeButton, cancelButton, yesButton or noButton. We saw a few examples in Alerts and Dialogs.



Active JavaScript



When a button inherits from the +JS class (and JavaScript is enabled in the
browser), that button will possibly show a much faster response in its action.


The reason is that the activation of a +JS button will - instead of doing a normal
POST - first try to send only the contents of all GUI components via an
XMLHttpRequest to the server, and receive the updated values in response. This
avoids the flicker caused by reloading and rendering of the whole page, is much
faster, and also does not jump to the beginning of the page if it is larger than
the browser window. The effect is especially noticeable while scrolling in
charts.


Only if this fails, for example because an error message was issued, or a
dialog popped up, it will fall back, and the form will be POSTed in the normal
way.


Thus it makes no sense to use the +JS prefix for buttons that cause a change
of the HTML code, open a dialog, or jump to another page. In such cases, overall
performance will even be worse, because the XMLHttpRequest is tried first (but
in vain).


When JavaScript is disabled int the browser, the XMLHttpRequest will not be
tried at all. The form will be fully usable, though, with identical
functionality and behavior, just a bit slower and not so smooth.





A Minimal Complete Application



The PicoLisp release includes in the "app/" directory a minimal, yet complete
reference application. This application is typical, in the sense that it
implements many of the techniques described in this document, and it can be
easily modified and extended. In fact, we use it as templates for our own
production application development.


It is a kind of simplified ERP system, containing customers/suppliers,
products (items), orders, and other data. The order input form performs live
updates of customer and product selections, price, inventory and totals
calculations, and generates on-the-fly PDF documents. Fine-grained access
permissions are controlled via users, roles and permissions. It comes localized
in seven languages (English, Spanish, German, Norwegian, Swedish, Russian and
Japanese), with some initial data and two sample reports.


Since this reference application employs so many of the typical techniques
used in writing PicoLisp applications, taking the time to study it is time very
well invested. Another good way to get acquainted with the language and
framework is to start experimenting by writing small applications of your own.
Copying and making changes to the reference application is a very good way to
get started with this, and I highly recommend doing so.




Getting Started



For a global installation (see Installation),
please create a symbolic link to the place where the program files are
installed. This is necessary because the application needs read/write access to
the current working directory (for the database and other runtime data).



$ ln -s /usr/share/picolisp/app




As ever, you may start up the application in debugging mode



$ pil app/main.l -main -go +




or in (non-debug) production mode



$ pil app/main.l -main -go -wait




and go to 'http://localhost:8080' with your
browser. You can login as user "admin", with password "admin". The demo data
contain several other users, but those are more restricted in their role
permissions.


Another possibility is to try the online version of this application at app.7fach.de.



Localization



Before or after you logged in, you can select another language, and click on
the "Change" button. This will effect all GUI components (though not text from
the database), and also the numeric, date and telephone number formats.



Navigation



The navigation menu on the left side shows two items "Home" and "logout", and
three submenus "Data", "Report" and "System".


Both "Home" and "logout" bring you back to the initial login form. Use
"logout" if you want to switch to another user (say, for another set of
permissions), and - more important - before you close your browser, to release
possible locks and process resources on the server.


The "Data" submenu gives access to application specific data entry and
maintenance: Orders, product items, customers and suppliers. The "Report"
submenu contains two simple inventory and sales reports. And the "System"
submenu leads to role and user administration.


You can open and close each submenu individually. Keeping more than one
submenu open at a time lets you switch rapidly between different parts of the
application.


The currently active menu item is indicated by a highlighted list style (no
matter whether you arrived at this page directly via the menu or by clicking on
a link somewhere else).



Choosing Objects



Each item in the "Data" or "System" submenu opens a search dialog for that
class of entities. You can specify a search pattern, press the top right
"Search" button (or just ENTER), and scroll through the list of results.


While the "Role" and "User" entities present simple dialogs (searching just
by name), other entities can be searched by a variety of criteria. In those
cases, a "Reset" button clears the contents of the whole dialog. A new object
can be created with bottom right "New" button.


In any case, the first column will contain either a "@"-link (to jump to that
object) or a "@"-button (to insert a reference to that object into the current
form).


By default, the search will list all database objects with an attribute value
greater than or equal to the search criterion. The comparison is done
arithmetically for numbers, and alphabetically (case sensitive!) for text. This
means, if you type "Free" in the "City" field of the "Customer/Supplier" dialog,
the value of "Freetown" will be matched. On the other hand, an entry of "free"
or "town" will yield no hits.


Some search fields, however, show a different behavior depending on the
application:


    

  • The names of persons, companies or products allow a tolerant search,
matching either a slightly misspelled name ("Mühler" instead of "Miller") or a
substring ("Oaks" will match "Seven Oaks Ltd.").


  • The search field may specify an upper instead of a lower limit, resulting in
a search for database objects with an attribute value less than or equal to the
search criterion. This is useful, for example in the "Order" dialog, to list
orders according to their number or date, by starting with the newest then and
going backwards.





Using the bottom left scroll buttons, you can scroll through the result list
without limit. Clicking on a link will bring up the corresponding object. Be
careful here to select the right column: Some dialogs (those for "Item" and
"Order") also provide links for related entities (e.g. "Supplier").



Editing



A database object is usually displayed in its own individual form, which is
determined by its entity class.


The basic layout should be consistent for all classes: Below the heading
(which is usually the same as the invoking menu item) is the object's identifier
(name, number, etc.), and then a row with an "Edit" button on the left, and
"Delete" button, a "Select" button and two navigation links on the right side.


The form is brought up initially in read-only mode. This is necessary to
prevent more than one user from modifying an object at the same time (and
contrary to the previous PicoLisp Java frameworks, where this was not a problem
because all changes were immediately reflected in the GUIs of other users).


So if you want to modify an object, you have to gain exclusive access by
clicking on the "Edit" button. The form will be enabled, and the "Edit" button
changes to "Done". Should any other user already have reserved this object, you
will see a message telling his name and process ID.


An exception to this are objects that were just created with "New". They will
automatically be reserved for you, and the "Edit" button will show up as "Done".


The "Delete" button pops up an alert, asking for confirmation. If the object
is indeed deleted, this button changes to "Restore" and allows to undelete the
object. Note that objects are never completely deleted from the database as long
as there are any references from other objects. When a "deleted" object is
shown, its identifier appears in square brackets.


The "Select" button (re-)displays the search dialog for this class of
entities. The search criteria are preserved between invocations of each dialog,
so that you can conveniently browse objects in this context.


The navigation links, pointing left and right, serve a similar purpose. They
let you step sequentially through all objects of this class, in the order of the
identifier's index.


Other buttons, depending on the entity, are usually arranged at the bottom of
the form. The bottom rightmost one should always be another "Edit" / "Done"
button.


As we said in the chapter on Scrolling, any button
in the form will save changes to the underlying data model. As a special case,
however, the "Done" button releases the object and reverts to "Edit". Besides
this, the edit mode will also cease as soon as another object is displayed, be
it by clicking on an object link (the pencil icon), the top right navigation
links, or a link in a search dialog.



Buttons vs. Links



The only way to interact with a HTTP-based application server is to click
either on a HTML link, or on a submit button (see also Control Flow). It is essential to understand the different
effects of such a click on data entered or modified in the current form.


    

  • A click on a link will leave or reload the page. Changes are discarded.

  • A click on a button will commit changes, and perform the associated action.




For that reason the layout design should clearly differentiate between links
and buttons. Image buttons are not a good idea when in other places images are
used for links. The standard button components should be preferred; they are
usually rendered by the browser in a non-ambiguous three-dimensional look and
feel.


Note that if JavaScript is enabled in the browser, changes will be
automatically committed to the server.


The enabled or disabled state of a button is an integral part of the
application logic. It must be indicated to the user with appropriate styles.





The Data Model



The data model for this mini application consists of only six entity classes
(see the E/R diagram at the beginning of "app/er.l"):


    

  • The three main entities are +CuSu (Customer/Supplier),
+Item (Product Item) and +Ord (Order).


  • A +Pos object is a single position in an order.


  • +Role and +User objects are needed for
authentication and authorization.





The classes +Role and +User are defined in
"@lib/adm.l". A +Role has a name, a list of permissions, and a list
of users assigned to this role. A +User has a name, a password and
a role.


In "app/er.l", the +Role class is extended to define an
url> method for it. Any object whose class has such a method is
able to display itself in the GUI. In this case, the file "app/role.l" will be
loaded - with the global variable *ID pointing to it - whenever an
HTML link to this role object is activated.


The +User class is also extended. In addition to the login name,
a full name, telephone number and email address is declared. And, of course, the
ubiquitous url> method.


The application logic is centered around orders. An order has a number, a
date, a customer (an instance of +CuSu) and a list of positions
(+Pos objects). The sum> method calculates the
total amount of this order.


Each position has an +Item object, a price and a quantity. The
price in the position overrides the default price from the item.


Each item has a number, a description, a supplier (also an instance of
+CuSu), an inventory count (the number of these items that were
counted at the last inventory taking), and a price. The cnt>
method calculates the current stock of this item as the difference of the
inventory and the sold item counts.


The call to dbs at the end of "app/er.l" configures the physical
database storage. Each of the supplied lists has a number in its CAR which
determines the block size as (64 << N) of the corresponding database file.
The CDR says that the instances of this class (if the element is a class symbol)
or the tree nodes (if the element is a list of a class symbol and a property
name) are to be placed into that file. This allows for some optimizations in the
database layout.





Usage



When you are connected to the application (see Getting
Started) you might try to do some "real" work with it. Via the "Data" menu
(see Navigation) you can create or modify customers,
suppliers, items and orders, and produce simple overviews via the "Report" menu.



Customer/Supplier



Source in "app/cusu.l"


The Customer/Supplier search dialog (choCuSu in "app/gui.l")
supports a lot of search criteria. These become necessary when the database
contains a large number of customers, and can filter by zip, by phone number
prefixes, and so on.


In addition to the basic layout (see Editing), the
form is divided into four separate tabs. Splitting a form into several tabs
helps to reduce traffic, with possibly better GUI response. In this case, four
tabs are perhaps overkill, but ok for demonstration purposes, and they leave
room for extensions.


Be aware that when data were modified in one of the tabs, the "Done" button
has to be pressed before another tab is clicked, because tabs are implemented as
HTML links (see Buttons vs. Links).


New customers or suppliers will automatically be assigned the next free
number. You can enter another number, but an error will result if you try to use
an existing number. The "Name" field is mandatory, you need to overwrite the
"<Name>" clue.


Phone and fax numbers in the "Contact" tab must be entered in the correct
format, depending on the locale (see Telephone
Numbers).


The "Memo" tab contains a single text area. It is no problem to use it for
large pieces of text, as it gets stored in a database blob internally.


The general layout of cusu.l is quite similar to the other
source files making up the demo application. Since this is such a typical way of
structuring PicoLisp applications, let's have a more detailed look. The
beginning of cusu.l looks like this:



########################################################################
(must "Customer/Supplier" Customer)

(menu ,"Customer/Supplier"
   (idForm ,"Customer/Supplier" '(choCuSu) 'nr '+CuSu T '(may Delete)
      '((: nr) " -- " (: nm))
      ....
########################################################################




The first line checks whether the user has the right permissions to access
this page. After that a call to a function called (menu) follows.
This function is defined in app/gui.l and creates the menu and
basic page layout used in this application. Nested within the call to
(menu) is our first, direct, encounter with a form function. In
this case it is a call to (idForm). Let us look a little closer at
this call.


The first parameter, "Customer/Supplier", is used in the form heading.
Parameter number two is interesting. '(choCuSu) creates a dialog
that makes is possible to search for an existing object to display/ edit, or
create a new one. (choCuSu) is defined in app/gui.l
and uses another form function, called (diaform). An abbreviated version is
shown below.



########################################################################
(de choCuSu (Dst)
   (diaform '(Dst)
      (<grid> "--.-.-."
         # Form components
         ... )
      (gui 'query '(+QueryChart) (cho)
         # Pilog query
         9
         '((This) (list This (: nr) This (: nm2) (: em) (: plz) (: ort) (: tel) (: mob))) )
      (<table> 'chart (choTtl ,"Customers/Suppliers" 'nr '+CuSu)
         # Table headers
         (do (cho)
            (<row> (alternating)
               (gui 1 '(+DstButton) Dst)
               ...
               (gui 9 '(+TelField)) ) ) )
      (<spread>
         (scroll (cho))
         (newButton T Dst '(+CuSu) ...)
         (cancelButton) ) ) )
########################################################################




(choCuSu) starts off by calling (diaform). This function is used when
we want a form to behave in a similar way to a dialog (See Alerts and Dialogs for a description of how dialogs
work in this framework). The first part of our diaform is a
(<grid>) containing some form components.


The grid is followed by another gui component, this time a +QueryChart. The chart is an
interesting, and very useful, concept. The basic idea is to separate how data is
presented in the gui from the internal representation. See charts for more information.


The +QueryChart uses a
Pilog query to fetch the data we wish to show from
the database. This part is followed by a number, in this case 9, which tells the
Chart how many columns of data to expect. The final part is a function that
takes care of putting data into the gui from the
dataset retrieved by the Pilog query. A table is used to present the result. The
number of columns in this table must match the number mentioned above, the one
that tells the chart how many columns to expect.


What is here is a common way of structuring applications in PicoLisp. Objects
are displayed and edited using (idForm), which in turn use (diaform) to select or create new
objects to view or edit.


Item



Source in "app/item.l"


Items also have a unique number, and a mandatory "Description" field.


To assign a supplier, click on the "+" button. The Customer/Supplier search
dialog will appear, and you can pick the desired supplier with the "@" button in
the first column. Alternatively, if you are sure to know the exact spelling of
the supplier's name, you can also enter it directly into the text field.


In the search dialog you may also click on a link, for example to inspect a
possible supplier, and then return to the search dialog with the browser's back
button. The "Edit" mode will then be lost, however, as another object has been
visited (this is described in the last part of Editing).


You can enter an inventory count, the number of items currently in stock. The
following field will automatically reflect the remaining pieces after some of
these items were sold (i.e. referenced in order positions). It cannot be changed
manually.


The price should be entered with the decimal separator according to the
current locale. It will be formatted with two places after the decimal
separator.


The "Memo" is for an arbitrary info text, like in Customer/Supplier above, stored in a database blob.


Finally, a JPEG picture can be stored in a blob for this item. Choose a file
with the browser's file select control, and click on the "Install" button. The
picture will appear at the bottom of the page, and the "Install" button changes
to "Uninstall", allowing the picture's removal.



Order



Source in "app/ord.l"


Oders are identified by number and date.


The number must be unique. It is assigned when the order is created, and
cannot be changed for compliance reasons.


The date is initialized to "today" for a newly created order, but may be
changed manually. The date format depends on the locale. It is YYYY-MM-DD (ISO)
by default, DD.MM.YYYY in the German and YYYY/MM/DD in the Japanese locale. As
described in Time & Date, this field allows
input shortcuts, e.g. just enter the day to get the full date in the current
month.


To assign a customer to this order, click on the "+" button. The
Customer/Supplier search dialog will appear, and you can pick the desired
customer with the "@" button in the first column (or enter the name directly
into the text field), just as described above for Items.


Now enter order the positions: Choose an item with the "+" button. The
"Price" field will be preset with the item's default price, you may change it
manually. Then enter a quantity, and click a button (typically the "+" button to
select the next item, or a scroll button go down in the chart). The form will be
automatically recalculated to show the total prices for this position and the
whole order.


Instead of the "+" or scroll buttons, as recommended above, you could of
course also press the "Done" button to commit changes. This is all right, but
has the disadvantage that the button must be pressed a second time (now "Edit")
if you want to continue with the entry of more positions.


The "x" button at the right of each position deletes that position without
further confirmation. It has to be used with care!


The "^" button is a "bubble" button. It exchanges a row with the row above it.
Therefore, it can be used to rearrange all items in a chart, by "bubbling" them
to their desired positions.


The "PDF-Print" button generates and displays a PDF document for this order.
The browser should be configured to display downloaded PDF documents in an
appropriate viewer. The source for the postscript generating method is in
"app/lib.l". It produces one or several A4 sized pages, depending on the number
of positions.



Reports



Sources in "app/inventory.l and "app/sales.l"


The two reports ("Inventory" and "Sales") come up with a few search fields
and a "Show" button.


If no search criteria are entered, the "Show" button will produce a listing
of the relevant part of the whole database. This may take a long time and cause
a heavy load on the browser if the database is large.


So in the normal case, you will limit the domain by stating a range of item
numbers, a description pattern, and/or a supplier for the inventory report, or a
range of order dates and/or a customer for the sales report. If a value in a
range specification is omitted, the range is considered open in that direction.


At the end of each report appears a "CSV" link. It downloads a file with the
TAB-separated values generated by this report.



picoLisp/doc/select.html0000644000175000017500000004357413406174616013677 0ustar  abuabu



The 'select' Predicate



abu@software-lab.de


The 'select' Predicate



(c) Software Lab. Alexander Burger


The Pilog select/3 predicate is rather complex, and quite
different from other predicates. This document tries to explain it in detail,
and shows some typical use cases.








Syntax



select takes at least three arguments:


    

  • A list of unification variables,

  • a list of generator clauses

  • and an arbitrary number of filter clauses




We will describe these arguments in the following, but demonstrate them first
on a concrete example.





First Example



The examples in this document will use the demo application in "app/*.l" (see
also "A Minimal Complete Application"). To get an
interactive prompt, start it as



$ pil app/main.l -main +
:




As ever, you can terminate the interpreter by hitting Ctrl-D.


For a first, typical example, let's write a complete call to solve that returns a list of articles with numbers
between 1 and 4, which contain "Part" in their description, and have a price
less than 100:



(let (Nr (1 . 4)  Nm "Part"  Pr '(NIL . 100.00))
   (solve
      (quote
         @Nr Nr
         @Nm Nm
         @Pr Pr
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))
               (range @Nr @Item nr)
               (part @Nm @Item nm)
               (range @Pr @Item pr) ) )
      @Item ) )




This expression will return, with the default database setup of "app/init.l",
a list of exactly one item ({3-2}), the item with the number 2.


The let statement assigns values to
the search parameters for number Nr, description Nm
and price Pr. The Pilog query (the first argument to
solve) passes these values to the Pilog variables @Nr,
@Nm and @Pr. Ranges of values are always specified by
cons pairs, so (1 . 4) includes the numbers 1 through 4, while
(NIL . 100.00) includes prices from minus infinite up to one
hundred.


The list of unification variables is



   (@Item)




The list of generator clauses is



      ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))




The filter clauses are



         (range @Nr @Item nr)
         (part @Nm @Item nm)
         (range @Pr @Item pr)







Unification Variables



As stated above, the first argument to select should be a list
of variables. These variables communicate values (via unify) from the select
environment to the enclosing Pilog environment.


The first variable in this list (@Item in the above example) is
mandatory, it takes the direct return value of select. Additional
optional variables may be unified by clauses in the body of select,
and return further values.





Generator Clauses



The second argument to select is a list of "generator clauses".
Each of these clauses specifies some kind of database B-Tree +index, to be traversed by
select, step by step, where each step returns a suitable single
database object. In the simplest case, they consist like here just of a relation
name (e.g. nr), a class (e.g. +Item), an optional hook
specifier (not in this example), and a pattern (values or ranges, e.g. (1 . 4)
or "Part").


The generator clauses are the core of 'select'. In some way, they behave
analog to or/2, as each of them
generates a sequence of values. However, the generator clauses behave different,
as they will not generate an exhaustive set of values upon backtracking, one
after the other, where the next gets its turn when the previous one is
exhausted. Instead, all clauses will generate their values quasi-parallel, with
a built-in optimization so that successful clauses will be called with a higher
probability. "Successful" means that the returned values successfully pass
select's filter clauses.





B-Tree Stepping



In its basic form, a generator clause is equivalent to the db/3 predicate, stepping through a single
B-Tree. The clause



(nr +Item @Nr)




generates the same values as would be produced by a stand-alone Pilog clause



(db nr +Item @Nr @Item)




as can be seen in the following two calls:



: (? (db nr +Item (1 . 4) @Item))
 @Item={3-1}
 @Item={3-2}
 @Item={3-3}
 @Item={3-4}
-> NIL
: (? (select (@Item) ((nr +Item (1 . 4)))))
 @Item={3-1}
 @Item={3-2}
 @Item={3-3}
 @Item={3-4}
-> NIL







Interaction of Generator Clauses



select is mostly useful if more than one generator clause is
involved. The tree search parameters of all clauses are meant to form a logical
AND. Only those objects should be returned, for which all search
parameters (and the associated filter clauses) are valid. As soon as one of the
clauses finishes stepping through its database (sub)tree, the whole call to
select will terminate, because further values returned from other
generator clauses cannot be part of the result set.


Therefore, select would find all results most quickly if it
could simply call only the generator clause with the smallest (sub)tree.
Unfortunately, this is usually not known in advance. It depends on the
distribution of the data in the database, and on the search parameters to each
generator clause.


Instead, select single-steps each generator clause in turn, in a
round-robin scheme, applies the filter clauses to each generated object, and
re-arranges the order of generator clauses so that the more successful clauses
will be preferred. This process usually converges quickly and efficiently.





Combined Indexes



A generator clause can also combine several (similar) indexes into a single
one. Then the clause is written actually as a list of clauses.


For example, a generator clause to search for a customer by phone number is



(tel +CuSu @Tel)



If we want to search for a customer without knowing whether a given number is a
normal or a mobile phone number, then a combined generator clause searching both
index trees could look like



((tel +CuSu @Tel  mob +CuSu @Tel))




The generator will first traverse all matching entries in the +Ref tree of the tel relation, and
then, when these are exhausted, all matching entries in the mob
index tree.





Indirect Object Associations



But generator clauses are not limited to the direct B-Tree interaction of
db/3. They can also traverse trees of
associated objects, and then follow +Link / +Joint relations, or tree relations like
+Ref to arrive at database objects
with a type suitable for return values from select.


To locate appropriate objects from associated objects, the generator clause
can contain - in addition to the standard relation/class/pattern specification
(see Generator Clauses above) - an arbitrary number of
association specifiers. Each association specifier can be


    

  1. A symbol. Then a +Link or
+Joint will be followed, or a
+List of those will be traversed to
locate appropriate objects.


  2. A list. Then this list should hold a relation and a class (and an optional
hook) which specify some B-Tree +index to be traversed to locate appropriate
objects.




In this way, a single generator clause can cause the traversal of a tree of
object relations to generate the desired sequence of objects.

An example can be found in "app/gui.l", in the 'choOrd' function which
implements the search dialog for +Ord (order) objects. Orders can
be searched for order number and date, customer name and city, item description
and supplier name:



(select (@@)
   ((nr +Ord @Nr) (dat +Ord @Dat)
      (nm +CuSu @Cus (cus +Ord))
      (ort +CuSu @Ort (cus +Ord))
      (nm +Item @Item (itm +Pos) ord)
      (nm +CuSu @Sup (sup +Item) (itm +Pos) ord) )




While (nr +Ord @Nr) and (dat +Ord @Dat) are direct
index traversals, (nm +CuSu @Cus (cus +Ord)) iterates the
nm (name) index of customers/suppliers +CuSu, and then
follows the +Ref +Link of the cus relation to the
orders. The same applies to the search for city names via ort.


The most complex example is (nm +CuSu @Sup (sup +Item) (itm +Pos)
ord), where the supplier name is searched in the nm tree of
+CuSu, then the +Ref tree
(sup +Item) tree is followed to locate items of that supplier, then
all positions for those items are found using (itm +Pos), and
finally the ord +Joint
is followed to arrive at the order object(s).





Nested Pilog Queries



In the most general case, a generator clause can be an arbitrary Pilog query.
Often this is a query to a database on a remote machine, using the remote/2 predicate, or some other resource
not accessible via database indexes, like iterating a +List of +Links or +Joints.


Syntactically, such a generator clause is recognized by the fact that its CAR
is a Pilog variable to denote the return value.


The second argument is a list of Pilog variables to communicate values (via
unify) from the surrounding
select environment.


The third argument is the actual list of clauses for the nested query.


Finally, an arbitrary number of association specifiers may follow, as
described in the Indirect Object Associations
section.


We can illustrate this with a somewhat useless (but simple) example, which
replaces the standard generators for item number and supplier name



(select (@Item)
   ((nr +Item @Nr) (nm +CuSu @Sup (sup +Item)))
   ...




with the equivalent form



(select (@Item)
   ((@A (@Nr) ((db nr +Item @Nr @A)))
      (@B (@Sup) ((db nm +CuSu @Sup @B)) (sup +Item)) )




That is, a query with the db/3 tree
iteration predicate is used to generate appropriate values.





Filter Clauses



The generator clauses produce - independent from each other - lots of
objects, which match the patterns of individual generator clauses, but not
necessarily the desired result set of the total select call.
Therefore, the filter clauses are needed to retain the good, and throw away the
bad objects. In addition, they give feedback to the generator for optimizing its
traversal priorities (as described in Generator Clauses).


select then collects all objects which passed through the
filters into a unique list, to avoid duplicates which would otherwise appear,
because most objects can be found by more than one generator clause.


Technically, the filters are normal Pilog clauses, which just happen to be
evaluated in the context of select. Arbitrary Pilog predicates can
be used, though there exist some predicates (e.g. isa/2, same/3, bool/3, range/3, head/3, fold/3, part/3 or tolr/3) especially suited for that task.





A Little Report



Assume we want to know how many pieces of item #2 were sold in the year 2007.
Then we must find all +Pos (position) objects referring to that
item and at the same time belonging to orders of the year 2007 (see the class
definition for +Pos in "app/er.l"). The number of sold pieces is
then in the cnt property of the +Pos objects.


As shown in the complete select below, we will hold the item
number in the variable @Nr and the date range for the year in
@Year.


Now, all positions referred by item #2 can be found by the generator clause



(nr +Item @Nr (itm +Pos))




and all positions sold in 2007 can be found by



(dat +Ord @Year pos)




However, the combination of both generator clauses



(select (@Pos)
   ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos)) )




will probably generate too many results, namely all positions with item #2
OR from the year 2007. Thus, we need two filter clauses. With them, the
full search expression will be:



(?
   @Nr 2                                                 # Item number
   @Year (cons (date 2007 1 1) (date 2007 12 31))        # Date range 2007
   (select (@Pos)
      ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))   # Generator clauses
      (same @Nr @Pos itm nr)                             # Filter item number
      (range @Year @Pos ord dat) ) )                     # Filter order date




For completeness, let's calculate the total count of sold items:



(let Cnt 0     # Counter variable
   (pilog
      (quote
         @Nr 2
         @Year (cons (date 2007 1 1) (date 2007 12 31))
         (select (@Pos)
            ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))
            (same @Nr @Pos itm nr)
            (range @Year @Pos ord dat) ) )
      (inc 'Cnt (get @Pos 'cnt)) )  # Increment total count
   Cnt )  # Return count







Filter Predicates



As mentioned under Filter Clauses, some predicates
exists mainly for select filtering.


Some of these predicates are of general use: isa/2 can be used to check for a type,
same/3 checks for a definite value,
bool/3 looks if the value is
non-NIL. These predicates are rather independent of the +relation type.


range/3 checks whether a value
is within a given range. This could be used with any +relation type, but typically it will be
used for numeric (+Number) or time
( +Date and +Time) relations.


Other predicates make only sense in the context of a certain +relation type:






picoLisp/doc/native.html0000644000175000017500000006604013134567502013675 0ustar  abuabu



Native C Calls



abu@software-lab.de


Native C Calls



(c) Software Lab. Alexander Burger


This document describes how to call C functions in shared object files
(libraries) from PicoLisp, using the built-in native function - possibly with the help of
the struct and lisp functions. It applies only to the 64-bit
version of PicoLisp.








Overview



native calls a C function in a shared library. It tries to


    

  1. find a library by name

  2. find a function by name in the library

  3. convert the function's argument(s) from Lisp to C structures

  4. call the function's C code

  5. convert the function's return value(s) from C to Lisp structures




The direct return value of native is the Lisp representation of
the C function's return value. Further values, returned by reference from the C
function, are available in Lisp variables (symbol values).


struct is a helper function, which can be used to manipulate C
data structures in memory. It may take a scalar (a numeric representation of a C
value) to convert it to a Lisp item, or (more typically) a pointer to a memory
area to build and extract data structures. lisp allows you to
install callback functions, callable from C code, written in Lisp.


In combination, these three functions can interface PicoLisp to almost any C
function.


The above steps are fully dynamic; native doesn't have (and
doesn't require) a priory knowledge about the library, the function or the
involved data. No need to write any glue code, interfaces or include files. All
functions can even be called interactively from the REPL.





Syntax



The arguments to native are


    

  1. a library

  2. a function

  3. a return value specification

  4. optional arguments




The simplest form is a call to a function without return value and without
arguments. If we assume a library "lib.so", containing a function with the
prototype



void fun(void);




then we can call it as



(native "lib.so" "fun")







Libraries



The first argument to native specifies the library. It is either
the name of a library (a symbol), or the handle of a previously
found library (a number).


As a special case, a transient symbol "@" can be passed for the
library name. It then refers to the current main program (instead of an external
library), and can be used for standard functions like "malloc" or
"printf".


native uses dlopen(3) internally to find and open
the library, and to obtain the handle. If the name contains a slash ('/'), then
it is interpreted as a (relative or absolute) pathname. Otherwise, the dynamic
linker searches for the library according to the system's environment and
directories. See the man page of dlopen(3) for further details.


If called with a symbolic argument, native automatically caches
the handle of the found library in the value of that symbol. The most natural
way is to pass the library name as a transient
symbol ("lib.so" above): The initial value of a transient symbol is
that symbol itself, so that native receives the library name upon
the first call. After successfully finding and opening the library,
native stores the handle of that library in the value of the passed
symbol ("lib.so"). As native evaluates its arguments
in the normal way, subsequent calls within the same transient scope will receive
the numeric value (the handle), and don't need to open and search the library
again.





Functions



The same rules applies to the second argument, the function. When called with
a symbol, native stores the function pointer in its value, so that
subsequent calls evaluate to that pointer, and native can directly
jump to the function.


native uses dlsym(3) internally to obtain the
function pointer. See the man page of dlsym(3) for further details.


In most cases a program will call more than one function from a given
library. If we keep the code within the same transient scope (i.e. in the same
source file, and not separated by the ==== function), each library will be opened -
and each function searched - only once.



(native "lib.so" "fun1")
(native "lib.so" "fun2")
(native "lib.so" "fun3")




After "fun1" was called, "lib.so" will be open, and
won't be re-opened for "fun2" and "fun3". Consider
the definition of helper functions:



(de fun1 ()
   (native "lib.so" "fun1") )

(de fun2 ()
   (native "lib.so" "fun2") )

(de fun3 ()
   (native "lib.so" "fun3") )




After any one of fun1, fun2 or fun3
was called, the symbol "lib.so" will hold the library handle. And
each function "fun1", "fun2" and "fun3"
will be searched only when called the first time.


Warning: It should be avoided to put more than one library into a single
transient scope if there is a chance that two different functions with the same
name will be called in two different libraries. Because of the function pointer
caching, the second call would otherwise (wrongly) go to the first function.






Return Value



The (optional) third argument to native specifies the return
value. A C function can return many types of values, like integer or floating
point numbers, string pointers, or pointers to structures which in turn consist
of those types, and even other structures or pointers to structures.
native tries to cover most of them.


As described in the result specification,
the third argument should consist of a pattern which tells native
how to extract the proper value.



Primitive Types



In the simplest case, the result specification is NIL like in
the examples so far. This means that either the C function returns
void, or that we are not interested in the value. The return value
of native will be NIL in that case.


If the result specification is one of the symbols B,
I or N, an integer number is returned, by interpreting
the result as a char (8 bit unsigned byte), int (32
bit signed integer), or long number (64 bit signed integer),
respectively. Other (signed or unsigned numbers, and of different sizes) can be
produced from these types with logical and arithmetic operations if necessary.


If the result specification is the symbol C, the result is
interpreted as a 16 bit number, and a single-char transient symbol (string) is
returned.


A specification of S tells native to interpret the
result as a pointer to a C string (null terminated), and to return a transient
symbol (string).


If the result specification is a number, it will be used as a scale to
convert a returned double (if the number is positive) or
float (if the number is negative) to a scaled fixpoint number.


Examples for function calls, with their corresponding C prototypes:



(native "lib.so" "fun" 'I)             # int fun(void);
(native "lib.so" "fun" 'N)             # long fun(void);
(native "lib.so" "fun" 'N)             # void *fun(void);
(native "lib.so" "fun" 'S)             # char *fun(void);
(native "lib.so" "fun" 1.0)            # double fun(void);





Arrays and Structures



If the result specification is a list, it means that the C function returned
a pointer to an array, or an arbitrary memory structure. The specification list
should then consist of either the above primitive specifications (symbols or
numbers), or of cons pairs of a primitive specification and a repeat count, to
denote arrays of the given type.


Examples for function calls, with their corresponding pseudo C prototypes:



(native "lib.so" "fun" '(I . 8))       # int *fun(void);  // 8 integers
(native "lib.so" "fun" '(B . 16))      # unsigned char *fun(void);  // 16 bytes

(native "lib.so" "fun" '(I I))         # struct {int i; int j;} *fun(void);
(native "lib.so" "fun" '(I . 4))       # struct {int i[4];} *fun(void);

(native "lib.so" "fun" '(I (B . 4)))   # struct {
                                       #    int i;
                                       #    unsigned char c[4];
                                       # } *fun(void);

(native "lib.so" "fun"                 # struct {
   '(((B . 4) I) (S . 12) (N . 8)) )   #    struct {unsigned char c[4]; int i;}
                                       #    char *names[12];
                                       #    long num[8];
                                       # } *fun(void);




If a returned structure has an element which is a pointer to some
other structure (i.e. not an embedded structure like in the last example above),
this pointer must be first obtained with a N pattern, which can
then be passed to struct for further
extraction.





Arguments



The (optional) fourth and following arguments to native specify
the arguments to the C function.



Primitive Types



Integer arguments (up to 64 bits, signed or unsigned char,
short, int or long) can be passed as they
are: As numbers.



(native "lib.so" "fun" NIL 123)        # void fun(int);
(native "lib.so" "fun" NIL 1 2 3)      # void fun(int, long, short);




String arguments can be specified as symbols. native allocates
memory for each string (with strdup(3)), passes the pointer to the
C function, and releases the memory (with free(3)) when done.



(native "lib.so" "fun" NIL "abc")      # void fun(char*);
(native "lib.so" "fun" NIL 3 "def")    # void fun(int, char*);




Note that the allocated string memory is released after the return
value is extracted. This allows a C function to return the argument string
pointer, perhaps after modifying the data in-place, and receive the new string
as the return value (with the S specification).



(native "lib.so" "fun" 'S "abc")       # char *fun(char*);




Also note that specifying NIL as an argument passes an empty
string ("", which also reads as NIL in PicoLisp) to the C function.
Physically, this is a pointer to a NULL-byte, and is not a NULL-pointer.
Be sure to pass 0 (the number zero) if a NULL-pointer is desired.


Floating point arguments are specified as cons pairs, where the value is in
the CAR, and the CDR holds the fixpoint scale. If the scale is positive, the
number is passed as a double, otherwise as a float.



(native "lib.so" "fun" NIL             # void fun(double, float);
   (12.3 . 1.0) (4.56 . -1.0) )





Arrays and Structures



Composite arguments are specified as nested list structures.
native allocates memory for each array or structure (with
malloc(3)), passes the pointer to the C function, and releases the
memory (with free(3)) when done.


This implies that such an argument can be both an input and an output value
to a C function (pass by reference).


The CAR of the argument specification can be NIL (then it is an
input-only argument). Otherwise, it should be a variable which receives the
returned structure data.


The CADR of the argument specification must be a cons pair with the total
size of the structure in its CAR. The CDR is ignored for input-only arguments,
and should contain a result specification for
the output value to be stored in the variable.


For example, a minimal case is a function that takes an integer reference,
and stores the number '123' in that location:



void fun(int *i) {
   *i = 123;
}




We call native with a variable X in the CAR of the
argument specification, a size of 4 (i.e. sizeof(int)), and
I for the result specification. The stored value is then available
in the variable X:



: (native "lib.so" "fun" NIL '(X (4 . I)))
-> NIL
: X
-> 123




The rest (CDDR) of the argument specification may contain initialization
data, if the C function expects input values in the structure. It should be a
list of initialization items, optionally with a
fill-byte value in the CDR of the last cell.


If there are no initialization items and just the final fill-byte,
then the whole buffer is filled with that byte. For example, to pass a buffer of
20 bytes, initialized to zero:



: (native "lib.so" "fun" NIL '(NIL (20) . 0))




A buffer of 20 bytes, with the first 4 bytes initialized to 1, 2, 3, and 4,
and the rest filled with zero:



: (native "lib.so" "fun" NIL '(NIL (20) 1 2 3 4 . 0))




and the same, where the buffer contents are returned as a list of bytes in
the variable X:



: (native "lib.so" "fun" NIL '(X (20 B . 20) 1 2 3 4 . 0))




For a more extensive example, let's use the following definitions:



typedef struct value {
   int x, y;
   double a, b, c;
   int z;
   char nm[4];
} value;

void fun(value *val) {
   printf("%d %d\n", val->x, val->y);
   val->x = 3;
   val->y = 4;
   strcpy(val->nm, "OK");
}




We call this function with a structure of 40 bytes, requesting the returned
data in V, with two integers (I . 2), three doubles
(100 . 3) with a scale of 2 (1.0 = 100), another integer
I and four characters (C . 4). If the structure gets
initialized with two integers 7 and 6, three doubles 0.11, 0.22 and 0.33, and
another integer 5 while the rest of the 40 bytes is cleared to zero



: (native "lib.so" "fun" NIL
   '(V (40 (I . 2) (100 . 3) I (C . 4)) -7 -6 (100 11 22 33) -5 . 0) )




then it will print the integers 7 and 6, and V will contain the
returned list



((3 4) (11 22 33) 5 ("O" "K" NIL NIL))




i.e. the original integer values 7 and 6 replaced with 3 and 4.


Note that the allocated structure memory is released after the return
value is extracted. This allows a C function to return the argument structure
pointer, perhaps after modifying the data in-place, and receive the new
structure as the return value - instead of (or even in addition to) to the
direct return via the argument reference.





Memory Management



The preceding Arguments section mentions that
native implicitly allocates and releases memory for strings, arrays
and structures.


Technically, this mimics automatic variables in C.


For a simple example, let's assume that we want to call read(2)
directly, to fetch a 4-byte integer from a given file descriptor. This could be
done with the following C function:



int read4bytes(int fd) {
   char buf[4];

   read(fd, buf, 4);
   return *(int*)buf;
}




buf is an automatic variable, allocated on the stack, which
disappears when the function returns. A corresponding native call
would be:



(native "@" "read" 'N Fd '(Buf (4 . I)) 4)




The structure argument (Buf (4 . I)) says that a space of 4
bytes should be allocated and passed to read, then an integer
I returned in the variable Buf (the return value of
native itself is the number returned by read). The
memory space is released after that.


(Note that we use "@" for the library here, as read
resides in the main program.)


Instead of a single integer, we might want a list of four bytes to be
returned from native:



(native "@" "read" 'N Fd '(Buf (4 B . 4)) 4)




The difference is that we wrote (B . 4) (a list of 4 bytes)
instead of I (a single integer) for the result specification (see the Arrays and Structures section).


Let's see what happens if we extend this example. We'll write the four bytes
to another file descriptor, after reading them from the first one:



void copy4bytes(int fd1, int fd2) {
   char buf[4];

   read(fd1, buf, 4);
   write(fd2, buf, 4);
}




Again, buf is an automatic variable. It is passed to both
read and write. A direct translation would be:



(native "@" "read" 'N Fd '(Buf (4 B . 4)) 4)
(native "@" "write" 'N Fd (cons NIL (4) Buf) 4)




This work as expected. read returns a list of four bytes in
Buf. The call to cons builds the structure



(NIL (4) 1 2 3 4)




i.e. no return variable, a four-byte memory area, filled with the four bytes
(assuming that read returned 1, 2, 3 and 4). Then this structure is
passed to write.


But: This solution induces quite some overhead. The four-byte buffer is
allocated before the call to read and released after that, then
allocated and released again for write. Also, the bytes are
converted to a list to be stored in Buf, then that list is extended
for the structure argument to write, and converted again back to
the raw byte array. The data in the list itself are never used.


If the above operation is to be used more than once, it is better to allocate
the buffer manually, use it for both reading and writing, and then release it.
This also avoids all intermediate list conversions.



(let Buf (native "@" "malloc" 'N 4) # Allocate memory
   (native "@" "read" 'N Fd Buf 4)  # (Possibly repeat this several times)
   (native "@" "write" 'N Fd Buf 4)
   (native "@" "free" NIL Buf) )    # Release memory





Fast Fourier Transform



For a more typical example, we might call the Fast Fourier Transform using
the library from the FFTW package. With the
example code for calculating Complex One-Dimensional DFTs:



#include <fftw3.h>
...
{
   fftw_complex *in, *out;
   fftw_plan p;
   ...
   in = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
   out = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
   p = fftw_plan_dft_1d(N, in, out, FFTW_FORWARD, FFTW_ESTIMATE);
   ...
   fftw_execute(p); /* repeat as needed */
   ...
   fftw_destroy_plan(p);
   fftw_free(in); fftw_free(out);
}




we can build the following equivalent:



(load "@lib/math.l")

(de FFTW_FORWARD . -1)
(de FFTW_ESTIMATE . 64)

(de fft (Lst)
   (let
      (Len (length Lst)
         In (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
         Out (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
         P (native "libfftw3.so" "fftw_plan_dft_1d" 'N
            Len In Out FFTW_FORWARD FFTW_ESTIMATE ) )
      (struct In NIL (cons 1.0 (apply append Lst)))
      (native "libfftw3.so" "fftw_execute" NIL P)
      (prog1
         (struct Out (make (do Len (link (1.0 . 2)))))
         (native "libfftw3.so" "fftw_destroy_plan" NIL P)
         (native "libfftw3.so" "fftw_free" NIL Out)
         (native "libfftw3.so" "fftw_free" NIL In) ) ) )




This assumes that the argument list Lst is passed as a list
of complex numbers, each as a list of two numbers for the real and imaginary
part, like



(fft '((1.0 0) (1.0 0) (1.0 0) (1.0 0) (0 0) (0 0) (0 0) (0 0)))




The above translation to Lisp is quite straightforward. After the two buffers
are allocated, and a plan is created, struct is called to store the argument list
in the In structure as a list of double numbers (according to the
1.0 initialization item). Then
fftw_execute is called, and struct is called again to
retrieve the result from Out and return it from fft
via the prog1. Finally, all memory is
released.



Constant Data



If such allocated data (strings, arrays or structures passed to
native) are constant during the lifetime of a program, it makes
sense to allocate them only once, before their first use. A typical candidate is
the format string of a printf call. Consider a function which
prints a floating point number in scientific notation:



(load "@lib/math.l")

: (de prf (Flt)
   (native "@" "printf" NIL "%e^J" (cons Flt 1.0)) )
-> prf

: (prf (exp 12.3))
2.196960e+05




As we know that the format string "%e^J" will be converted from
a Lisp symbol to a C string with strdup - and then thrown away - on
each call to prf, we might as well perform a little optimization
and delegate this conversion to the program load time:



: (de prf (Flt)
   (native "@" "printf" NIL `(native "@" "strdup" 'N "%e^J") (cons Flt 1.0)) )
-> prf

: (prf (exp 12.3))
2.196960e+05




If we look at the prf function, we see that it now contains the
pointer to the allocated string memory:



: (pp 'prf)
(de prf (Flt)
   (native "@" "printf" NIL 24662032 (cons Flt 1000000)) )
-> prf




This pointer will be used by printf directly, without any
further conversion or memory management.





Callbacks



Sometimes it is necessary to do the reverse: Call Lisp code from C code. This
can be done in two ways - with certain limitations.



Call by Name



The first way is actually not a callback
in the strict sense. It just allows to call a Lisp function with a given name.


The limitation is that this function can accept only maximally five numeric
arguments, and returns a number.


The prerequisite is, of course, that you have access to the C source code. To
use it from C, insert the following prototype somewhere before the first call:



long lisp(char*,long,long,long,long,long);




Then you can call lisp from C:



long n = lisp("myLispFun", a, b, 0, 0, 0);




The first argument should be the name of a Lisp function (built-in, or
defined in Lisp). It is searched for at runtime, so it doesn't need to exist at
the time the C library is compiled or loaded.


Be sure to pass dummy arguments (e.g. zero) if your function expects less
than five arguments, to keep the C compiler happy.


This mechanism can generally be used for any type of argument and return
value (not only long). On the C side, appropriate casts or an
adapted prototype should be used. It is then up to the called Lisp function to
prepare and/or extract the proper data with struct and memory management operations.



Function Pointer



This is a true callback
mechanism. It uses the Lisp-level function lisp (not to confuse with the C-level function
with the same name in the previous section). No C source code access is
required.


lisp returns a function pointer, which can be passed to C
functions via native. When this function pointer is dereferenced
and called from the C code, the corresponding Lisp function is invoked. Here,
too, only five numeric arguments and a numeric return value can be used, and
other data types must be handled by the Lisp function with struct and memory management operations.


Callbacks are often used in user interface libraries, to handle key-, mouse-
and other events. Examples can be found in "@lib/openGl.l". The
following function mouseFunc takes a Lisp function, installs it
under the tag mouseFunc (any other tag would be all right too) as a
callback, and passes the resulting function pointer to the OpenGL
glutMouseFunc() function, to set it as a callback for the current
window:



(de mouseFunc (Fun)
   (native `*GlutLib "glutMouseFunc" NIL (lisp 'mouseFunc Fun)) )




(The global *GlutLib holds the library
"/usr/lib/libglut.so". The backquote (`) is important
here, so that the transient symbol with the library name (and not the global
*GlutLib) is evaluated by native, resulting in the
proper library handle at runtime).


A program using OpenGL may then use mouseFunc to install a
function



(mouseFunc
   '((Btn State X Y)
      (do-something-with Btn State X Y) ) )




so that future clicks into the window will pass the button, state and
coordinates to that function.



picoLisp/doc/httpGate.html0000600000175000017500000002077513476652257014177 0ustar  abuabu



The 'httpGate' Proxy Server



mattias@inogu.se


The 'httpGate' Proxy Server



(c) Software Lab. Mattias Sundblad


This document describes the httpGate utility which is included
in the PicoLisp distribution.


For basic information about the PicoLisp system please look at the PicoLisp Reference and the PicoLisp
Tutorial.







Purpose



httpGate is a central element of the PicoLisp application server
architecture. Its purpose is to perform the following tasks:


    

  • Provide a single application entry port (e.g. 80 or 443).

  • Allow PicoLisp applications to run as non-root.

  • Start application servers on demand.

  • Handle HTTPS/SSL communication.




Basic functionality



A HTTP request to port 80, respectively 443, of the form



   http[s]://server.org/12345/path/file




is forwarded to a server on localhost listening on port 12345, to ask for the
resource "path/file".


If httpGate was started with a config file, and that file contains an entry
for "app", then also the following request is accepted:



   http[s]://server.org/app/path/file




In that case, the "app" server process is started automatically (if it is not
already running) listening on port 12345, and the request is forwarded as above.


Only GET and POST requests will be forwarded, and only to ports >= 1024.
The main httpGate process then forks two child processes, one for each
direction. These child processes terminate automatically if the connection is
idle for more than 7 minutes.


Building httpGate



httpGate is delivered in source code form with the picoLisp distribution. To
build the program you need a c compiler and related header files. Development
headers for OpenSSL are also needed. On Debian based systems, the prerequisites
can be fulfilled by running apt-get install build-essential and
apt-get install libssl-dev. 
Next, go to the 'src' directory in
the distribution and run make gate. When this is done, there should
be an httpGate executable in the 'bin' directory.


Running httpGate



The simplest way to run httpGate is to start it with an explicit port
argument:



   bin/httpGate 80 8080
   bin/httpGate 443 8080 pem/www.domain.key,pem/domain.crt




When started in this way, httpGate forwards requests from port 80 and 443
respectively to a PicoLisp application on port 8080. This form has a drawback
though, since it only allows for a single application to be handled. Usually,
there are many PicoLisp applications running on the same machine, and we need
httpGate to forward requests to all of them.


To handle several applications, start httpGate with a "names" config file:



      bin/httpGate 80 names
      bin/httpGate 443 names pem/www.domain.key,pem/domain.crt




httpGate needs to be started as root, but application servers should run
under normal user accounts. The easiest way to start httpGate automatically is
to add lines like the ones above to '/etc/rc.local'.


Configuring httpGate



The "names" config file



The "names" config file contains one line per application server. Each line
holds six whitespace separated tokens, for example:



   app 12345 tom /home/tom log/app ./pil app/main.l lib/app.l -main -go -wait




    

  1. "app" is the name of the application, and the key to this line.

  2. "12345" is the port where this server should listen at.

  3. "tom" is the user under whose ID the server should run.

  4. "/home/tom" is the working directory where the server should start.

  5. "log/app" is a log file to redirect stdout/stderr to.

  6. The rest of the line ".pil app/main.l ..." is the command to start the application.




Empty lines, and lines starting with a "#", are ignored. If the key in a
config file record is the special name "@", then it denotes the default
application for this machine. URLs without name will be forwarded to that port.
Optional tokens (e.g. log files) or empty arguments to the commands must be
written as single caret (^) characters to denote empty strings. Double or single
quotes are not parsed.


If the port is zero, then a single additional token is expected which should
denote an URL to redirect the request to:



   app 0 https://domain/foo/bar



This will cause httpGate to respnd with "302 Found" and "Location:
https://domain/foo/bar".


Balanced names file



If the config file contains many (hundreds or thousands) entries, then it is
recommended to sort it with the 'balance' utility. This may greatly accelerate
name (key) lookup at runtime. For that, put the above config lines into a file
"config". The tool 'balance' can be built - together with httpGate - with



   (cd src; make tools gate)




The following command will create a balanced "names" file:



   cat config | bin/balance -sort > names




The "void" file



If the local application server cannot be connected on the requested port
(typically because a session timed out), and a file with the name "void" exists
in the current working directory (token 4 in the config line), then the contents
of that file (normally HTML) are sent as response to the client.


Reloading the configuration



When the config file is modified, it can be reloaded by sending SIGHUP to all
running top-level httpGate processes:



   $ sudo pkill -HUP -P1 httpGate




Another possibility is to restart httpGate(s). This is not a problem, and can
be done also while the server is in production.


Just kill the top level httpGate parent process. This is not harmful, because
existing user sessions are handled by pairs of child processes, which continue
to run (until they terminate normally) even if their parent is stopped. Note
that this is different from PicoLisp DB applications, where the parent should
*never* be hard-stopped (eg. with 'kill -9 <pid>') while child processes
are running ('kill <pid>' is OK though, because the parent takes care of
stopping the children).


An example for stopping and restarting a running httpGate is:



   (let L
      # Build list of all httpGate parents (i.e. on 80 and 443)
      (make
         (in '("sudo" "pgrep" "-P1" "httpGate")
            (while (read)
               (link @) ) ) )
      # Stop them
      (for P L
         (call "sudo" "kill" P) )
      # Wait until all are gone
      (while (find '((P) (kill P 0)) L)
         (wait 200) )
      # Start new
      (call "sudo" "bin/httpGate" 80 "names")
      (call "sudo" "bin/httpGate" 443 "names" "pem/...") )




Keep-alive and retirement



Applications should call



   (retire 20)




before they call 'server'. This causes the parent server process to terminate
automatically 20 minutes after the last child process (user session) terminated.
It will be started by httpGate again on demand. User sessions in turn terminate
automatically after 5 minutes (if nobody logged in) or 1 hour (if a user is
logged in), unless JavaScript is enabled in the client browser and the
application calls



   (<ping> 7)




in its main 'action' function. In that case, the user session will not
terminate until the user closes the last window or tab to this application.



picoLisp/doc/fun.l0000644000175000017500000000021010637721454012454 0ustar  abuabu# 25jun07abu
# (c) Software Lab. Alexander Burger

(de fact (N)
   (if (=0 N)
      1
      (* N (fact (dec N))) ) )

# vi:et:ts=3:sw=3
picoLisp/doc/shape.l0000644000175000017500000000157110637721451012774 0ustar  abuabu# 25jun07abu
# (c) Software Lab. Alexander Burger

# The Shape base class
(class +Shape)
# x y

(dm T (X Y)
   (=: x X)
   (=: y Y) )

(dm move> (DX DY)
   (inc (:: x) DX)
   (inc (:: y) DY) )


# The Rectangle class
(class +Rectangle +Shape)
# dx dy

(dm T (X Y DX DY)
   (super X Y)
   (=: dx DX)
   (=: dy DY) )

(dm area> ()
   (* (: dx) (: dy)) )

(dm perimeter> ()
   (* 2 (+ (: dx) (: dy))) )

(dm draw> ()
   (drawRect (: x) (: y) (: dx) (: dy)) ) # Hypothetical function 'drawRect'


# The Circle class
(class +Circle +Shape)
# r

(dm T (X Y R)
   (super X Y)
   (=: r R) )

(dm area> ()
   (*/ (: r) (: r) 31415927 10000000) )

(dm perimeter> ()
   (*/ 2 (: r) 31415927 10000000) )

(dm draw> ()
   (drawCircle (: x) (: y) (: r)) )       # Hypothetical function 'drawCircle'


# The Fixed prefix class
(class +Fixed)

(dm move> (DX DY))  # A do-nothing method

# vi:et:ts=3:sw=3
picoLisp/doc/family.l0000644000175000017500000002261012172173426013151 0ustar  abuabu# 19jul13abu
# (c) Software Lab. Alexander Burger

(load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/ps.l")

### DB ###
(class +Person +Entity)
(rel nm (+Need +Sn +Idx +String))      # Name
(rel pa (+Joint) kids (+Man))          # Father
(rel ma (+Joint) kids (+Woman))        # Mother
(rel mate (+Joint) mate (+Person))     # Partner
(rel job (+Ref +String))               # Occupation
(rel dat (+Ref +Date))                 # born
(rel fin (+Ref +Date))                 # died
(rel txt (+String))                    # Info

(dm url> (Tab)
   (list "!person" '*ID This) )


(class +Man +Person)
(rel kids (+List +Joint) pa (+Person)) # Children

(class +Woman +Person)
(rel kids (+List +Joint) ma (+Person)) # Children

(dbs
   (0)                                 # (1 . 64)
   (2 +Person)                         # (2 . 256)
   (3 (+Person nm))                    # (3 . 512)
   (3 (+Person job dat fin)) )         # (4 . 512)


### GUI ###
(de choPerson (Dst)
   (diaform '(Dst)
      ( "--.-.-."
         "Name" (gui 'nm '(+Focus +Var +TextField) '*PrsNm 20)
         "Occupation" (gui 'job '(+Var +TextField) '*PrsJob 20)
         "born" (prog
            (gui 'dat1 '(+Var +DateField) '*PrsDat1 10)
            (gui 'dat2 '(+Var +DateField) '*PrsDat2 10) )
         (searchButton '(init> (: home query)))
         "Father" (gui 'pa '(+Var +TextField) '*PrsPa 20)
         "Mother" (gui 'ma '(+Var +TextField) '*PrsMa 20)
         "Partner" (gui 'mate '(+Var +TextField) '*PrsMate 20)
         (resetButton '(nm pa ma mate job dat1 dat2 query)) )
      (gui 'query '(+QueryChart) (cho)
         '(goal
            (quote
               @Nm *PrsNm
               @Pa *PrsPa
               @Ma *PrsMa
               @Mate *PrsMate
               @Job *PrsJob
               @Dat (and (or *PrsDat1 *PrsDat2) (cons *PrsDat1 (or *PrsDat2 T)))
               (select (@@)
                  ((nm +Person @Nm)
                     (nm +Person @Pa kids)
                     (nm +Person @Ma kids)
                     (nm +Person @Mate mate)
                     (job +Person @Job)
                     (dat +Person @Dat) )
                  (tolr @Nm @@ nm)
                  (tolr @Pa @@ pa nm)
                  (tolr @Ma @@ ma nm)
                  (tolr @Mate @@ mate nm)
                  (head @Job @@ job)
                  (range @Dat @@ dat) ) ) )
         7
         '((This) (list This This (: pa) (: ma) (: mate) (: job) (: dat))) )
      (
 'chart NIL
         '((btn) (NIL "Name") (NIL "Father") (NIL "Mother") (NIL "Partner") (NIL "Occupation") (NIL "born"))
         (do (cho)
            ( (alternating)
               (gui 1 '(+DstButton) Dst)
               (gui 2 '(+ObjView +TextField) '(: nm))
               (gui 3 '(+ObjView +TextField) '(: nm))
               (gui 4 '(+ObjView +TextField) '(: nm))
               (gui 5 '(+ObjView +TextField) '(: nm))
               (gui 6 '(+TextField))
               (gui 7 '(+DateField)) ) ) )
      (
         (scroll (cho))
         ( 4)
         (prin "Man")
         (newButton T Dst '(+Man) 'nm *PrsNm)
         ()
         (prin "Woman")
         (newButton T Dst '(+Woman) 'nm *PrsNm)
         ( 4)
         (cancelButton) ) ) )

# Person HTML Page
(de person ()
   (app)
   (action
      (html 0 (get (default *ID (val *DB)) 'nm) "@lib.css" NIL
         (form NIL
            (
 NIL ( (: nm)))
            (panel T "Person '@1'" T '(choPerson) 'nm '+Person)
            (
 NIL
               (gui '(+E/R +TextField) '(nm : home obj) 40 "Name")
               (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman))) )
            ( 5
               "Occupation" (gui '(+E/R +TextField) '(job : home obj) 20)
               "Father" (choPerson 0)
               (gui '(+E/R +Obj +TextField) '(pa : home obj) '(nm +Man) 30)
               "born" (gui '(+E/R +DateField) '(dat : home obj) 10)
               "Mother" (choPerson 0)
               (gui '(+E/R +Obj +TextField) '(ma : home obj) '(nm +Woman) 30)
               "died" (gui '(+E/R +DateField) '(fin : home obj) 10)
               "Partner" (choPerson 0)
               (gui '(+E/R +Obj +TextField) '(mate : home obj) '(nm +Person) 30) )
            (gui '(+E/R +Chart) '(kids : home obj) 5
               '((This) (list NIL This (: dat) (: pa) (: ma)))
               cadr )
            (
 NIL NIL
               '(NIL (NIL "Children") (NIL "born") (NIL "Father") (NIL "Mother"))
               (do 4
                  ( NIL
                     (choPerson 1)
                     (gui 2 '(+Obj +TextField) '(nm +Person) 20)
                     (gui 3 '(+E/R +DateField) '(dat curr) 10)
                     (gui 4 '(+ObjView +TextField) '(: nm) 20)
                     (gui 5 '(+ObjView +TextField) '(: nm) 20) ) )
               ( NIL NIL (scroll 4)) )
            (----)
            (gui '(+E/R +TextField) '(txt : home obj) 40 4)
            (gui '(+Rid +Button) "Contemporaries"
               '(url "!contemporaries" (: home obj)) )
            (gui '(+Rid +Button) "Tree View"
               '(url "!treeReport" (: home obj)) )
            (editButton T) ) ) ) )


### Reports ###
# Show all contemporaries of a person
(de contemporaries (*ID)
   (action
      (html 0 "Contemporaries" "@lib.css" NIL
         (form NIL
            (
 NIL ( "Contemporaries of " (: nm)))
            (ifn (: obj dat)
               (
 NIL (ht:Prin "No birth date for " (: obj nm)))
               (gui '(+QueryChart) 12
                  '(goal
                     (quote
                        @Obj (: home obj)
                        @Dat (: home obj dat)
                        @Beg (- (: home obj dat) 36525)
                        @Fin (or (: home obj fin) (+ (: home obj dat) 36525))
                        (db dat +Person (@Beg . @Fin) @@)
                        (different @@ @Obj)
                        (^ @ (>= (get (-> @@) 'fin) (-> @Dat)))
                        (^ @ (<= (get (-> @@) 'dat) (-> @Fin))) ) )
                  7
                  '((This)
                     (list This (: job) (: dat) (: fin) (: pa) (: ma) (: mate)) ) )
               (
 NIL (pack (datStr (: obj dat)) " - " (datStr (: obj fin)))
                  (quote
                     (NIL "Name") (NIL "Occupation") (NIL "born") (NIL "died")
                     (NIL "Father") (NIL "Mother") (NIL "Partner") )
                  (do 12
                     ( NIL
                        (gui 1 '(+ObjView +TextField) '(: nm))
                        (gui 2 '(+TextField))
                        (gui 3 '(+DateField))
                        (gui 4 '(+DateField))
                        (gui 5 '(+ObjView +TextField) '(: nm))
                        (gui 6 '(+ObjView +TextField) '(: nm))
                        (gui 7 '(+ObjView +TextField) '(: nm)) ) ) )
               (scroll 12)
               (----)
               (gui '(+Rid +Button) "Textfile"
                  '(let Txt (tmp "Contemporaries.txt")
                     (out Txt (txt> (chart)))
                     (url Txt) ) )
               (gui '(+Rid +Button) "PDF"
                  '(psOut NIL "Contemporaries"
                     (out (tmp "Contemporaries.txt")
                        (txt> (chart)) )
                     (in (tmp "Contemporaries.txt")
                        (let (Page 1  Fmt (200 120 50 50 120 120 120)  Ttl (line T))
                           (a4L "Contemporaries")
                           (font (7 . "Helvetica"))
                           (indent 30 10)
                           (down 12)
                           (font 9 (ps Ttl))
                           (down 12)
                           (table Fmt
                              "Name" "Occupation" "born" "died" "Father" "Mother" "Partner" )
                           (down 6)
                           (pages 560
                              (page T)
                              (down 12)
                              (ps (pack Ttl ", Page " (inc 'Page)))
                              (down 12) )
                           (until (eof)
                              (let L (split (line) "^I")
                                 (down 8)
                                 (table Fmt
                                    (font "Helvetica-Bold" (ps (head 50 (car L))))
                                    (ps (head 30 (cadr L)))
                                    (ps (get L 3))
                                    (ps (get L 4))
                                    (ps (head 30 (get L 5)))
                                    (ps (head 30 (get L 6)))
                                    (ps (head 30 (get L 7))) )
                                 (down 4) ) ) ) )
                     (page) ) ) ) ) ) ) )

# Tree display of a person's descendants
(de treeReport (This)
   (html 0 "Family Tree View" "@lib.css" NIL
      (
 NIL "Family Tree View")
      (
     NIL
         (recur (This)
            (when (try 'url> This 1)
               (
  •  NIL
                  ( (: nm) (mkUrl @))
                  (when (try 'url> (: mate) 1)
                     (prin " -- ")
                     ( (: mate nm) (mkUrl @)) ) )
               (when (: kids)
                  (
       NIL (mapc recurse (: kids))) ) ) ) ) ) )

### RUN ###
(de main ()
   (pool "family/" *Dbs)
   (unless (val *DB)
      (put>
         (set *DB (request '(+Man) 'nm "Adam"))
         'mate
         (request '(+Woman) 'nm "Eve") )
      (commit) ) )

(de go ()
   (rollback)
   (server 8080 "!person") )

# vi:et:ts=3:sw=3
picoLisp/doc/family.tgz0000644000175000017500000003350512172174201013517 0ustar  abuabuQ=klye |_{jwRIߋD_"E(-=c$FbI8n8BFZE?
J!:QHGrvޏYrEnFֵ-m\|;bq*T.tbw),[6+Mm5G!V8
%!ؒb&grj+dc-!+,32Nbnh~w0~iϹ:&|;je#ܴ9۪;5\aG`lZ?ئr9F\n0{Pu;Tłޜ3Iٮ4>y8|NObi.Q|%uj)۪E]	CTә[VTE\;gb|k0.˕je̓M7zOOj#0ܕ#C$qbr_+)R!;[`}l,H-z7RM-cb*

	 HV3ܴ0jp-UTMx*,ۇ2;d|2,[kGG#F8.2hO\Sr Ӛob>]iUbg`,MӨWeZxRC.6jAfpEcȬeZk6'
?F-nnrAqi}N"yAP,<HB:!p0! k!?(`z=Ua XԍMz5C92lm4I(TpL0mdNō.mvMƲPu'&,PL)}U)]j]\or㪬W檌(9<7vS2t2!ͦCRkgAMXxA+|Eni6D6{AቱJ_ղ2aRrD׋x~<у4ee0?jH'	xio&;=bDa)'1*9VλN"iq̽Â SڑL;%S9gf1)c}mhI	
6r3aB1F;:jp`zI0\4=enaWXn7֑[78v]/(td.Ӧf`ޡPbiqC)§[Fѹsqو188㾀
IY[0ֶ
O 1fXlՖiQ|ݷ
bQ}g;Azm[JݖaUqZfmhlʴkUXjx$	h!aÌEX+[I.;;bv)dnf0ىb/#(T 3cgM+
7čL`MwXHbɫeVYBcppT!6{N:;+5&x^D'!XBܘ~1)8@;>MphYTuvl3hvX/{x9cM6M,\=IQ,Xd[hwRL[T٥Hyf*V	Ζ|h=
[QI
{؍f4A֐FѴP(x:c^Ǹiny$NCa604\,t<:?|r-zHn⢸\n+0e!eNrժGV0
93S18
nG8j)Z?uY{*:)K:+Zsl>	`xDVӶZr"jVOi
#WYv6
"ڂ
-VA{hX45
vfnW7餜iV is5[M6ۚgΒl`}sua(`<jT[ǟK׍nw߷mom̲:[ҍu^ڿoDZw^45ɉǫ'UZFqhҌVjn8VtNqݾQ˩0y1tս-&
fסdql;%}¥PcS^B-z2G[
'~]Lυؼaig̟ಮCg&oYh]0P_ZE/?_ffc'N/DYRBG=/C=38Ek_l4+s͑?T=Մk6M]1ͷ_ a+䟇+7L^xeRH(&=L]XV.XE^f
δpC
:}U᰸q`G#/ϪV)UuobO}+e$ U%DڦN+| ~?Ugh*_7MOޠX+퇇ӞS+`:J{9C1s:ߗI껅w8uZxڏϥ]9~- }+KW#jԹ=Je={J]3n8LƜZ~5[h[Ϋ(ui/JSN{I[t"u{4Ԥgһ4dPSG:SG·?O{	`A,7 ȿJC
|b(/(CK
S0%IY@ݞM}8+QDYm4ӣh/HQ^])
3TYЙkՋ_+_#ͽ#bSoH(-)D[)@
x /]|$.+.?Ny1֕FG_c)+4t:r5?D
xk+N$׺>>T]Gy:ɃiAx_z
nZQ/X1Zq9lՒ[M{yŴW2ZL]¤ӴW޾Ba?u1L}z7i?1z_Nߥ;#SGx)~&Mކ`޾RnM]꣎pPGNQgNv=iOֵnzO@s?#K͚lr-OP龆q&~[GusIsIԔjsB*lTpffòMC:\&L(໑W۲_F
@o$`W܊dSIS֫ćG
"ab@`?ҍv$7Z\cƸjlۆyWNzA~`WedxF&8/ve'8/ #~HD])C7sdzhz!pWS["݋'4e:3ֹ;ae`ϧ~.
eH&oIkFgG3XaE싶=;4eZ=//l
IPL"ģS	e]6!(
(J07G`pN^,UMm&h+!bWꞈaQ]1G8x$ND>xHD'Njb qB8Fatoz濎ǀCNZ2t-qtX?gƸl/n;hE	-ASGFu{=cJ*9aCF<aC-IBS"nsKD`071}楀1I VOa߾qKwۏ@
{Ff7C*C@N>/H?Mez7P0h}憠nDFāsFZ)r-/rÈߤa=ٶ?p5)n5N8$6ze1a*g,+{JEDH ˼FLH./:L[Lw&THEp;hH	(k$GR9L|QH&sbs@i4Xt_CXG0)aHm5%Ѵer1ݝCմ)o00:D/9dΜUaL`Gp#-2ɰOxKZR	>h
|H<|*xSE<ٳ3Ł'u?IۑhK(~Tte
0N,~Ma1A'EK)ӜmsR-?k`ooGvOk5w7´wb蟓[pxms"S;~"}5z*"zu)z#"A~q)!$RB;MC /֢pMV0c&<sh@-OO>|t4g
Yak
UAKMy"eۢB\|Ƒ[K-&oN*WיKYu
$:5.b9o8`8jހ]=B$=&6g)@sUXM@%I<:yphB{^MHoQ<CU/-JC;,09;nq/`+)d7N[kNARP/BJtXP7~,pȆ=x:9ɩ~q?:LڶZ Z \EE4MEV8XʁpUCH	LjsQqnʺ=k1@Ot<")R^z8䥌oKy%b`W;%8z<
dhx!AGyY^	'~Ii6|sypVP/8qBS-:䊶MPo;W_s=m{W"ו]	IwxE/#Ԗe0_TJ-	&euGnnY^&E 2d ݀7	0	$&0dE]!={ϩ䑭Rap{^ջ?瞟d{O?dp
_|WlsGB!w߉G)oO盐shOE!`{{7\…C]3?Y^=MZa
(zwAx}'d/aϽqNp'QYܺTa	Fa?sA!a.<~~7XlJi!io+Im7wAn%)6>z	` NmEWDY
2'1&U(9pt5yb?dÏ>95L[i`3 E'o|OaMPw/`xU4/&Fo
1-hNTJ)fw[S؍_~+}ۻ'Z*'ߺl\
CNbkx}0y??"y~<o08x_:sD:i޳b_s!큍1do{S8=ߝÎۻ-o}7ǞT\.2<徸`0R505"ؿ W݀$@bGASNk/%cW#,UaﮎvmPDX7+?=z[4_22GՑۄ;}?1Q] :	R=-GWG1ˎ$}_+4o`W6׶=69ޞ_+Wg_
óS(WlUtC7s9wZ`T;zV["X[-[~t=dk}w]1wׇV[NEWLܕ𹾿/jvts/\n^÷}XKN!2\Vj
HV
aUz`dX7߳]YZMYU?m_wρ1y3޷3C'H8G!u:z!w<+[4Cj܇j`@*C$3|xWG7DÅ0K2YT[pӝSN0}cb?,/Bӥgp`hnCqq}	9+WkiEu@
N`/@>
#i힕 [QZرzV^Q⟏7`m=l1 { ·Mϕ6ls]ҸVMҥoIOHVD's=ASarLakDYI[BnF
8%}<^%CPv^Bpɡ.u
gﻯ؇g?vf9=+j?yNh;-A\ݰz&nnbRXv:`eE;pDEp.,ك;x#X?}:({VDW/v;d>
(d#g<',VBTC=ZJZɮP|lTp#}IKSCMqcz˩;]w`k#ZeVcO2&JS՞Vⅶ]E'u~߱|?b5&[
WGGZ9B#AԻ}ٗiMw7nL0>L@q"ϋDCiѠkQ&"=}o
d>esxY\B:S|S1vf)gֻm?f{ {ׂmg[Vܛie9 \ƁT}/B~^pcvL"1N]pS/ŧ\~҅:S+
y}n:zgC_v/"Wmf<+[{/=k!*Rzד G?a~
뢴8Y
vh
=-m;XOx#/Ac>{Gm톎۵Jn;m-
l*ϞqI?(LgAKHIRkaoͅ-G(yLsq,9mҧ!O~}3;_%*zB~t߃Z`x{kly7^AxwR@//5M@^7wo0
lSŊ$:,zP-|w~	w[E"OC`&I.1c5o怛gs7ܴ+",ػ+A5#{׻7Q->C$ݓ,q5[h/芰-AQ=1}~7ә4_FtGӃ~)$sL)3J!Ӏ\rȥ?"y2T	tᥓNJY9\йv**y5RTrb"D(QR{&IR?Ȃ%?S;F"E*%***Őʥ,%c:@L`
(	qNԢ=!YISj?5&eTCJ+%ޜF-D8^v
A $fש+"馴;]|Y	!H 	8my-Do6*O B1BWtW[q
Œΰ.6ZP'r9t˥BF'ɮ:dcel^l|17ZmqyADa2e1UX"HA..w9diKdz\ub(=ue]BCx)..Π_k"xυ1vw%ܛUW-ppp0\ڙP=p{kxQj/W?Zbْz[Et㙚(D١*+2W<8}ZqI`yv^Uj!g샀~`{(9>LO~
+}W/*Y|*!H^kPKEm\գ0-n6歶v,V?u|Vpz1=_+OB0<Y#*(-	ާ9?i_ޔF;' }otH#l+.
k
ďsg}fѳVj"xYu%qes|z*HYJ>̭|`s]c9l貱
P
wՓp6\U!y04l臿YtwcƀTMzכ[ tP	t*ngns"U/{V~B6l@`/zːN
΃ko?}PQDXli{원D,&.bPPN[")
Ş/ˁ]fL1)=1'tpXp$O7p Lt&.t'UiN(V1ny.<Hזɠh~%zי|ثР/BE(;5gbx;tH7h!n4P0b4	QŶa6bEbحiۥW(7B>Pm2uZѮհi_fGV,B
bt*%%G0Fh%@ɧaC'	f*Ŏ
wG+yPm3eB`2P
뚺UÖIƹ}=(>nHm-e2w1W+xO%Dg}S{*+)E(,,֕*еgҬZdȏ46-VDd%'+=Y	JNV6]1sp9pL#,Rɚʤ&oJnx5%D̡׏-do'dѮה1fF{1;$V]!ϼoFr^JP߇次	b.7d	>~q|#UqixG\0C>~&N٥2
KDVZ%r*V	|J`Uh㡝iG%MJJzt UfwT06nHK>ѬQEx#pe?!NR^:UB+rI4x"_TEpuR7Ti|RP[Շ+p%ÕPy
W	k$V[’j]9P=Rf4E҈)#3F@"g--`YS7x/<7C234K,/CͲ2S!{T{VȢAwJ7@u`̻1!_
Ǜ(n*	E!߾!UPV9ݯ8O_	:!wmH)o_
ʊ	[_D@J{x`[$ZCtDnSQLZAxcO2必gpT#TCRPL{IǑ4E/E	MkN:Mkkdg=*kf@Z*Tm	tӦ6Op0H(8.DZ3*1r<%P3ߐf!	͎lŦ333R779\薻"eȼF8Ʃx&jSHA{֩GȔNge	 ;zfFKO]B=V'ciVHBDZjHZj,BY|V=U/ڴ0%0#4ZTIQ%3*A1"ǜY놔)Twj$׎KGQQQQ%ATYD
PeuU'	Bvש'f7:E~4h0@%.s8q~&&j!{sN?efvXfYB?*_Ftݖ	vZi,VYN8fQ:`Pk_JPe\ɚ#dKoFBg$6ps΄3gJHٹ~lէ*u̹y+ձ#n=urXv!Gq~.Vb;/&'y8,,+o#6c8ۂɲ7_LEIsR&x	V
3'pFB3_jvfҮfҖf~J=CTU
ZB̗=)c"x2^ˀ]@J;&,cHi^6XbN1c8pƏ3|gVY蠨bq9@*9x@ \ k7KoituPb(2X]#F
1+y;!fU8:56:(!
5)c8lOk,XlMAL"Ή.^BPY>)/Ü"FNᘡpHR,e>Ykޟr
/?}t~#]XW@R[#ΎŒx-ΡlޒH2CiЊ
X0AAѤxP."hRA(:3s5#1w,(JvR<bH0飙QN
n)oX#gGK@H
q{?`{>J4H;9_3ʩ=vwinmFQhl[\}l4DTLO]}OݍMxū:=)ɺs77؟g2X\=]9pEu}3nIkW^~-V='nz=-V
o,7:Rō
Qxgcg·cۋ)eG#xc8uH[\ b	Ptivڄ;r|yv99E}xR9d{Tw|c1
ۢڷOjRu0L}+bс菜&@acY*m#{v$d宊;#K!A@O=
OBxM3]뢹ůH>&l&@.79T<xk:V»GmRFw:tlrb5u8ۢT*}*z6uĪ|7Z`
x&F_~k {AFw߅6U8'8ed#\7ty|
g5v0OsxNS_OeVv$~gY|μ1[s<8˩lK
h634찅B%oYmcJ7zdxwwsm،o{X"$ө`Aː’gN$԰tp%t.J"
H컻h"g	(TD5
^ʑPtg53TCzKa鎾igeb8p\=;VdX~1I>
2e_cC׌x]ֵ:Pn$"#z&4dG>3BWz%Wj"WJ\LC+SǪIz[w[w].[I8-tla
rPO>S>B	`L|^)\_ٜҍUek>!>MT$a=
U:=ԍէ+hz5NWaX1\+ɏOg)=lAۇS]Xj&a9vnXq`u?fR&걑5eNyԀ)vT+-9*eZ8V2M>F=74K#<1l8gEIY0
W.|]6<zZycx޼1hiZGzsJMN2>7g{8o0iWF\%3NC3|_K[E{݂9T@6F"mu9{APGE/r.
tf+'ak𜣎ƐX\ɘۭbޮ37bV{OVZ5
\Q$yǵjPt%]п:q&WY
 *Uτ
k_V>kfs9zNƞ*P.w,?{'Z0a*&FTE
P%#P&smA;3qU_(왵/(Nsh/LJz3^OR/c߹=[QєbgNȆ
'/xu55TP3~h4(=}Uz
ENʙn}j aVv ڵLun_iY^i̻jayIҜoP>b(ÁHc$kэ%f	`9Ҫi@(F5-יyEu>xp8;^rd4xQ,t6qsbБ=ZP&,*`~'0t?}$+seXidBC3J̜hTptn>+*OTxX̏	}G:7et3
?ټ>ds;oloϸGFb|oԷ6sb;z~w1οYo
PAo7?=Ɍܻ`yҟT¯^|1}2y`9uˏ+yhGszk7e9o/_]qhl߬y+]ޝ?.}3>ys~~=>uάݹw/-/ƞ1cMn"_;X|nCB
9H<=o`uݹKKJ}Ա0?	{3ܥ5Wz'lyD.X&?Ʋ8t>~{Ghn߳8/nq
(jzV9Itmg(x>&t$)Z
	C'2t}ױc=Ě3;.X,~"?XV~X>`}+L`[__Oӿm<筐f
!5EV+ȭUp
nHolOxh=
Pzz{u!*+{%K^ͱ:j3>_KSwD`J类qm;VߵmIH03;뇒pZ#)8>=ڂ{!sTpz'dܾ}APn*$Y
&qo丮3	iDŽ
1r)F:tRH?E3rT>X3:j
"9dZ2J/ = ]sfJUd)Pb?N/g.{^Ckкm2AQFWASRh!C9C-#hY;u{F~cŏ&!C~J;J0g֧}P	!H<ɬ#`*im1TYS24/xN{-/exyg;"YGo_"b%Qa'-n0tCt]RЇ}Ar1|1tA2)H
2 >%ҡe7\/h8nK#XA
Ir]BCMsMΚ[l$n|#{n]bB&fTNAam3]M
W02p52,(elk%zl.Cܥ8[ΰ+*p3}L@]P	5*eK&M4l}LVz'ûP9EA=	SwyzxBf->0
qBWkh8a.d (W?pJ~z
(\i~.kIJar
2Q䛱1ݦBEu[vz_ÒT;X:{}A`kuz]?äƤz<=GDT:B@I@^0lHUo4B!͆X5/&hfQ*9j QX}rQꐏJM0KM.KԲM,KٴM*KfJ&HQ򷾜( ]м[o	eKq"
P"/K/xNa|G>X[E?[e~ OҿU!"m]C\2Ȁ[_ \2+$JqD>APPN+'8nEXosԅ>T,Pڵ줥QTu~U^~"0WYqV'sC@iy8$AVD>Kw
d1R֨מ]I*dqC)|@E!&}7`P}(	FF'ʼdKÞh?KAFd*]7=%aThŘnb̨jXIaS'423sr2Z9w.ʏA#+]CA[1.=1DbmH[nm@]{ :M bJ&5ԫ	hNŠQČA=Kt\G"r作;x/
+ܱ{9Wg),{<ZÖ3$4܉E9wXAP~C?0D7'g2\$].8ZEZrA \/WZq#*t{o2mXOX܋υ7VSr8nDneK	cϭmqMsS{4qo^IxIXapJZ=0o-oqKbyoqC$vRL`uFb2X`괺76W|u{}mTܯ[O89a1uvlM"3z;""?N$	H΀ {[e%~Vok&!i+vѻ0G)F.T"|I۸@i@&W5	tDae+
:nt[`J$&cC-jeKy5]ʫh	"\̒=fSqަ]n(g_L 2!VeNn/J?(b(|*e7TYF9RV.TJY)eQp[.=mlGn~o6fw[e{)~C\IPBv1
ob7#mP	TPU	UEEJAUBHH@ǓP@9gfvfkߑn={w̙3dޖy2Op[m;!‘U(\+JWNBI"\JXH9 kJԓ+OX
2Vኝ'BߓC>Ηcx@$ذMA9*G.٦<+
4.X$g=62iɤʝ^VjmPG:Z&3
|rtGC2܃F3#ypwSp;?30"D%M4*a
V}	_p]3yA%}	\5yP$LJp8Rօ_@Z݈ҡ7(怛5V>0@Y}1A1E9:{]A<!h>*Ԗ3D~ʯI<Ϡ)1oJcrED^ZU;{/L1-mi60٠[\I+b'=iY˜fw|[?+5WU੥FmI0NNFn+w).*E	@MS
^ |,$x(^t4ir-mY`ؑP|⿟4_%p N׌C׉}%gEf2OSb&T<f2O}S^&T%_y8}ɷ~`\BW6
~_v0ߍ؋X^"7	*4
Cp,=ݭkSHJ5
[5*RB^V8se-w떎F[yRҸTh4	]^M.+-jpʵqVNTԜM%j2fӶ-[^}V:hEVjFG}VݞZ~$tdyQEgeb`j{#|fѳ$Jr\%i[]!}asG/}:})/җ
})/ϗ|[O'⽫ar\1wD_IicWp8]Q阃NCZIGdP30QEa-
(@xCGUK/Q\&FƷFX?o*ra\|3$1`Prj#T[sjBa86jvA֣M1L#vKнЅ5Vni˩I4)fJ}<$:^/˶\9j%CYHIJ@"vDu_R>mbtlo}6ovG֭[;oԶmBvo/dyS߻kmjQtnنG˞`m8Pv螞B	' ]VC޵{3tמǪ36¸;OꝜ?,rp=Ԝ@G(:L>7Cq!UulE3fpWwweQ{]9s=,IBvh̋/ӍYt9A2 #COU&uZi)?yk_/ʧx)91Z^LO?:_͒23].¦VuO|J@5:1{vv?15Y}

,)k]5Ʌ+>\VD%m_]$8Do`߉ Sٝj&=ʝlXĺCp~AXo`Aue=֌9x.z}}$GBZD7$zLkO[[݃D^aI4K'tA	Ykc?TsT0􍶸ؗZb	~kp~<.Kb+~x".幧9ٸퟏ;z\dH7n~X`nSg/hnIFb/(`k\ꄫSR?,؏zM
"Yc.b0^C)Ś"k|ƊgaZrU_[:1@|dYMN/$g#bBַ@N"kb8tSW.w5hٰ#S`y
]pKfx{1
{JbIBXusOMi㞩Qa[?x6^Dc2fz@P
ὥƯdpH_8Zho%tvQ^oIUH;ߠQ\OA(#u	?l('5}5.p_\uV8i9N8C&5RGuIoTQ_]g re7mϹ#I8G5F뢇-#{{C;iK/iu#3X8%t0lpk환}Ɋ8<">tBl	y#=r[/K잨OVqCgR
zԠ>Ίcp:5`vtM5=30u΀'8d@gu6e`Bl%>0<=]t쟂c
1Ͳ^:Bֆ4Y7.xmd?I](Mb'>eK|+>ӌcwqTI4:LQ!CI
8vq/pe~f}_K(p#H2"H)L"H !T
P7|fhTrzc#a>E/>g@J`O@?b=.1v`7֤I]U`ylm.>[ŧMlߘ3>BRDi!!kN\].ȕ?;A+jgx?KkΪ(ЏcVW
n8B*GB]N@ѹDh`;rh1=yG5҆hvp6}	Η"|ݯ
iD=ՙ)Rou2Lc:";wb왘Nũ=.Ҟm{ГGdxO 6nѡR&ꖓФ~qK&l?w$:XHUuRh7]AN(aO3i/L{z@nÔIcsP%FN÷ -o9՜TvOSITJ?#xpԆe*31k#p< n8:1{|~j~3'~jPzO#h3}IYfR|QC2
dDF48 ($&1b<^޸I5b2y`˱-Xtel0Wa_n"|;G''r
d!8|G2:>3}f/Z3S}l}A#]2.7">9}I
-.uN_"?-/ʙV_^?f0c_d뿫sKlZc7t{%|x8(#i}Mɒ#)1.3<LV]=39Yϙo?yVhpicoLisp/doc/hello.l0000644000175000017500000000014311556506533012774 0ustar  abuabu(load "@lib/xhtml.l")

(html 0 "Hello" NIL NIL
   (
       NIL "Hello world")
   "This is PicoLisp" )
picoLisp/doc/quine0000644000175000017500000000071010126770430012547 0ustar  abuabuWith lambda (= 'quote'):
   : ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X))))
   -> ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X))))


With 'let':
   : (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X))
   -> (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X))


Cheating:
   : (de quine NIL
      (pp 'quine) )
   -> quine

   : (quine)
   (de quine NIL
      (pp 'quine) )
   -> quine


Succinct:
   : T
   -> T
picoLisp/doc/search0000644000175000017500000000314312455452771012712 0ustar  abuabuKeywords
   (+Key +String)                head
      "Regen Axer" {2}

   (+Ref +String)                head
      ("Regen Axer" . {2}) {2}

Phone numbers
   (+Fold +Ref +String)          fold
      ("regenaxer" . {2}) {2}

Personal Names
   (+Sn +IdxFold +String)        tolr
      ("RSNSR" {C4} . T) {C4}
      ("Regen Axer" . {C4}) {C4}
      ("axer" {C4}) {C4}
      ("egen" {C4}) {C4}
      ("gen" {C4}) {C4}
      ("regenaxer" {C4}) {C4}
      ("xer" {C4}) {C4}

   (+Sn +Idx +String)            tolr
      ("Axer" {2}) {2}
      ("RSNSR" {2} . T) {2}
      ("Regen Axer" . {2}) {2}
      ("egen" {2}) {2}
      ("gen" {2}) {2}
      ("xer" {2}) {2}

Item Names
   (+IdxFold +String)            part
      ("Regen Axer" . {2}) {2}
      ("axer" {2}) {2}
      ("egen" {2}) {2}
      ("gen" {2}) {2}
      ("regenaxer" {2}) {2}
      ("xer" {2}) {2}

   (+Fold +Idx +String)          part
      ("axer" {2}) {2}
      ("egenaxer" {2}) {2}
      ("enaxer" {2}) {2}
      ("genaxer" {2}) {2}
      ("naxer" {2}) {2}
      ("regenaxer" . {2}) {2}
      ("xer" {2}) {2}

   (+List +Fold +Idx +String)    part
      ("axer" . {2}) {2}
      ("egen" {2}) {2}
      ("gen" {2}) {2}
      ("regen" . {2}) {2}
      ("xer" {2}) {2}

   (+List +Fold +Ref +String)    fold
      ("axer" . {2}) {2}
      ("regen" . {2}) {2}

Identifiers
   (+Idx +String)                hold
      ("Axer" {2}) {2}
      ("Regen Axer" . {2}) {2}
      ("egen" {2}) {2}
      ("gen" {2}) {2}
      ("xer" {2}) {2}

Number, Date, Time
   (+Key +Number)                range
   (+Ref +Number)                range

Objects
   (+Ref +Link)                  same
picoLisp/doc/travel0000644000175000017500000000271507371731246012744 0ustar  abuabu
   Rheine                 Osnabrueck
      O-----------42----------O-----------------48-------------+
      |                       |                                |
      |39            +--------+                                |
      |              |        |43                              |
      |     +---51---+        |                                |
      |     |                 | Warendorf      Guetersloh      |
      O-----+-----28--------+-O-+--------27--------O-----16----O Bielefeld
      | Muenster            | | |                  |           |
      |                     | | |                  +-----+     |
      |                  +--+ | +--+               |     |     |
      |                  |    |    |    Rheda      |     |     |
      |                27|    |27  +-24---O---10---+     |     |
      |46            +---+    |           |              |31   |
      |              |        |        +--+-----+        |     |39
      |              |        | Beckum |  |     |        |     |
      +--------------O---11---O-----24-+  |     |32      |     |
               Ahlen |        |           |     |        |     |
                     |      26|           |     +--------+-----+
                     |        +-----38----+                    |
                     |        |                                |
                     +---27---O---------------41---------------+
                            Soest                           Paderborn
picoLisp/doc64/README0000644000175000017500000001421112674437654012560 0ustar  abuabu23mar16abu
(c) Software Lab. Alexander Burger


         64-bit PicoLisp
         ===============

The 64-bit version of PicoLisp is a complete rewrite of the 32-bit version.

While the 32-bit version was written in C, the 64-bit version is implemented in
a generic assembler, which in turn is written in PicoLisp. In most respects, the
two versions are compatible (see "Differences" below).


      Building the Kernel
      -------------------

No C-compiler is needed to build the interpreter kernel, only a 64-bit version
of the GNU assembler for the target architecture.

The kernel sources are the "*.l" files in the "src64/" directory. The PicoLisp
assembler parses them and generates a few "*.s" files, which the GNU assembler
accepts to build the executable binary file. See the details for bootstrapping
the "*.s" files in INSTALL.

The generic assembler is in "src64/lib/asm.l". It is driven by the script
"src64/mkAsm" which is called by "src64/Makefile".

The CPU registers and instruction set of the PicoLisp processor are described in
"doc64/asm", and the internal data structures of the PicoLisp machine in
"doc64/structures".

Currently, arm64/Linux, x86-64/Linux, ppc64/Linux, x86-64/FreeBSD,
x86-64/OpenBSD and x86-64/SunOS are supported. The platform dependent files are
in the "src64/arch/" for the target architecture, and in "src64/sys/" for the
target operating system.

In addition, an emulator which "assembles" to C code can be built. It is much
slower than the native code, but otherwise completely compatible.


      Reasons for the Use of Assembly Language
      ----------------------------------------

Contrary to the common expectation: Runtime execution speed was not a primary
design decision factor. In general, pure code efficiency has not much influence
on the overall execution speed of an application program, as memory bandwidth
(and later I/O bandwidth) is the main bottleneck.

The reasons to choose assembly language (instead of C) were, in decreasing order
of importance:

   1. Stack manipulations
      Alignment to cell boundaries: To be able to directly express the desired
      stack data structures (see "doc64/structures", e.g. "Apply frame"), a
      better control over the stack (as compared to C) was required.

      Indefinite pushs and pops: A Lisp interpreter operates on list structures
      of unknown length all the time. The C version always required two passes,
      the first to determine the length of the list to allocate the necessary
      stack structures, and then the second to do the actual work. An assembly
      version can simply push as many items as are encountered, and clean up the
      stack with pop's and stack pointer arithmetics.

   2. Alignments and memory layout control
      Similar to the stack structures, there are also heap data structures that
      can be directly expressed in assembly declarations (built at assembly
      time), while a C implementation has to defer that to runtime.

      Built-in functions (SUBRs) need to be aligned to to a multiple of 16+2,
      reflecting the data type tag requirements, and thus allow direct jumps to
      the SUBR code without further pointer arithmetic and masking, as is
      necessary in the C version.

   3. Multi-precision arithmetics (Carry-Flag)
      The bignum functions demand an extensive use of CPU flags. Overflow and
      carry/borrow have to emulated in C with awkward comparisons of signed
      numbers.

   4. Register allocation
      A manual assembly implementation can probably handle register allocation
      more flexibly, with minimal context saves and reduced stack space, and
      multiple values can be returned from functions in registers. As mentioned
      above, this has no measurable effect on execution speed, but the binary's
      overall size is significantly reduced.

   5. Return status register flags from functions
      Functions can return condition codes directly. The callee does not need to
      re-check returned values. Again, this has only a negligible impact on
      performance.

   6. Multiple function entry points
      Some things can be handled more flexibly, and existing code may be easier
      to re-use. This is on the same level as wild jumps within functions
      ('goto's), but acceptable in the context of an often-used but rarely
      modified program like a Lisp kernel.

It would indeed be feasible to write only certain parts of the system in
assembly, and the rest in C. But this would be rather unsatisfactory. And it
gives a nice feeling to be independent of a heavy-weight C compiler.


      Differences to the 32-bit Version
      ---------------------------------

Except for the following seven cases, the 64-bit version should be upward
compatible to the 32-bit version.

1. Internal format and printed representation of external symbols
   This is probably the most significant change. External (i.e. database)
   symbols are coded more efficiently internally (occupying only a single cell),
   and have a slightly different printed representation. Existing databases need
   to be converted.

2. Short numbers are pointer-equal
   As there is now an internal "short number" type, an expression like

      (== 64 64)

   will evaluate to 'T' on a 64-bit system, but to 'NIL' on a 32-bit system.

3. Bit manipulation functions may differ for negative arguments
   Numbers are represented internally in a different format. Bit manipulations
   are not really defined for negative numbers, but (& -15 -6) will give -6 on
   32 bits, and 6 on 64 bits.

4. 'do' takes only a 'cnt' argument (not a bignum)
   For the sake of simplicity, a short number (60 bits) is considered to be
   enough for counted loops.

5. Calling native functions is different. Direct calls using the 'lib:fun'
   notation is still possible (see the 'ext' and 'ht' libraries), but the
   corresponding functions must of course be coded in assembly and not in C. To
   call C functions, the new 'native' function should be used, which can
   interface to native C functions directly, without the need of glue code to
   convert arguments and return values.

6. New features were added, like coroutines or namespaces.

7. Bugs (in the implementation, or in this list ;-)
picoLisp/ersatz/README0000644000175000017500000000410313273352252013132 0ustar  abuabu08may13abu
(c) Software Lab. Alexander Burger


         Ersatz PicoLisp
         ===============

Ersatz PicoLisp is a version of PicoLisp completely written in Java. It requires
a 1.6 Java Runtime Environment.

It should be the last resort when there is no other way to run a "real"
PicoLisp. Also, it may be used to bootstrap the 64-bit version, which requires a
running PicoLisp to build from the sources.

Unfortunately, ErsatzLisp lacks everything which makes up "true" PicoLisp:
Speed, small memory footprint, and simple internal structures.

Performance is rather poor. It is 5 to 10 times slower, allocates a huge amount
of memory at startup (600 MB vs. 3 MB), and needs 2.5 to 4 times the space for
runtime Lisp data. But efficiency was not a major goal. Instead, performance was
often sacrificed in favor of simpler or more modular structures.

There is no support for

-- raw console input ('key') and line editing
-- child processes ('fork')
-- interprocess communication ('tell', 'hear', 'ipc', 'udp' etc.)
-- databases (external symbols)
-- native C calls
-- signal handling
-- namespaces
-- coroutines


      Invocation
      ----------

Ersatz PicoLisp can be started - analog to 'pil' - as

   $ ersatz/pil

This includes slightly simplified versions of the standard libraries as loaded
by the "real" 'pil' (without database, but with Pilog and XML support).

To start it in debug mode, use

   $ ersatz/pil +


On non-Unix systems, you might start 'java' directly, e.g.:

   java -DPID=42 -cp .;tmp;picolisp.jar PicoLisp lib.l

Instead of '42' some other number may be passed. It is used to simulate a
"process ID", so it should be different for every running instance of Ersatz
PicoLisp.


      Building the JAR file
      ---------------------

The actual source files are

   sys.src  # The system
   fun.src  # Function definitions

The PicoLisp script "mkJar" will read them, generate the Java source file
"PicoLisp.java", compile that with 'javac', and pack the result into a JAR (Java
Archive) file. "mkJar" expects to be run in the "ersatz/" directory, e.g.:

   $ (cd ersatz; ./mkJar)
picoLisp/games/README0000644000175000017500000001426011745447105012727 0ustar  abuabu24apr12abu
(c) Software Lab. Alexander Burger


         PicoLisp Demo Games
         ===================

This directory contains a few simple games. They are neither especially
interesting, nor powerful, but may be useful as programming examples.

For a global PicoLisp installation (see the INSTALL file), either supply a full
path to "/usr/share/picolisp/games/.l" instead of just "games/.l" in
the commands below, or change the working directory to "/usr/share/picolisp/".


'mine' is a simplified version of the minesweeper game. You can start it as:

$ pil games/mine.l -main -go +

It will display a 12-by-12 field with 24 (default) hidden mines. You can move
around using the standard 'vi'-keys 'j' (down), 'k' (up), 'l' (right) and 'h'
(left).

Hit ENTER or SPACE to uncover a field, and ESC to terminate the game. In the
latter case (of if a mine exploded), you'll get the PicoLisp prompt. Then you
can continue the game with

: (go)

possibly after re-initializing it with

: (main)

or exit the PicoLisp interpreter with ENTER.



'nim' and 'ttt' are only testbeds for the general 'game' alpha-beta search
function (normally, these games are better implemented by directly exploring
their underlying principles and strategies).

Start 'nim' as

$ pil games/nim.l +

and then find the optimal move path for, let's say, three heaps of four matches
each:

: (nim 4 4 4)
-> (-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4))

This is a winning position (a minimal cost of -100), with three moves (in the
CARs of the move list: Take 4 from heap 1, then 4 from heap 2, and finally 4
from heap 3).



To play Tic-Tac-Toe, enter

$ pil games/ttt.l -main +

A three-by-three board is displayed. Enter your moves with the 'go' function:

: (go a 1)
   +---+---+---+
 3 |   |   |   |
   +---+---+---+
 2 |   |   |   |
   +---+---+---+
 1 | T |   |   |
   +---+---+---+
     a   b   c

Your positions are marked with 'T', the computer's with '0'.



The 'chess' game is minimalistic (447 lines of code). Nevertheless, it plays
some slow - though correct - chess. Start it as:

$ pil games/chess.l -main +
   +---+---+---+---+---+---+---+---+
 8 |||||||||
   +---+---+---+---+---+---+---+---+
 7 |
      |
      |
      |
      |
      |
      |
      |
      |
   +---+---+---+---+---+---+---+---+
 6 |   | - |   | - |   | - |   | - |
   +---+---+---+---+---+---+---+---+
 5 | - |   | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
 4 |   | - |   | - |   | - |   | - |
   +---+---+---+---+---+---+---+---+
 3 | - |   | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
 2 | P | P | P | P | P | P | P | P |
   +---+---+---+---+---+---+---+---+
 1 | R | N | B | Q | K | B | N | R |
   +---+---+---+---+---+---+---+---+
     a   b   c   d   e   f   g   h

The pieces are indicated by the letters 'K'ing, 'Q'ueen, 'R'ook, 'B'ishop,
k'N'ight and 'P'awn, with black pieces in angular brackets.


Alternatively, you can also run it through XBoard (in the X Window System):

$ xboard -fcp games/xchess


Without XBoard, you may enter your moves with the field names (in lower case)
for the "from" and "to" positions:

: (go e2 e4)

Castling may be entered by just specifying the king's move:

: (go e1 g1)

To promote a pawn to some piece other than a queen, you can specify a class:

: (go h7 h8 +Knight)

To undo one or several moves, enter

: (go -)

and to redo them

: (go +)

To switch sides (and have the computer play against itself), call 'go' without
arguments:

: (go)

The initial board position can be restored with

: (main)

The global variable '*Depth' holds the maximal depth of the alpha-beta tree
search. It defaults to 5. You may change it to some smaller value for a faster
response, or to a larger value for a deeper search:

: (setq *Depth 7)

The same effect can be achieved by passing the desired depth as the first
argument to 'main':

: (main 7)

The second (optional) argument to 'main' is your color ('NIL' for white and 'T'
for black).

To setup some given board position, call 'main' with a list of triples, with
each describing:

   1. The field
   2. The piece's classes
   3. An optional flag to indicate that the piece did not move yet

: (main 5 NIL
   (quote
      (a2 (+White +Pawn) T)
      (b1 (+White +King))
      (d4 (+Black +King)) ) )
   +---+---+---+---+---+---+---+---+
 8 |   | - |   | - |   | - |   | - |
   +---+---+---+---+---+---+---+---+
 7 | - |   | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
 6 |   | - |   | - |   | - |   | - |
   +---+---+---+---+---+---+---+---+
 5 | - |   | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
 4 |   | - |   ||   | - |   | - |
   +---+---+---+---+---+---+---+---+
 3 | - |   | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
 2 | P | - |   | - |   | - |   | - |
   +---+---+---+---+---+---+---+---+
 1 | - | K | - |   | - |   | - |   |
   +---+---+---+---+---+---+---+---+
     a   b   c   d   e   f   g   h

At any time, you can print the current board position in the above format to a
file with

: (ppos "file")

which later can be restored with

: (load "file")



There is also a plain 'sudoku' solver:

$ pil games/sudoku.l +

: (main
   (quote
      (5 3 0 0 7 0 0 0 0)
      (6 0 0 1 9 5 0 0 0)
      (0 9 8 0 0 0 0 6 0)
      (8 0 0 0 6 0 0 0 3)
      (4 0 0 8 0 3 0 0 1)
      (7 0 0 0 2 0 0 0 6)
      (0 6 0 0 0 0 2 8 0)
      (0 0 0 4 1 9 0 0 5)
      (0 0 0 0 8 0 0 7 9) ) )
   +---+---+---+---+---+---+---+---+---+
 9 | 5   3     |     7     |           |
   +   +   +   +   +   +   +   +   +   +
 8 | 6         | 1   9   5 |           |
   +   +   +   +   +   +   +   +   +   +
 7 |     9   8 |           |     6     |
   +---+---+---+---+---+---+---+---+---+
 6 | 8         |     6     |         3 |
   +   +   +   +   +   +   +   +   +   +
 5 | 4         | 8       3 |         1 |
   +   +   +   +   +   +   +   +   +   +
 4 | 7         |     2     |         6 |
   +---+---+---+---+---+---+---+---+---+
 3 |     6     |           | 2   8     |
   +   +   +   +   +   +   +   +   +   +
 2 |           | 4   1   9 |         5 |
   +   +   +   +   +   +   +   +   +   +
 1 |           |     8     |     7   9 |
   +---+---+---+---+---+---+---+---+---+
     a   b   c   d   e   f   g   h   i

Type

: (go)

to let it search for a solution.
picoLisp/games/chess.l0000644000175000017500000003547013452674572013346 0ustar  abuabu# 08apr19abu
# (c) Software Lab. Alexander Burger

# *Board a1 .. h8
# *White *Black *WKPos *BKPos *Pinned
# *Depth *Moved *Undo *Redo *Me *You

(load "@lib/simul.l")

### Fields/Board ###
# x y color piece whAtt blAtt

(setq *Board (grid 8 8))

(for (X . Lst) *Board
   (for (Y . This) Lst
      (=: x X)
      (=: y Y)
      (=: color (not (bit? 1 (+ X Y)))) ) )

(de *Straight `west `east `south `north)

(de *Diagonal
   ((This) (: 0 1  1  0 -1  1))   # Southwest
   ((This) (: 0 1  1  0 -1 -1))   # Northwest
   ((This) (: 0 1 -1  0 -1  1))   # Southeast
   ((This) (: 0 1 -1  0 -1 -1)) ) # Northeast

(de *DiaStraight
   ((This) (: 0 1  1  0 -1  1  0 -1  1))   # South Southwest
   ((This) (: 0 1  1  0 -1  1  0  1  1))   # West Southwest
   ((This) (: 0 1  1  0 -1 -1  0  1  1))   # West Northwest
   ((This) (: 0 1  1  0 -1 -1  0 -1 -1))   # North Northwest
   ((This) (: 0 1 -1  0 -1 -1  0 -1 -1))   # North Northeast
   ((This) (: 0 1 -1  0 -1 -1  0  1 -1))   # East Northeast
   ((This) (: 0 1 -1  0 -1  1  0  1 -1))   # East Southeast
   ((This) (: 0 1 -1  0 -1  1  0 -1  1)) ) # South Southeast


### Pieces ###
(de piece (Typ Cnt Fld)
   (prog1
      (def
         (pack (mapcar '((Cls) (cdr (chop Cls))) Typ))
         Typ )
      (init> @ Cnt Fld) ) )


(class +White)
# color ahead

(dm init> (Cnt Fld)
   (=: ahead north)
   (extra Cnt Fld) )

(dm name> ()
   (pack " " (extra) " ") )

(dm move> (Fld)
   (adjMove '*White '*WKPos whAtt- whAtt+) )


(class +Black)
# color ahead

(dm init> (Cnt Fld)
   (=: color T)
   (=: ahead south)
   (extra Cnt Fld) )

(dm name> ()
   (pack '< (extra) '>) )

(dm move> (Fld)
   (adjMove '*Black '*BKPos blAtt- blAtt+) )


(class +piece)
# cnt field attacks

(dm init> (Cnt Fld)
   (=: cnt Cnt)
   (move> This Fld) )

(dm ctl> ())


(class +King +piece)

(dm name> () 'K)

(dm val> () 120)

(dm ctl> ()
   (unless (=0 (: cnt)) -10) )

(dm moves> ()
   (make
      (unless
         (or
            (n0 (: cnt))
            (get (: field) (if (: color) 'whAtt 'blAtt)) )
         (tryCastle west T)
         (tryCastle east) )
      (try1Move *Straight)
      (try1Move *Diagonal) ) )

(dm attacks> ()
   (make
      (try1Attack *Straight)
      (try1Attack *Diagonal) ) )


(class +Castled)

(dm ctl> () 30)


(class +Queen +piece)

(dm name> () 'Q)

(dm val> () 90)

(dm moves> ()
   (make
      (tryMoves *Straight)
      (tryMoves *Diagonal) ) )

(dm attacks> ()
   (make
      (tryAttacks *Straight)
      (tryAttacks *Diagonal T) ) )


(class +Rook +piece)

(dm name> () 'R)

(dm val> () 47)

(dm moves> ()
   (make (tryMoves *Straight)) )

(dm attacks> ()
   (make (tryAttacks *Straight)) )


(class +Bishop +piece)

(dm name> () 'B)

(dm val> () 33)

(dm ctl> ()
   (when (=0 (: cnt)) -10) )

(dm moves> ()
   (make (tryMoves *Diagonal)) )

(dm attacks> ()
   (make (tryAttacks *Diagonal T)) )


(class +Knight +piece)

(dm name> () 'N)

(dm val> () 28)

(dm ctl> ()
   (when (=0 (: cnt)) -10) )

(dm moves> ()
   (make (try1Move *DiaStraight)) )

(dm attacks> ()
   (make (try1Attack *DiaStraight)) )


(class +Pawn +piece)

(dm name> () 'P)

(dm val> () 10)

(dm moves> ()
   (let (Fld1 ((: ahead) (: field))  Fld2 ((: ahead) Fld1))
      (make
         (and
            (tryPawnMove Fld1 Fld2)
            (=0 (: cnt))
            (tryPawnMove Fld2 T) )
         (tryPawnCapt (west Fld1) Fld2 (west (: field)))
         (tryPawnCapt (east Fld1) Fld2 (east (: field))) ) ) )

(dm attacks> ()
   (let Fld ((: ahead) (: field))
      (make
         (and (west Fld) (link @))
         (and (east Fld) (link @)) ) ) )


### Move Logic ###
(de inCheck (Color)
   (if Color (get *BKPos 'whAtt) (get *WKPos 'blAtt)) )

(de whAtt+ (This Pce)
   (=: whAtt (cons Pce (: whAtt))) )

(de whAtt- (This Pce)
   (=: whAtt (delq Pce (: whAtt))) )

(de blAtt+ (This Pce)
   (=: blAtt (cons Pce (: blAtt))) )

(de blAtt- (This Pce)
   (=: blAtt (delq Pce (: blAtt))) )

(de adjMove (Var KPos Att- Att+)
   (let (W (: field whAtt)  B (: field blAtt))
      (when (: field)
         (put @ 'piece NIL)
         (for F (: attacks) (Att- F This)) )
      (nond
         (Fld (set Var (delq This (val Var))))
         ((: field) (push Var This)) )
      (ifn (=: field Fld)
         (=: attacks)
         (put Fld 'piece This)
         (and (isa '+King This) (set KPos Fld))
         (for F (=: attacks (attacks> This)) (Att+ F This)) )
      (reAtttack W (: field whAtt) B (: field blAtt)) ) )

(de reAtttack (W W2 B B2)
   (for This W
      (unless (memq This W2)
         (for F (: attacks) (whAtt- F This))
         (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) )
   (for This W2
      (for F (: attacks) (whAtt- F This))
      (for F (=: attacks (attacks> This)) (whAtt+ F This)) )
   (for This B
      (unless (memq This B2)
         (for F (: attacks) (blAtt- F This))
         (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) )
   (for This B2
      (for F (: attacks) (blAtt- F This))
      (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) )

(de try1Move (Lst)
   (for Dir Lst
      (let? Fld (Dir (: field))
         (ifn (get Fld 'piece)
            (link (list This (cons This Fld)))
            (unless (== (: color) (get @ 'color))
               (link
                  (list This
                     (cons (get Fld 'piece))
                     (cons This Fld) ) ) ) ) ) ) )

(de try1Attack (Lst)
   (for Dir Lst
      (and (Dir (: field)) (link @)) )  )

(de tryMoves (Lst)
   (for Dir Lst
      (let Fld (: field)
         (loop
            (NIL (setq Fld (Dir Fld)))
            (T (get Fld 'piece)
               (unless (== (: color) (get @ 'color))
                  (link
                     (list This
                        (cons (get Fld 'piece))
                        (cons This Fld) ) ) ) )
            (link (list This (cons This Fld))) ) ) ) )

(de tryAttacks (Lst Diag)
   (use (Pce Cls Fld2)
      (for Dir Lst
         (let Fld (: field)
            (loop
               (NIL (setq Fld (Dir Fld)))
               (link Fld)
               (T
                  (and
                     (setq Pce (get Fld 'piece))
                     (<> (: color) (get Pce 'color)) ) )
               (T (== '+Pawn (setq Cls (last (type Pce))))
                  (and
                     Diag
                     (setq Fld2 (Dir Fld))
                     (= (get Fld2 'y) (get ((get Pce 'ahead) Fld) 'y))
                     (link Fld2) ) )
               (T (memq Cls '(+Knight +Queen +King)))
               (T (and Pce (xor Diag (== Cls '+Bishop)))) ) ) ) ) )

(de tryPawnMove (Fld Flg)
   (unless (get Fld 'piece)
      (if Flg
         (link (list This (cons This Fld)))
         (for Cls '(+Queen +Knight +Rook +Bishop)
            (link
               (list This
                  (cons This)
                  (cons
                     (piece (list (car (type This)) Cls) (: cnt))
                     Fld ) ) ) ) ) ) )

(de tryPawnCapt (Fld1 Flg Fld2)
   (if (get Fld1 'piece)
      (unless (== (: color) (get @ 'color))
         (if Flg
            (link
               (list This
                  (cons (get Fld1 'piece))
                  (cons This Fld1) ) )
            (for Cls '(+Queen +Knight +Rook +Bishop)
               (link
                  (list This
                     (cons (get Fld1 'piece))
                     (cons This)
                     (cons
                        (piece (list (car (type This)) Cls) (: cnt))
                        Fld1 ) ) ) ) ) )
      (let? Pce (get Fld2 'piece)
         (and
            (== Pce (car *Moved))
            (=1 (get Pce 'cnt))
            (isa '+Pawn Pce)
            (n== (: color) (get Pce 'color))
            (link (list This (cons Pce) (cons This Fld1))) ) ) ) )

(de tryCastle (Dir Long)
   (use (Fld1 Fld2 Fld Pce)
      (or
         (get (setq Fld1 (Dir (: field))) 'piece)
         (get Fld1 (if (: color) 'whAtt 'blAtt))
         (get (setq Fld2 (Dir Fld1)  Fld Fld2) 'piece)
         (when Long
            (or
               (get (setq Fld (Dir Fld)) 'piece)
               (get Fld (if (: color) 'whAtt 'blAtt)) ) )
         (and
            (== '+Rook (last (type (setq Pce (get (Dir Fld) 'piece)))))
            (=0 (get Pce 'cnt))
            (link
               (list This
                  (cons This)
                  (cons
                     (piece (cons (car (type This)) '(+Castled +King)) 1)
                     Fld2 )
                  (cons Pce Fld1) ) ) ) ) ) )

(de pinned (Fld Lst Color)
   (use (Pce L P)
      (and
         (loop
            (NIL (setq Fld (Dir Fld)))
            (T (setq Pce (get Fld 'piece))
               (and
                  (= Color (get Pce 'color))
                  (setq L
                     (make
                        (loop
                           (NIL (setq Fld (Dir Fld)))
                           (link Fld)
                           (T (setq P (get Fld 'piece))) ) ) )
                  (<> Color (get P 'color))
                  (memq (last (type P)) Lst)
                  (cons Pce L) ) ) )
         (link @) ) ) )


### Moves ###
# Move      ((p1 (p1 . f2))            . ((p1 . f1)))
# Capture   ((p1 (p2) (p1 . f2))       . ((p1 . f1) (p2 . f2)))
# Castle    ((K (K) (C . f2) (R . f4)) . ((R . f3) (K . f1)))
# Promote   ((P (P) (Q . f2))          . ((Q) (P . f1)))
# Capt/Prom ((P (p1) (P) (Q . f2))     . ((Q) (P . f1) (p1 . f2)))
(de moves (Color)
   (filter
      '((Lst)
         (prog2
            (move (car Lst))
            (not (inCheck Color))
            (move (cdr Lst)) ) )
      (mapcan
         '((Pce)
            (mapcar
               '((Lst)
                  (cons Lst
                     (flip
                        (mapcar
                           '((Mov) (cons (car Mov) (get Mov 1 'field)))
                           (cdr Lst) ) ) ) )
               (moves> Pce) ) )
         (if Color *Black *White) ) ) )

(de move (Lst)
   (if (atom (car Lst))
      (inc (prop (push '*Moved (++ Lst)) 'cnt))
      (dec (prop (++ *Moved) 'cnt)) )
   (for Mov Lst
      (move> (car Mov) (cdr Mov)) ) )


### Evaluation ###
(de mate (Color)
   (and (inCheck Color) (not (moves Color))) )

(de battle (Fld Prey Attacker Defender)
   (use Pce
      (loop
         (NIL (setq Pce (mini 'val> Attacker)) 0)
         (setq Attacker (delq Pce Attacker))
         (NIL (and (asoq Pce *Pinned) (not (memq Fld @)))
            (max 0 (- Prey (battle Fld (val> Pce) Defender Attacker))) ) ) ) )

# Ref. Sargon, Dan and Kate Spracklen, Hayden 1978
(de cost (Color)
   (if (mate (not Color))
      -9999
      (setq *Pinned
         (make
            (for Dir *Straight
               (pinned *WKPos '(+Rook +Queen))
               (pinned *BKPos '(+Rook +Queen) T) )
            (for Dir *Diagonal
               (pinned *WKPos '(+Bishop +Queen))
               (pinned *BKPos '(+Bishop +Queen) T) ) ) )
      (let (Ctl 0  Mat 0  Lose 0  Win1 NIL  Win2 NIL  Flg NIL)
         (use (White Black Col Same B)
            (for Lst *Board
               (for This Lst
                  (setq White (: whAtt)  Black (: blAtt))
                  ((if Color inc dec) 'Ctl (- (length White) (length Black)))
                  (let? Val (and (: piece) (val> @))
                     (setq Col (: piece color)  Same (== Col Color))
                     ((if Same dec inc) 'Ctl (ctl> (: piece)))
                     (unless
                        (=0
                           (setq B
                              (if Col
                                 (battle This Val White Black)
                                 (battle This Val Black White) ) ) )
                        (dec 'Val 5)
                        (if Same
                           (setq
                              Lose (max Lose B)
                              Flg (or Flg (== (: piece) (car *Moved))) )
                           (when (> B Win1)
                              (xchg 'B 'Win1)
                              (setq Win2 (max Win2 B)) ) ) )
                     ((if Same dec inc) 'Mat Val) ) ) ) )
         (unless (=0 Lose) (dec 'Lose 5))
         (if Flg
            (* 4 (+ Mat Lose))
            (when Win2
               (dec 'Lose (>> 1 (- Win2 5))) )
            (+ Ctl (* 4 (+ Mat Lose))) ) ) ) )


### Game ###
(de display (Res)
   (when Res
      (disp *Board T
         '((This)
            (cond
               ((: piece) (name> @))
               ((: color) " - ")
               (T "   ") ) ) ) )
   (and (inCheck *You) (prinl "(+)"))
   Res )

(de moved? (Lst)
   (or
      (> 16 (length Lst))
      (find '((This) (n0 (: cnt))) Lst) ) )

(de bookMove (From To)
   (let Pce (get From 'piece)
      (list 0 (list (list Pce (cons Pce To)) (cons Pce From))) ) )

(de myMove ()
   (let? M
      (cadr
         (cond
            ((moved? (if *Me *Black *White))
               (game *Me *Depth moves move cost) )
            (*Me
               (if (member (get *Moved 1 'field 'x) (1 2 3 5))
                  (bookMove 'e7 'e5)
                  (bookMove 'd7 'd5) ) )
            ((rand T) (bookMove 'e2 'e4))
            (T (bookMove 'd2 'd4)) ) )
      (move (car (push '*Undo M)))
      (off *Redo)
      (cons
         (caar M)
         (cdr (asoq (caar M) (cdr M)))
         (pick cdr (cdar M)) ) ) )

(de yourMove (From To Cls)
   (when
      (find
         '((Mov)
            (and
               (== (caar Mov) (get From 'piece))
               (== To (pick cdr (cdar Mov)))
               (or
                  (not Cls)
                  (isa Cls (car (last (car Mov)))) ) ) )
         (moves *You) )
      (prog1 (car (push '*Undo @))
         (off *Redo)
         (move @) ) ) )

(de undo ()
   (move (cdr (push '*Redo (++ *Undo)))) )

(de redo ()
   (move (car (push '*Undo (++ *Redo)))) )

(de setup (Depth You Init)
   (setq *Depth (or Depth 5)  *You You  *Me (not You))
   (off *White *Black *Moved *Undo *Redo)
   (for Lst *Board
      (for This Lst (=: piece) (=: whAtt) (=: blAtt)) )
   (if Init
      (for L Init
         (with (piece (cadr L) 0 (car L))
            (unless (caddr L)
               (=: cnt 1)
               (push '*Moved This) ) ) )
      (mapc
         '((Cls Lst)
            (piece (list '+White Cls) 0 (car Lst))
            (piece '(+White +Pawn) 0 (cadr Lst))
            (piece '(+Black +Pawn) 0 (get Lst 7))
            (piece (list '+Black Cls) 0 (get Lst 8)) )
         '(+Rook +Knight +Bishop +Queen +King +Bishop +Knight +Rook)
         *Board ) ) )

(de main (Depth You Init)
   (setup Depth You Init)
   (display T) )

(de go Args
   (display
      (cond
         ((not Args) (xchg '*Me '*You) (myMove))
         ((== '- (car Args)) (and *Undo (undo)))
         ((== '+ (car Args)) (and *Redo (redo)))
         ((apply yourMove Args) (display T) (myMove)) ) ) )

# Print position to file
(de ppos (File)
   (out File
      (println
         (list 'main *Depth *You
            (lit
               (mapcar
                  '((This)
                     (list
                        (: field)
                        (val This)
                        (not (memq This *Moved)) ) )
                  (append *White *Black) ) ) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/games/mine.l0000644000175000017500000000620411524214167013146 0ustar  abuabu# 08feb11abu
# (c) Software Lab. Alexander Burger

(load "@lib/term.l")

# Spielfeldbelegung:
# NIL    Verdeckt: Leeres Feld
# T      Verdeckt: Mine
# 0-8    Aufgedeckt, Nachbarminen

(seed (in "/dev/urandom" (rd 8)))

# Globale Konstanten
(de *Minen . 24)  # Anzahl der Minen
(de *FeldX . 12)  # Feldgroesse X
(de *FeldY . 12)  # Feldgroesse Y

(de *NachbarX -1  0 +1 -1  +1 -1  0 +1)
(de *NachbarY -1 -1 -1  0   0 +1 +1 +1)

# Globale Variablen
(de *Feld)        # Datenbereich des Minenfeldes


# Eine Mine legen
(de legeMine ()
   (use (X Y)
      (while
         (get *Feld
            (setq Y (rand 1 *FeldY))
            (setq X (rand 1 *FeldX)) ) )
      (set (nth *Feld Y X) T) ) )

# *Feld anzeigen
(de anzeigen (Flg)
   (let (N 0 Y 0)
      (for L *Feld
         (prin (align 2 (inc 'Y)) " ")
         (for C L
            (prin
               " "
               (cond
                  ((not C) (inc 'N) "-")
                  (Flg C)
                  ((=T C) "-")
                  (T C) ) ) )
         (prinl) )
      (prin "   ")
      (for C *FeldX
         (prin " " (char (+ 64 C))) )
      (prinl)
      (prinl "<" N ">  ") ) )

# Ein Feld ausrechnen
(de wertFeld (X Y)
   (when
      (=0
         (set (nth *Feld Y X)
            (cnt
               '((DX DY)
                  (=T (get *Feld (+ Y DY) (+ X DX))) )
               *NachbarX
               *NachbarY ) ) )
      (mapc
         '((DX DY)
            (and
               (>= *FeldX (inc 'DX X) 1)
               (>= *FeldY (inc 'DY Y) 1)
               (not (member (cons DX DY) *Visit))
               (push '*Visit (cons DX DY))
               (wertFeld DX DY) ) )
         *NachbarX
         *NachbarY ) ) )

# Hauptfunktion
(de main (N)
   (when N
      (setq *Minen N) )
   (setq *Feld
      (make (do *FeldY (link (need *FeldX)))) )
   (do *Minen (legeMine)) )

(de go ()
   (use (K X Y)
      (anzeigen)
      (xtUp (+ 2 *FeldY))
      (xtRight 4)
      (one X Y)
      (catch NIL
         (until (= "^[" (setq K (key)))
            (case K
               ("j"
                  (unless (= Y *FeldY)
                     (xtDown 1)
                     (inc 'Y) ) )
               ("k"
                  (unless (= Y 1)
                     (xtUp 1)
                     (dec 'Y) ) )
               ("l"
                  (unless (= X *FeldX)
                     (xtRight 2)
                     (inc 'X) ) )
               ("h"
                  (unless (= X 1)
                     (xtLeft 2)
                     (dec 'X) ) )
               ((" " "^J" "^M")
                  (xtLeft (+ 2 (* 2 X)))
                  (xtUp (dec Y))
                  (when (=T (get *Feld Y X))
                     (anzeigen T)
                     (prinl "*** BUMM ***")
                     (throw) )
                  (let *Visit NIL
                     (wertFeld X Y) )
                  (anzeigen)
                  (unless (find '((L) (memq NIL L)) *Feld)
                     (prinl ">>> Gewonnen! <<<")
                     (throw) )
                  (xtUp (- *FeldY Y -3))
                  (xtRight (+ 2 (* 2 X))) ) ) )
         (xtLeft (+ 2 (* 2 X)))
         (xtDown (+ 3 (- *FeldY Y))) ) ) )

# vi:et:ts=3:sw=3
picoLisp/games/nim.l0000644000175000017500000000110511524214137012771 0ustar  abuabu# 08feb11abu
# (c) Software Lab. Alexander Burger

(load "@lib/simul.l")

# Nim
(de nim Pos
   (game T NIL
      '((Flg)  # Moves
         (make
            (for (I . N) Pos
               (do N
                  (link
                     (cons (cons I N) I (- N)) )
                  (dec 'N) ) ) ) )
      '((Mov)  # Move
         (dec (nth Pos (car Mov)) (cdr Mov)) )
      '((Flg)  # Cost
         (let N (apply + Pos)
            (if (=0 N) -100 N) ) ) ) )

### Test ###
(test
   '(-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4))
   (nim 4 4 4) )

# vi:et:ts=3:sw=3
picoLisp/games/sudoku.l0000644000175000017500000000343511416121173013525 0ustar  abuabu# 10jul10abu
# (c) Software Lab. Alexander Burger

(load "@lib/simul.l")

### Fields/Board ###
# val lst

(setq
   *Board (grid 9 9)
   *Fields (apply append *Board) )

# Init values to zero (empty)
(for L *Board
   (for This L
      (=: val 0) ) )

# Build lookup lists
(for (X . L) *Board
   (for (Y . This) L
      (=: lst
         (make
            (let A (* 3 (/ (dec X) 3))
               (do 3
                  (inc 'A)
                  (let B (* 3 (/ (dec Y) 3))
                     (do 3
                        (inc 'B)
                        (unless (and (= A X) (= B Y))
                           (link
                              (prop (get *Board A B) 'val) ) ) ) ) ) )
            (for Dir '(`west `east `south `north)
               (for (This (Dir This)  This  (Dir This))
                  (unless (memq (:: val) (made))
                     (link (:: val)) ) ) ) ) ) ) )

# Cut connections (for display only)
(for (X . L) *Board
   (for (Y . This) L
      (when (member X (3 6))
         (con (car (val This))) )
      (when (member Y (4 7))
         (set (cdr (val This))) ) ) )

# Display board
(de display ()
   (disp *Board 0
      '((This)
         (if (=0 (: val))
            "   "
            (pack " " (: val) " ") ) ) ) )

# Initialize board
(de main (Lst)
   (for (Y . L) Lst
      (for (X . N) L
         (put *Board X (- 10 Y) 'val N) ) )
   (display) )

# Find solution
(de go ()
   (unless
      (recur (*Fields)
         (with (car *Fields)
            (if (=0 (: val))
               (loop
                  (NIL
                     (or
                        (assoc (inc (:: val)) (: lst))
                        (recurse (cdr *Fields)) ) )
                  (T (= 9 (: val)) (=: val 0)) )
               (recurse (cdr *Fields)) ) ) )
      (display) ) )

# vi:et:ts=3:sw=3
picoLisp/games/ttt.l0000644000175000017500000000337011524214100013015 0ustar  abuabu# 08feb11abu
# (c) Software Lab. Alexander Burger

# *Board

(load "@lib/simul.l")

(de display ()
   (for Y (3 2 1)
      (prinl "   +---+---+---+")
      (prin " " Y)
      (for X (1 2 3)
         (prin " | " (or (get *Board X Y) " ")) )
      (prinl " |") )
   (prinl "   +---+---+---+")
   (prinl "     a   b   c") )

(de find3 (P)
   (find
      '((X Y DX DY)
         (do 3
            (NIL (= P (get *Board X Y)))
            (inc 'X DX)
            (inc 'Y DY)
            T ) )
      (1 1 1 1 2 3 1 1)
      (1 2 3 1 1 1 1 3)
      (1 1 1 0 0 0 1 1)
      (0 0 0 1 1 1 1 -1) ) )

(de myMove ()
   (when
      (game NIL 8
         '((Flg)     # Moves
            (unless (find3 (or (not Flg) 0))
               (make
                  (for (X . L) *Board
                     (for (Y . P) L
                        (unless P
                           (link
                              (cons
                                 (cons X Y (or Flg 0))
                                 (list X Y) ) ) ) ) ) ) ) )
         '((Mov) # Move
            (set (nth *Board (car Mov) (cadr Mov)) (cddr Mov)) )
         '((Flg)     # Cost
            (if (find3 (or Flg 0)) -100 0) ) )
      (let Mov (caadr @)
         (set (nth *Board (car Mov) (cadr Mov)) 0) )
      (display) ) )

(de yourMove (X Y)
   (and
      (sym? X)
      (>= 3 (setq X (- (char X) 96)) 1)
      (num? Y)
      (>= 3 Y 1)
      (not (get *Board X Y))
      (set (nth *Board X Y) T)
      (display) ) )

(de main ()
   (setq *Board (make (do 3 (link (need 3)))))
   (display) )

(de go Args
   (cond
      ((not (yourMove (car Args) (cadr Args)))
         "Illegal move!" )
      ((find3 T) "Congratulation, you won!")
      ((not (myMove)) "No moves")
      ((find3 0) "Sorry, you lost!") ) )

# vi:et:ts=3:sw=3
picoLisp/games/xchess0000755000175000017500000000270612331364164013267 0ustar  abuabu#!/usr/bin/picolisp /usr/lib/picolisp/lib.l
# 04may14abu
# (c) Software Lab. Alexander Burger

(load "/usr/share/picolisp/games/chess.l")

(de reply @
   (prinl (glue " " (rest)))
   (flush) )

(de xmove ()
   (when (myMove)
      (let L (car *Undo)
         (reply "move"
            (pack
               (cdr (asoq (caar L) (cdr L)))
               (pick cdr (cdar L)) ) ) ) ) )

(in NIL
   (loop
      (case (read)
         (xboard)
         (protover
            (read)
            (reply "feature" "myname=\"PicoLisp Chess\"")
            (reply "feature" "time=0" "sigint=0" "usermove=1")
            (reply "feature" "done=1") )
         (accepted (read))
         (new
            (seed (in "/dev/urandom" (rd 3)))
            (setup (format (sys "XCHESS_DEPTH"))) )
         (level (line T))
         (sd (setup (read)))
         (post)
         (black (off *Me) (on *You))
         (white (on *Me) (off *You))
         (usermove
            (let (L (clip (line))  From (pack (head 2 L))  To (pack (head 2 (cddr L)))  F (get L 5))
               (if (and (yourMove (intern From) (intern To)) (or (not F) (= "q" F)))
                  (xmove)
                  (reply "Illegal move:" (pack L)) ) ) )
         (go (xchg '*Me '*You) (xmove))
         (undo (undo))
         (remove (undo) (undo))
         (result (line T))
         (random)
         (hard)
         (force)
         (quit (bye))
         (T (reply "Error (unknown command):" @)) ) ) )

# vi:et:ts=3:sw=3
picoLisp/misc/bigtest0000755000175000017500000000502512717125054013270 0ustar  abuabu#!bin/picolisp lib.l
# 18may16abu
# misc/bigtest 

(load "@lib/misc.l")

(seed (car (argv)))

#  Random patterns:
#  cnt
#     xxx0000000000000000000000000xxxx0000000000000000000000000xxx
#        (| 7 (>> -28 15) (>> -57 7))
#
#     xxx1111111111111111111111111xxxx1111111111111111111111111xxx
#        1FFFFFF0FFFFFF8
#
#
#  dig
#     xxx000000000000000000000000000xxxx000000000000000000000000000xxx
#        (| 7 (>> -30 15) (>> -61 7))
#
#     xxx111111111111111111111111111xxxx111111111111111111111111111xxx
#        1FFFFFFC3FFFFFF8

(de rnd ()
   (let Big (| (rand 0 7) (>> -28 (rand 0 15)) (>> -57 (rand 0 7)))
      (when (rand T)
         (setq Big (| Big `(hex "1FFFFFF0FFFFFF8"))) )
      (do (rand 0 2)
         (let Dig (| (rand 0 7) (>> -30 (rand 0 15)) (>> -61 (rand 0 7)))
            (when (rand T)
               (setq Dig (| Dig `(hex "1FFFFFFC3FFFFFF8"))) )
            (setq Big (| Dig (>> -64 Big))) ) )
      (if (rand T) Big (- Big)) ) )


(de test1 (S N1)
   (let (N (read)  X (eval (list S N1)))
      (unless (= N X)
         (prinl "^J" N ": (" S " " N1 ") -> " X)
         (bye) ) ) )

(de test2 (S N1 N2)
   (let (N (read)  X (eval (list S N1 N2)))
      (unless (= N X)
         (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X)
         (bye) ) ) )

(de cmp2 (S N1 N2)
   (let (N (n0 (read))  X (eval (list S N1 N2)))
      (unless (== N X)
         (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X)
         (bye) ) ) )


(sys "BC_LINE_LENGTH" "200")

(pipe
   (out '("bc")
      (do 10000000
         (setq N1 (rnd))
         (while (=0 (setq N2 (rnd))))
         (prinl N1)
         (prinl N2)
         (prinl N1 " + " N2)
         (prinl N1 " + 1")
         (prinl N1 " + 1")
         (prinl N1 " - " N2)
         (prinl N1 " - 1")
         (prinl N1 " - 1")
         (prinl N1 " * " N2)
         (prinl N1 " * 2")
         (prinl N1 " % " N2)
         (prinl N1 " / " N2)
         (prinl N1 " / 2")
         (prinl N1 " >= " N2)
         (prinl N1 " > " N2)
         (prinl "sqrt(" (abs N1) ")")
         (at (0 . 1000) (wait 100)) ) )
   (do 100
      (do 100000
         (setq
            N1 (read)
            N2 (read) )
         (test2 '+ N1 N2)
         (test2 '+ N1 1)
         (test1 'inc N1)
         (test2 '- N1 N2)
         (test2 '- N1 1)
         (test1 'dec N1)
         (test2 '* N1 N2)
         (test2 '* N1 2)
         (test2 '% N1 N2)
         (test2 '/ N1 N2)
         (test2 '/ N1 2)
         (cmp2 '>= N1 N2)
         (cmp2 '> N1 N2)
         (test1 'sqrt (abs N1)) )
      (prin ".")
      (flush) )
   (prinl) )

(bye)
picoLisp/misc/calc0000755000175000017500000000030711562150633012525 0ustar  abuabu#!/usr/bin/picolisp /usr/lib/picolisp/lib.l
# 10may11abu
# (c) Software Lab. Alexander Burger

(load "@lib/misc.l" "/usr/share/picolisp/misc/calc.l")

# Initialize
(main)

# Start server
(go)
(wait)
picoLisp/misc/calc.l0000644000175000017500000000414613015542370012757 0ustar  abuabu# 24nov16abu
# (c) Software Lab. Alexander Burger

# *Init *Accu *Stack

(allowed NIL "!calculator" "@lib.css")
(load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l")

# Calculator logic
(de digit (N)
   (when *Init (zero *Accu) (off *Init))
   (setq *Accu (+ N (* 10 *Accu))) )

(de calc ()
   (let (Fun (caar *Stack)  Val (cddr (++ *Stack)))
      (setq *Accu
         (if (and (== '/ Fun) (=0 *Accu))
            (note "Div / 0")
            (Fun Val *Accu) ) ) ) )

(de operand (Fun Prio)
   (when (>= (cadar *Stack) Prio) (calc))
   (push '*Stack (cons Fun Prio *Accu))
   (on *Init) )

(de finish ()
   (while *Stack (calc))
   (on *Init) )

# Calculator GUI
(de calculator ()
   (app)
   (action
      (html 0 "Bignum Calculator" "@lib.css" NIL
         (
       NIL "Bignum Calculator")
         (form NIL
            (
       (gui '(+Var +NumField) '*Accu 60))
            ( 4
               (gui '(+JS +Button) "±" '(setq *Accu (- *Accu)))
               (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730)
                  '(setq *Accu (sqrt *Accu)) )
               (gui '(+JS +Button) "\^" '(operand '** 3))
               (gui '(+JS +Button) "/" '(operand '/ 2))

               (gui '(+JS +Button) "7" '(digit 7))
               (gui '(+JS +Button) "8" '(digit 8))
               (gui '(+JS +Button) "9" '(digit 9))
               (gui '(+JS +Button) "*" '(operand '* 2))

               (gui '(+JS +Button) "4" '(digit 4))
               (gui '(+JS +Button) "5" '(digit 5))
               (gui '(+JS +Button) "6" '(digit 6))
               (gui '(+JS +Button) "-" '(operand '- 1))

               (gui '(+JS +Button) "1" '(digit 1))
               (gui '(+JS +Button) "2" '(digit 2))
               (gui '(+JS +Button) "3" '(digit 3))
               (gui '(+JS +Button) "+" '(operand '+ 1))

               (gui '(+JS +Button) "0" '(digit 0))
               (gui '(+JS +Button) "C" '(zero *Accu))
               (gui '(+JS +Button) "A" '(main))
               (gui '(+JS +Button) "=" '(finish)) ) ) ) ) )

# Initialize
(de main ()
   (on *Init)
   (zero *Accu)
   (off *Stack) )

# Start server
(de go ()
   (server 8080 "!calculator") )
picoLisp/misc/chat0000755000175000017500000000102210352170504012530 0ustar  abuabu#!bin/picolisp lib.l
# 21dec05abu

# *Port *Sock *Name

(de chat Lst
   (out *Sock
      (mapc prin Lst)
      (prinl) ) )


(setq *Port (port 4004))

(loop
   (setq *Sock (listen *Port))
   (NIL (fork) (close *Port))
   (close *Sock) )

(out *Sock
   (prin "Please enter your name: ")
   (flush) )
(in *Sock (setq *Name (line T)))

(tell 'chat "+++ " *Name " arrived +++")

(task *Sock
   (in @
      (ifn (eof)
         (tell 'chat *Name "> " (line T))
         (tell 'chat "--- " *Name " left ---")
         (bye) ) ) )
(wait)
picoLisp/misc/crc.l0000644000175000017500000000170011567113325012621 0ustar  abuabu# 25may11abu
# (c) Software Lab. Alexander Burger

(if (== 64 64) (load "@lib/native.l") (from "/**/"))

(gcc "util" NIL
   (crc (Len Lst) "crc" 'I Len (cons NIL (cons Len) Lst)) )

int crc(int len, char *p) {
   int res, c, i;

   for (res = 0; --len >=0;) {
      c = *p++;
      for (i = 0; i < 8; ++i) {
         if ((c ^ res) & 1)
            res ^= 0x14002;  /* Polynom x**16 + x**15 + x**2 + 1 */
         c >>= 1,  res >>= 1;
      }
   }
   return res;
}

/**/


(ifn (== 64 64) (load "@lib/gcc.l") (from "/**/"))

(gcc "crc" NIL 'crc)

any crc(any ex) {
   any x;
   int len, res, c, i;

   len = evCnt(ex, x = cdr(ex));
   x = cdr(x),  x = EVAL(car(x));
   for (res = 0; --len >=0; x = cdr(x)) {
      c = (int)xCnt(ex,car(x));
      for (i = 0; i < 8; ++i) {
         if ((c ^ res) & 1)
            res ^= 0x14002;  /* Polynom x**16 + x**15 + x**2 + 1 */
         c >>= 1,  res >>= 1;
      }
   }
   return boxCnt(res);
}

/**/

# vi:et:ts=3:sw=3
picoLisp/misc/dining.l0000644000175000017500000000346511350355410013325 0ustar  abuabu# 18mar10abu
# (c) Software Lab. Alexander Burger
# Dining Philosophers

(de dining (Name State)
   (loop
      (prinl Name ": " State)
      (state 'State                       # Dispatch according to state
         (thinking 'hungry)               # If thinking, get hungry
         (hungry                          # If hungry, grab random fork
            (if (rand T)
               (and (acquire leftFork) 'leftFork)
               (and (acquire rightFork) 'rightFork) ) )
         (hungry 'hungry                  # Failed, stay hungry for a while
            (wait (rand 1000 3000)) )
         (leftFork                        # If holding left fork, try right one
            (and (acquire rightFork) 'eating)
            (wait 2000) )                 # then eat for 2 seconds
         (rightFork                       # If holding right fork, try left one
            (and (acquire leftFork) 'eating)
            (wait 2000) )                 # then eat for 2 seconds
         ((leftFork rightFork) 'hungry    # Otherwise, go back to hungry,
            (release (val State))         # release left or right fork
            (wait (rand 1000 3000)) )     # and stay hungry
         (eating 'thinking             # After eating, resume thinking
            (release leftFork)
            (release rightFork)
            (wait 6000) ) ) ) )           # for 6 seconds

(setq *Philosophers
   (maplist
      '((Phils Forks)
         (let (leftFork (tmp (car Forks))  rightFork (tmp (cadr Forks)))
            (or
               (fork)  # Parent: Collect child process IDs
               (dining (car Phils) 'hungry) ) ) )  # Initially hungry
      '("Aristotle" "Kant" "Spinoza" "Marx" "Russell")
      '("ForkA" "ForkB" "ForkC" "ForkD" "ForkE" .) ) )

(push '*Bye '(mapc kill *Philosophers))  # Terminate all upon exit

# vi:et:ts=3:sw=3
picoLisp/misc/fannkuch.l0000644000175000017500000000221311275250505013645 0ustar  abuabu# 07nov09abu
# (c) Software Lab. Alexander Burger
# Fannkuch benchmark (http://shootout.alioth.debian.org)

(de fannkuch (N)
   (let (Lst (range 1 N)  L Lst  Max)
      (recur (L)  # Permute
         (if (cdr L)
            (do (length L)
               (recurse (cdr L))
               (rot L) )
            (zero N)  # For each permutation
            (for (P (copy Lst)  (> (car P) 1)  (flip P (car P)))
               (inc 'N) )
            (setq Max (max N Max)) ) )
      Max ) )

# Parallelized version
(de fannkuch+ (N)
   (let (Res (need N)  Lst (range 1 N)  L Lst  Max)
      (for (R Res R (cdr R))
         (later R
            (let L (cdr Lst)
               (recur (L)  # Permute
                  (if (cdr L)
                     (do (length L)
                        (recurse (cdr L))
                        (rot L) )
                     (zero N)  # For each permutation
                     (for (P (copy Lst)  (> (car P) 1)  (flip P (car P)))
                        (inc 'N) )
                     (setq Max (max N Max)) ) )
               Max ) )
         (rot Lst) )
      (wait NIL (full Res))
      (apply max Res) ) )

# vi:et:ts=3:sw=3
picoLisp/misc/fibo.l0000644000175000017500000000221113225340630012761 0ustar  abuabu# 10jan18abu
# (c) Software Lab. Alexander Burger

# Standard version
(de fibo (N)
   (if (>= 2 N)
      1
      (+ (fibo (dec N)) (fibo (- N 2))) ) )

# Non-recursive
(de fib (N)
   (let (A 0  B 1)
      (do N
         (swap 'B (+ (swap 'A B) B)) ) ) )

# Parallelized version
(de fibo+ (D N)  # Uses 2**D processes
   (cond
      ((>= 1 (dec 'N)) 1)
      ((ge0 (dec 'D))
         (let (A NIL B NIL)
            (later 'A (fibo+ D N))
            (later 'B (fibo+ D (dec N)))
            (wait NIL (and A B))
            (+ A B) ) )
      (T
         (+
            (fibo+ D N)
            (fibo+ D (dec N)) ) ) ) )

# Using a cache (fastest)
(de cachedFibo (N)
   (cache '(NIL) N
      (if (>= 2 N)
         1
         (+ (cachedFibo (dec N)) (cachedFibo (- N 2))) ) ) )


`(== 64 64)  # Only in the 64-bit version

# Coroutine
(de coFibo ()
   (co 'fibo
      (let (A 0  B 1)
         (loop
            (yield
               (swap 'B (+ (swap 'A B) B)) ) ) ) ) )

# Coded in 'C'
(load "@lib/native.l")

(gcc "fibo" NIL
   (cFibo (N) "Fibo" 'I N) )

int Fibo(int n) {
   if (n <= 2)
      return 1;
   return Fibo(n-1) + Fibo(n-2);
}
/**/

# vi:et:ts=3:sw=3
picoLisp/misc/hanoi.l0000644000175000017500000000077412172155050013154 0ustar  abuabu# 19jul13abu
# (c) Software Lab. Alexander Burger

# Lisp
(de hanoi (N)
   (move N 'left 'center 'right) )

(de move (N A B C)
   (unless (=0 N)
      (move (dec N) A C B)
      (println 'Move 'disk 'from 'the A 'to 'the B 'pole)
      (move (dec N) C B A) ) )

# Pilog
(be hanoi (@N)
   (move @N left center right) )

(be move (0 @ @ @) T)

(be move (@N @A @B @C)
   (^ @M (dec (-> @N)))
   (move @M @A @C @B)
   (^ @ (println 'Move 'disk 'from 'the (-> @A) 'to 'the (-> @B) 'pole))
   (move @M @C @B @A) )
picoLisp/misc/life.l0000644000175000017500000000166512260511301012766 0ustar  abuabu# 31dec13abu
# (c) Software Lab. Alexander Burger

(load "@lib/simul.l")

(seed (in "/dev/urandom" (rd 8)))

(let Grid (grid 26 26)
   (for Col Grid
      (for This Col
         (=: life (rand T)) ) )
   (loop
      (disp Grid NIL
         '((This) (if (: life) "X " "  ")) )
      (wait 1000)
      (for Col Grid
         (for This Col
            (let N  # Count neighbors
               (cnt
                  '((Dir) (get (Dir This) 'life))
                  (quote
                     west east south north
                     ((X) (south (west X)))
                     ((X) (north (west X)))
                     ((X) (south (east X)))
                     ((X) (north (east X))) ) )
               (=: next  # Next generation
                  (if (: life)
                     (>= 3 N 2)
                     (= N 3) ) ) ) ) )
      (for Col Grid  # Update
         (for This Col
            (=: life (: next)) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/misc/mailing0000755000175000017500000001162413075612312013245 0ustar  abuabu#!bin/picolisp lib.l
# 19apr17abu
# (c) Software Lab. Alexander Burger

# Configuration
(setq
   *MailingList "picolisp@software-lab.de"
   *SpoolFile "/var/mail/picolisp"
   *MailingDomain "software-lab.de"
   *Mailings (make (in "Mailings" (while (line T) (link @))))
   *SmtpHost "localhost"
   *SmtpPort 25 )

# Process mails
(loop
   (when (gt0 (car (info *SpoolFile)))
      (protect
         (in *SpoolFile
            (unless (= "From" (till " " T))
               (quit "Bad mbox file") )
            (char)
            (while (setq *From (lowc (till " " T)))
               (line)  # Skip rest of line and "\r\n"
               (off
                  *Name *Subject *Date *MessageID *InReplyTo *MimeVersion
                  *ContentType *ContentTransferEncoding *ContentDisposition *UserAgent )
               (while (trim (split (line) " "))
                  (let L @
                     (while (and (sub? (peek) " \t") (char))  # Skip WSP
                        (conc L (trim (split (line) " "))) )
                     (setq *Line (glue " " (cdr L)))
                     (case (pack (car L))
                        ("From:" (setq *Name *Line))
                        ("Subject:" (setq *Subject *Line))
                        ("Date:" (setq *Date *Line))
                        ("Message-ID:" (setq *MessageID *Line))
                        ("In-Reply-To:" (setq *InReplyTo *Line))
                        ("MIME-Version:" (setq *MimeVersion *Line))
                        ("Content-Type:" (setq *ContentType *Line))
                        ("Content-Transfer-Encoding:" (setq *ContentTransferEncoding *Line))
                        ("Content-Disposition:" (setq *ContentDisposition *Line))
                        ("User-Agent:" (setq *UserAgent *Line)) ) ) )
               (if (nor (member *From *Mailings) (= "subscribe" (lowc *Subject)))
                  (out "/dev/null" (echo "^JFrom ") (msg *From " discarded"))
                  (unless (setq *Sock (connect *SmtpHost *SmtpPort))
                     (quit "Can't connect to SMTP server") )
                  (unless
                     (and
                        (pre? "220 " (in *Sock (line T)))
                        (out *Sock (prinl "HELO " *MailingDomain "^M"))
                        (pre? "250 " (in *Sock (line T)))
                        (out *Sock (prinl "MAIL FROM:" *MailingList "^M"))
                        (pre? "250 " (in *Sock (line T))) )
                     (quit "Can't HELO") )
                  (when (= "subscribe" (lowc *Subject))
                     (push1 '*Mailings *From)
                     (out "Mailings" (mapc prinl *Mailings)) )
                  (for To *Mailings
                     (out *Sock (prinl "RCPT TO:" To "^M"))
                     (unless (pre? "250 " (in *Sock (line T)))
                        (msg T " can't mail") ) )
                  (when (and (out *Sock (prinl "DATA^M")) (pre? "354 " (in *Sock (line T))))
                     (out *Sock
                        (prinl "From: " (or *Name *From) "^M")
                        (prinl "Sender: " *MailingList "^M")
                        (prinl "Reply-To: " *MailingList "^M")
                        (prinl "To: " *MailingList "^M")
                        (prinl "Subject: " *Subject "^M")
                        (and *Date (prinl "Date: " @ "^M"))
                        (and *MessageID (prinl "Message-ID: " @ "^M"))
                        (and *InReplyTo (prinl "In-Reply-To: " @ "^M"))
                        (and *MimeVersion (prinl "MIME-Version: " @ "^M"))
                        (and *ContentType (prinl "Content-Type: " @ "^M"))
                        (and *ContentTransferEncoding (prinl "Content-Transfer-Encoding: " @ "^M"))
                        (and *ContentDisposition (prinl "Content-Disposition: " @ "^M"))
                        (and *UserAgent (prinl "User-Agent: " @ "^M"))
                        (prinl "^M")
                        (cond
                           ((= "subscribe" (lowc *Subject))
                              (prinl "Hello " (or *Name *From) " :-)^M")
                              (prinl "You are now subscribed^M")
                              (prinl "****^M^J^M") )
                           ((= "unsubscribe" (lowc *Subject))
                              (out "Mailings"
                                 (mapc prinl (del *From '*Mailings)) )
                              (prinl "Good bye " (or *Name *From) " :-(^M")
                              (prinl "You are now unsubscribed^M")
                              (prinl "****^M^J^M") ) )
                        (echo "^JFrom ")
                        (prinl "^J-- ^M")
                        (prinl "UNSUBSCRIBE: mailto:" *MailingList "?subject=Unsubscribe^M")
                        (prinl ".^M")
                        (prinl "QUIT^M") ) )
                  (close *Sock) ) ) )
         (out *SpoolFile (rewind)) ) )
   (call "fetchmail" "-as")
   (wait `(* 4 60 1000)) )

# vi:et:ts=3:sw=3
picoLisp/misc/maze.l0000644000175000017500000000213012113425474013003 0ustar  abuabu# 27feb13abu
# (c) Software Lab. Alexander Burger

# ./pil misc/maze.l -"setq M (maze 16 12)" -"display M" -bye

(load "@lib/simul.l")

(de maze (DX DY)
   (let Maze (grid DX DY)
      (let Fld (get Maze (rand 1 DX) (rand 1 DY))
         (recur (Fld)
            (for Dir (shuffle '((west . east) (east . west) (south . north) (north . south)))
               (with ((car Dir) Fld)
                  (unless (or (: west) (: east) (: south) (: north))
                     (put Fld (car Dir) This)
                     (put This (cdr Dir) Fld)
                     (recurse This) ) ) ) ) )
      (for (X . Col) Maze
         (for (Y . This) Col
            (set This
               (cons
                  (cons
                     (: west)
                     (or
                        (: east)
                        (and (= Y 1) (= X DX)) ) )
                  (cons
                     (: south)
                     (or
                        (: north)
                        (and (= X 1) (= Y DY)) ) ) ) ) ) )
      Maze ) )

(de display (Maze)
   (disp Maze 0 '((This) "   ")) )

# vi:et:ts=3:sw=3
picoLisp/misc/pdfPage.l0000644000175000017500000000245012656061141013421 0ustar  abuabu# 08feb16abu
# (c) Software Lab. Alexander Burger

(allowed ()
   "!work" "@lib.css" )

(scl 2)
(load
   "@lib/http.l" "@lib/xhtml.l" "@lib/form.l"
   "@lib/canvas.l" "@lib/svg.l" "@lib/tinymce.l"
   "lib/pdfPage.l" )

(setq
   *Title "MyPage"
   *Css '("@lib.css" . "canvas {border: 1px solid}") )

(pdfPage 'myPage '(+PdfPage)
   *Title *A4-DX *A4-DY 24 "Tangerine"
   (image "img/7fachLogo.png" "image/png"
      (/ (- (: dx) 318) 2)
      (/ (- (: dy) 130) 2)
      318
      130 ) )

(de drawCanvas (This Dly F X Y X2 Y2)
   (make
      (draw> This Dly F X Y X2 Y2) ) )

(de work ()
   (app)
   (action
      (html 0 *Title *Css NIL
         ( 7)
         (form NIL
            (
               ((620 NIL "margin: 6px")
                  (
       @
                     (pdfCanvas 'myPage) )
                  ((NIL 60 "margin: 12px")
                     (
       @
                        (pdfPagePanel)
                        (--)
                        (
       NIL ,"File")
                        (gui '(+UpField) 12)
                        (pdfLoadButton '(field -1))
                        ( 7)
                        (pdfSaveButton) ) ) ) ) ) ) ) )
(de main ()
   #{(locale "DE" "de")}# )

(de go ()
   (retire 10)
   (server (or (format (sys "PORT")) 8080) "!work") )

# vi:et:ts=3:sw=3
picoLisp/misc/pi.l0000644000175000017500000000101211576347167012473 0ustar  abuabu# 16jun11abu
# (c) Software Lab. Alexander Burger

##############################
# Iterative calculation of PI:
#  S = 0
#  P = 2
#  Loop
#     S = sqrt(S+2)
#     P = 2*P/S
##############################

(de pi (N Eps)
   (default N *Scl  Eps 100)
   (let (Scl (** 10 N)  S 0  N2 (* 2 Scl)  P N2  P2 0)
      (while (> (- P P2) Eps)
         (setq
            P2 P
            S (sqrt (* Scl (+ S N2)))
            P (*/ N2 P S) ) ) ) )

(test 3141592653589793238462643383279502884197169399375105820975043
   (pi 60) )
picoLisp/misc/piDigits.l0000644000175000017500000000133611576346465013650 0ustar  abuabu# 16jun11abu
# (c) Software Lab. Alexander Burger

# Spigot algorithm (Jeremy Gibbons)

# Print next digit of PI (unbounded)
(de piDigit ()
   (job '((Q . 1) (R . 0) (S . 1) (K . 1) (N . 3) (L . 3))
      (while (>= (- (+ R (* 4 Q)) S) (* N S))
         (mapc set '(Q R S K N L)
            (list
               (* Q K)
               (* L (+ R (* 2 Q)))
               (* S L)
               (inc K)
               (/ (+ (* Q (+ 2 (* 7 K))) (* R L)) (* S L))
               (+ 2 L) ) ) )
      (prog1 N
         (let M (- (/ (* 10 (+ R (* 3 Q))) S) (* 10 N))
            (setq Q (* 10 Q)  R (* 10 (- R (* N S)))  N M) ) ) ) )

# Print _all_ digits of PI
(prin (piDigit) ".")
(loop
   (prin (piDigit))
   (flush) )

# vi:et:ts=3:sw=3
picoLisp/misc/rcsim.l0000644000175000017500000004666113015542411013176 0ustar  abuabu# 24nov16abu
# (c) Software Lab. Alexander Burger

### RC Flight Simulator for 64-bit PicoLisp ###

# *FocLen *Scene *Model
# *DT *Throttle *Speed *Altitude

(scl 6)  # Keep in sync with `SCL' in C lib

(load "@lib/z3d.l" "@lib/term.l")

# Color Constant Definitions from "/usr/lib/X11/rgb.txt"
(def 'Black     (hex "000000"))
(def 'Blue      (hex "0000FF"))
(def 'Brown     (hex "A52A2A"))
(def 'DarkGreen (hex "006400"))
(def 'DarkGrey  (hex "A9A9A9"))
(def 'Grey      (hex "BEBEBE"))
(def 'LightBlue (hex "ADD8E6"))
(def 'Red       (hex "FF0000"))
(def 'Yellow    (hex "FFFF00"))
(def 'White     (hex "FFFFFF"))

# Create model
(de model (Obj Lst Pos)
   (default Pos `(* 8 12))
   (apply struct
      (conc
         (extract                                        # Faces
            '((M)
               (unless (and (car M) (sym? @))
                  (inc 'Pos 8)
                  (cons
                     (struct
                        (native "@" "malloc" 'N
                           (+ `(* 4 4) (* 8 (length (cddr M)))) )
                        'N
                        (cons (or (num? (car M)) `(hex "1000000")) 4)
                        (cons
                           (or
                              (num? (cadr M))
                              (if (cadr M)
                                 `(hex "2000000")
                                 `(hex "1000000") ) )
                           4 )
                        (- (/ (length (cddr M)) 3))
                        -42
                        (cons 1.0 (cddr M)) )
                     8 ) ) )
            (cddddr Lst) )
         (cons (0 . 8))
         (extract                                        # Submodels
            '((M)
               (when (and (car M) (sym? @))
                  (inc 'Pos 8)
                  (cons
                     (if (cdr M)
                        (model Obj M Pos)
                        (put Obj (car M) Pos)
                        0 )
                     8 ) ) )
            (cddddr Lst) )
         '((0 . 8)) )
      (put Obj (++ Lst)
         (native "@" "malloc" 'N
            (+ `(* 8 12) (* 8 (length (cdr Lst)))) ) )   # (+ 2 CDDDR)
      'N                                                 # Return structure pointer
      (cons 1.0 (head 3 Lst))                            # pos
      (1.0  1.0 0.0 0.0  0.0 1.0 0.0  0.0 0.0 1.0) ) )   # rot

# Simulation
(de *DT . 0.020)
(de *Tower . 12.0)

(de MUL Args
   (let D 1.0
      (make
         (link '*/ (++ Args) (++ Args))
         (while Args
            (setq D (* D 1.0))
            (link (++ Args)) )
         (link D) ) ) )

(de damp ("Var" Val)
   (set "Var" (>> 1 (+ Val (val "Var")))) )

(class +Model)
# mass power rc lc tx tz pitch torq stab
# body leftAileron rightAileron rudder elevator propeller blade disk
# ele ail rud thr thrust vx vy vz fx fy fz dx dy dz

(dm T ()
   (=: mass 910.0)               # kg
   (=: power 3924.0)             # N
   (=: rc -1.4)                  # kg/m
   (=: lc -250.0)                # kg/m
   (=: trim 30)                  # Trimmung
   (=: lim1 0.8)                 # tan(a)
   (=: lim2 0.24)
   (=: tx 1.2)                   # Touchdown
   (=: tz -1.9)
   (=: pitch 0.26)
   (=: torq -10000.0)            # Drehmoment
   (=: stab (0.01 0.01 0.02))    # Stabilitaet
   (model This
      '(body 0.0 0.0 1.50
         # Flaeche oben
         (`Blue `Blue -0.15 +0.30 +1.05  +1.20  0.00 +1.05  +1.20 +3.90 +1.05  +0.90 +4.20 +1.05  -0.20 +3.90 +1.05  -0.60 +2.20 +1.05  -0.60 +0.60 +1.05)
         (`Blue `Blue -0.60 -0.60 +1.05  -0.60 -2.20 +1.05  -0.20 -3.90 +1.05  +0.90 -4.20 +1.05  +1.20 -3.90 +1.05  +1.20  0.00 +1.05  -0.15 -0.30 +1.05)
         (`Blue `Blue +1.20  0.00 +1.05  -0.15 -0.30 +1.05  -0.15 +0.30 +1.05)
         # Querruder
         (rightAileron -0.60 +2.20 +1.05
            (`Red `Red +0.40 +1.70  0.00  +0.72 +1.78 0.00  +0.72 +1.90 0.00  +0.40 +2.10 0.00  0.00 +1.80 0.00  0.00 +1.70 0.00)
            (`Red `Red +0.40 +1.70  0.00   0.00 +1.70 0.00   0.00  0.00 0.00) )
         (leftAileron -0.60 -2.20 +1.05
            (`Red `Red +0.40 -1.70 0.00  +0.72 -1.78 0.00  +0.72 -1.90 0.00  +0.40 -2.10 0.00  0.00 -1.80 0.00  0.00 -1.70 0.00)
            (`Red `Red +0.40 -1.70 0.00   0.00 -1.70 0.00   0.00  0.00 0.00) )
         # Flaeche rechts unten
         (`Blue `Blue +0.90 +0.20 -0.60  +0.90 +3.90 -0.30  +0.60 +4.20 -0.30  -0.90 +3.90 -0.30  -0.90 +0.20 -0.60)
         # Flaeche links unten
         (`Blue `Blue -0.90 -0.20 -0.60  -0.90 -3.90 -0.30  +0.60 -4.20 -0.30  +0.90 -3.90 -0.30  +0.90 -0.20 -0.60)
         # Streben links
         (`Brown `Brown -0.20 -2.55 +1.05  -0.50 -2.55 -0.37  -0.60 -2.55 -0.37  -0.30 -2.55 +1.05)
         (`Brown `Brown -0.50 -2.55 -0.37  -0.50 -2.55 -0.37  +0.80 -2.55 +0.90  +0.80 -2.55 +1.05)
         (`Brown `Brown +0.90 -2.55 +1.05  +0.60 -2.55 -0.37  +0.50 -2.55 -0.37  +0.80 -2.55 +1.05)
         # Streben rechts
         (`Brown `Brown -0.20 +2.55 +1.05  -0.50 +2.55 -0.37  -0.60 +2.55 -0.37  -0.30 +2.55 +1.05)
         (`Brown `Brown -0.50 +2.55 -0.37  -0.50 +2.55 -0.37  +0.80 +2.55 +0.90  +0.80 +2.55 +1.05)
         (`Brown `Brown +0.90 +2.55 +1.05  +0.60 +2.55 -0.37  +0.50 +2.55 -0.37  +0.80 +2.55 +1.05)
         # Motorlager
         (`Grey NIL +1.80 +0.30 +0.30  +1.80 -0.30 +0.30  +1.80 -0.30 -0.30  +1.80 +0.30 -0.30)
         # Rumpfnase
         (`Blue NIL +1.20  0.00 +0.60  +1.80 -0.30 +0.30  +1.80 +0.30 +0.30)
         (`Blue NIL +1.20  0.00 +0.60  +1.20 -0.45 +0.30  +1.80 -0.30 +0.30)
         (`Blue NIL +1.80 +0.30 +0.30  +1.20 +0.45 +0.30  +1.20  0.00 +0.60)
         (`Blue NIL +1.20 -0.45 +0.30  +1.20 -0.45 -0.30  +1.80 -0.30 -0.30  +1.80 -0.30 +0.30)
         (`Blue NIL +1.80 +0.30 +0.30  +1.80 +0.30 -0.30  +1.20 +0.45 -0.30  +1.20 +0.45 +0.30)
         (`Blue NIL +1.20 -0.45 -0.30  +1.20 -0.30 -0.60  +1.80 -0.30 -0.30)
         (`Blue NIL +1.80 +0.30 -0.30  +1.20 +0.30 -0.60  +1.20 +0.45 -0.30)
         (`Blue NIL +1.20 -0.30 -0.60  +1.20 +0.30 -0.60  +1.80 +0.30 -0.30  +1.80 -0.30 -0.30)
         # Rumpfseite rechts
         (`Red NIL +1.20 +0.45 +0.30  +1.20 +0.45 -0.30  -1.50 +0.45 -0.30  -1.50 +0.45 +0.30  -1.20 +0.45 +0.45  -0.90 +0.45 +0.45)
         (`Red NIL -1.50 +0.45 +0.30  -1.50 +0.45 -0.30  -4.80  0.00 -0.30 -4.80   0.00  0.00)
         # Rumpfseite links
         (`Red NIL -0.90 -0.45 +0.45  -1.20 -0.45 +0.45  -1.50 -0.45 +0.30  -1.50 -0.45 -0.30  +1.20 -0.45 -0.30  +1.20 -0.45 +0.30)
         (`Red NIL -4.80  0.00  0.00  -4.80  0.00 -0.30  -1.50 -0.45 -0.30  -1.50 -0.45 +0.30)
         # Rumpfoberteil vorne
         (`Red NIL +1.20 0.00 +0.60  +1.20 +0.45 +0.30  -0.90 +0.45 +0.45  -0.60 0.00 +0.60)
         (`Red NIL -0.60 0.00 +0.60  -0.90 -0.45 +0.45  +1.20 -0.45 +0.30  +1.20 0.00 +0.60)
         # Cockpit
         (`Brown NIL -0.60  0.00 +0.60  -0.90 +0.45 +0.45  -0.90 -0.45 +0.45)
         (`Black NIL -0.90 +0.45 +0.45  -1.20 +0.45 +0.45  -1.20 -0.45 +0.45  -0.90  -0.45  +0.45)
         (`Black NIL -1.20 +0.45 +0.45  -1.35  0.00 +0.54  -1.20 -0.45 +0.45)
         # Rumpfoberteil hinten
         (`Red NIL -1.35  0.00 +0.54  -1.20 +0.45 +0.45  -4.80  0.00  0.00)
         (`Red NIL -1.20 +0.45 +0.45  -1.50 +0.45 +0.30  -4.80  0.00  0.00)
         (`Red NIL -4.80  0.00  0.00  -1.20 -0.45 +0.45  -1.35  0.00 +0.54)
         (`Red NIL -4.80  0.00  0.00  -1.50 -0.45 +0.30  -1.20 -0.45 +0.45)
         # Rumpfboden
         (`Red NIL +1.20 +0.45 -0.30  +1.20 +0.30 -0.60  -1.50 +0.30 -0.60  -1.50 +0.45 -0.30)
         (`Red NIL +1.20 +0.30 -0.60  +1.20 -0.30 -0.60  -1.50 -0.30 -0.60  -1.50 +0.30 -0.60)
         (`Red NIL -1.50 -0.45 -0.30  -1.50 -0.30 -0.60  +1.20 -0.30 -0.60  +1.20 -0.45 -0.30)
         (`Red NIL -4.80  0.00 -0.30  -1.50 -0.30 -0.60  -1.50 -0.45 -0.30)
         (`Red NIL -4.80  0.00 -0.30  -1.50 +0.30 -0.60  -1.50 -0.30 -0.60)
         (`Red NIL -1.50 +0.45 -0.30  -1.50 +0.30 -0.60  -4.80  0.00 -0.30)
         # Hoehenleitwerk
         (`Red `Red -3.60 +0.15 0.00  -4.20 +1.80 0.00  -4.50 +1.80 0.00  -4.50 +0.06 0.00)
         (`Red `Red -4.50 -0.06 0.00  -4.50 -1.80 0.00  -4.20 -1.80 0.00  -3.60 -0.15 0.00)
         # Hoehenruder
         (elevator -4.50 0.00 0.00
            (`Blue `Blue 0.00 +1.80 0.00  -0.60 +1.50 0.00  -0.60 +0.60 0.00  0.00 +0.06 0.00)
            (`Blue `Blue 0.00 -0.06 0.00  -0.60 -0.60 0.00  -0.60 -1.50 0.00  0.00 -1.80 0.00) )
         # Seitenleitwerk
         (`Red `Red -4.80 0.00 0.00  -3.60 0.00 +0.15  -4.20 0.00 +0.90  -4.80 0.00 +1.05)
         # Seitenruder
         (rudder -4.80 0.00 0.00
            (`Blue `Blue 0.00 0.00 +1.05  0.00 0.00 -0.30  -0.45 0.00 +0.30  -0.45 0.00 +0.90) )
         # Schatten Nase
         (NIL T +0.90 -0.30 -0.20  +1.70 0.00 -0.20  +0.90 +0.30 -0.20)
         # Schatten Flaechen
         (NIL T +0.90 -3.00 -0.20  +0.90 +3.00 -0.20  -0.90 +3.00 -0.20  -0.90 -3.00 -0.20)
         # Schatten Rumpf
         (NIL T -0.90 -0.40 -0.20  -0.90 +0.40 -0.20  -4.70 0.00 -0.20)
         # Schatten Leitwerk
         (NIL T -3.60 0.00 -0.20  -4.20 +1.80 -0.20  -4.50 +1.80 -0.20  -4.50 -1.80 -0.20  -4.20 -1.80 -0.20)
         # Spinner
         (`Blue NIL +1.80 +0.15 -0.15  +1.80 +0.15 +0.15  +2.10 0.00 0.00)
         (`Blue NIL +1.80 -0.15 -0.15  +1.80 +0.15 -0.15  +2.10 0.00 0.00)
         (`Blue NIL +1.80 -0.15 +0.15  +1.80 -0.15 -0.15  +2.10 0.00 0.00)
         (`Blue NIL +1.80 +0.15 +0.15  +1.80 -0.15 +0.15  +2.10 0.00 0.00)
         # Fahrwerk
         (`Grey `Grey +1.20 +0.30 -0.60  +1.20 +0.90 -1.47  +1.20 +1.00 -1.47  +1.20 +0.40 -0.60)
         (`Grey `Grey +1.20 -0.30 -0.60  +1.20 -0.90 -1.47  +1.20 -1.00 -1.47  +1.20 -0.40 -0.60)
         (`Grey `Grey +1.20 -1.20 -1.47  +1.20 -1.20 -1.53  +1.20 +1.20 -1.53  +1.20 +1.20 -1.47)
         (`Grey `Grey +1.20 +0.90 -1.53  +1.20 +0.90 -1.47  +0.30 +0.30 -0.60  +0.18 +0.30 -0.60)
         (`Grey `Grey +1.20 -0.90 -1.53  +1.20 -0.90 -1.47  +0.30 -0.30 -0.60  +0.18 -0.30 -0.60)
         # Rad rechts
         (`Yellow `Yellow +1.20 +1.20 -1.20  +1.38 +1.20 -1.25  +1.50 +1.20 -1.37  +1.55 +1.20 -1.55  +1.50 +1.20 -1.73  +1.38 +1.20 -1.85  +1.20 +1.20 -1.90  +1.02 +1.20 -1.85  +0.90 +1.20 -1.72  +0.85 +1.20 -1.55  +0.90 +1.20 -1.37  +1.02 +1.20 -1.25)
         # Schatten Rad rechts
         (NIL T +1.60 +1.00 -1.55  +1.60 +1.40 -1.55  +0.80 +1.40 -1.55  +0.80 +1.00 -1.55)
         # Rad links
         (`Yellow `Yellow +1.20 -1.20 -1.20  +1.38 -1.20 -1.25  +1.50 -1.20 -1.37  +1.55 -1.20 -1.55  +1.50 -1.20 -1.73  +1.38 -1.20 -1.85  +1.20 -1.20 -1.90  +1.02 -1.20 -1.85  +0.90 -1.20 -1.72  +0.85 -1.20 -1.55  +0.90 -1.20 -1.37  +1.02 -1.20 -1.25)
         # Schatten Rad links
         (NIL T +1.60 -1.00 -1.55  +1.60 -1.40 -1.55  +0.80 -1.40 -1.55  +0.80 -1.00 -1.55)
         # Platzhalter
         (propeller) ) )
   (model This
      '(blade +1.95 0.00 0.00
         (`Black `Black -0.05 0.00 0.00  +0.05 0.00 0.00  +0.02 +0.40 -0.50  +0.00 +0.90 -0.90  -0.02 +0.50 -0.40  -0.05 0.00 0.00  -0.02 -0.50 +0.40  +0.00 -0.90 +0.90  +0.02 -0.40 +0.50  +0.05 0.00 0.00) ) )
   (model This
      '(disk +1.95 0.00 0.00
         (NIL NIL +0.00 -0.30 +1.20  +0.00 -0.90 +0.90  +0.00 -1.20 +0.30  +0.00 -1.20 -0.30  +0.00 -0.90 -0.90  +0.00 -0.30 -1.20  +0.00 +0.30 -1.20  +0.00 +0.90 -0.90  +0.00 +1.20 -0.30  +0.00 +1.20 +0.30  +0.00 +0.90 +0.90  +0.00 +0.30 +1.20) ) )
   (=: ele (=: ail (=: rud (=: thr (=: thrust 0)))))
   (=: vx (=: vy (=: vz 0)))
   (=: fx (=: fy (=: fz 0)))
   (=: dx (=: dy (=: dz 0)))
   (z3dDX (: body) -100.0)
   (z3dDY (: body) -200.0)
   (z3dYrot (: body) 0.26)
   (inc (:: propeller) (: body))
   (=: blade (cons (: blade) 8))
   (=: disk (cons (: disk) 8))
   (struct (: propeller) NIL (: blade)) )

(dm dir> (VarX VarY)
   (let B (struct (: body) (1.0 . 3))
      (z3dSpot VarX VarY
         (+ (car B) (>> 3 (: vx)) (>> 2 (: vz)))
         (+ (cadr B) (>> 3 (: vy)) (>> 2 (: vz)))
         (-
            (+ (caddr B) (>> 3 (: vz)) (>> 2 (: vz)))
            *Tower ) ) ) )

(dm down> ()
   (when (> (: ele) -100)
      (dec (:: ele) 20)
      (z3dArot (: elevator) +0.2) ) )

(dm up> ()
   (when (> 100 (: ele))
      (inc (:: ele) 20)
      (z3dArot (: elevator) -0.2) ) )

(dm left> ()
   (when (> (: ail) -100)
      (dec (:: ail) 20)
      (dec (:: rud) 20)
      (z3dArot (: leftAileron) +0.2)
      (z3dArot (: rightAileron) +0.2)
      (z3dArot (: rudder) +0.2) ) )

(dm right> ()
   (when (> 100 (: ail))
      (inc (:: ail) 20)
      (inc (:: rud) 20)
      (z3dArot (: leftAileron) -0.2)
      (z3dArot (: rightAileron) -0.2)
      (z3dArot (: rudder) -0.2) ) )

(dm throt> (X)
   (=: thr
      (cond
         ((not X) 0)
         ((=T X) 100)
         ((lt0 X) (max 10 (- (: thr) 25)))
         ((=0 (: thr)) 10)
         ((= 10 (: thr)) 25)
         (T (min 100 (+ 25 (: thr)))) ) ) )

(dm sim> ()
   (cond
      ((gt0 (: ele))
         (dec (:: ele))
         (z3dArot (: elevator) +0.01) )
      ((lt0 (: ele))
         (inc (:: ele))
         (z3dArot (: elevator) -0.01) ) )
   (cond
      ((gt0 (: ail))
         (dec (:: ail))
         (dec (:: rud))
         (z3dArot (: leftAileron) +0.01)
         (z3dArot (: rightAileron) +0.01)
         (z3dArot (: rudder) +0.01) )
      ((lt0 (: ail))
         (inc (:: ail))
         (inc (:: rud))
         (z3dArot (: leftAileron) -0.01)
         (z3dArot (: rightAileron) -0.01)
         (z3dArot (: rudder) -0.01) ) )
   (cond
      ((> (: thr) (: thrust))
         (inc (:: thrust)) )
      ((> (: thrust) (: thr))
         (dec (:: thrust)) ) )
   (struct (: propeller) NIL
      (if (> 20 (: thrust))
         (: blade)
         (: disk) ) )
   (unless (=0 (: thrust))
      (z3dXrot
         (if (> 20 (: thrust))
            (: blade 1)
            (: disk 1) )
         0.2 ) )
   (use (Touch VX VY VZ Body Taxi Stick A FX FY FZ DX DY DZ)
      (z3dRotate (: body) (: tx) 0 (: tz) NIL NIL 'Touch)
      (z3dRotate (: body) (: vx) (: vy) (: vz) 'VX 'VY 'VZ T)
      (setq
         Body (struct (: body) (1.0 . 12))
         Taxi (> 0.1 (+ (caddr Body) Touch))
         Stick (>= 1.0 (+ VX VY))
         FX (+ (*/ (: thrust) (: power) 100) `(MUL (: rc) VX (abs VX)))
         FZ (+
            (cond
               ((> 0.1 VX) 0)
               ((> (abs (setq A (*/ 1.0 VZ VX))) (: lim2))
                  0 )
               ((>= (: lim1) A)
                  `(MUL VX VX (: lc) A) )
               (T `(MUL VX VX (: lc) (- (: lim2) A))) )
            `(MUL 8.0 (: rc) VZ (abs VZ)) ) )
      (ifn Taxi
         (setq FY `(MUL 4.0 (: rc) VY (abs VY)))
         (let F (>> 2 (: mass))
            (cond
               ((> 0.1 (abs VX))
                  (and (>= F FX) (zero FX)) )
               ((gt0 VX)
                  (dec 'FX F) )
               (T (inc 'FX F)) )
            (setq FY (if (lt0 VY) (* 12 F) (* -12 F))) )
         (z3dYrot (: body)
            (>> 3 (- (: pitch) (get Body 6))) ) )  # rot.a.z
      (unless Stick
         (z3dYrot (: body)
            (+
               (*/ VX (+ (: ele) (: trim)) 80000)
               `(MUL VZ (: stab 2)) ) )
         (if Taxi
            (prog
               (z3dZrot (: body) (*/ VX (: rud) 80000))
               (z3dXrot (: body) (get Body 9)) )  # rot.b.z
            (z3dXrot (: body)  # roll
               (+
                  (- (*/ VX (: ail) 80000) (/ VY 400))
                  (*/ (: thrust) (: torq) (: mass))
                  `(MUL (get Body 9) (: stab 1)) ) )  # rot.b.z
            (z3dZrot (: body)
               (+
                  (*/ VX (: rud) 80000)
                  `(MUL VY (: stab 3)) ) ) ) )
      # World system
      (z3dRotate (: body) FX FY FZ 'FX 'FY 'FZ)
      (dec 'FZ `(MUL (: mass) 9.81))
      # Accelerate
      (setq
         A (*/ 1.0 *DT (: mass))
         DX `(MUL A (damp (:: fx) FX))
         DY `(MUL A (damp (:: fy) FY))
         DZ `(MUL A (damp (:: fz) FZ)) )
      (if (and Stick (> 0.001 (+ `(MUL DX DX) `(MUL DY DY))))
         (=: vx (=: vy (=: dx (=: dy 0))))
         (inc (:: vx) (damp (:: dx) DX))
         (inc (:: vy) (damp (:: dy) DY)) )
      (inc (:: vz) (damp (:: dz) DZ))
      (when (and Taxi (lt0 (: vz)))
         (when (> -6.0 (: vz))
            (=: thr (=: thrust 0))
            (=: vx (=: vy 0))
            (struct (: propeller) NIL (: blade)) )
         (z3dZ (: body) (- Touch))
         (=: vz 0) )
      # Translate
      (z3dDX (: body) `(MUL (: vx) *DT))
      (z3dDY (: body) `(MUL (: vy) *DT))
      (z3dDZ (: body) `(MUL (: vz) *DT))
      # Instruments
      (setq
         *Throttle (: thr)
         *Speed (*/ VX 3.6 `(* 1.0 1.0))
         *Altitude (/ (caddr Body) 1.0) ) ) )

(dm draw> ()
   (z3dDraw (: body)) )

# Scene
(class +Scene)
# env

(dm T ()
   (model This
      '(runway1 -120.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway2 -80.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway3 -40.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway4 0.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway5 +40.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway6 +80.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (model This
      '(runway7 +120.0 -200.0 -0.02
         (`DarkGrey NIL +20.0 -20.0 0  +20.0 +20.0 0  -20.0 +20.0 0  -20.0 -20.0 0)
         (`White NIL +10.0 -1.0 0  +10.0 +1.0 0  -10.0 +1.0 0  -10.0 -1.0 0) ) )
   (=: env
      (list
         (: runway1)
         (: runway2)
         (: runway3)
         (: runway4)
         (: runway5)
         (: runway6)
         (: runway7) ) ) )

(dm sim> ())

(dm draw> ()
   (mapc z3dDraw (: env)) )

# Key Controls
(fkey *XtIns   (and (> 32000.0 *FocLen) (setq *FocLen (>> -1 *FocLen))))
(fkey *XtDel   (and (> *FocLen 2000.0) (setq *FocLen (>> 1 *FocLen))))
(fkey *XtUp    (down> *Model))
(fkey *XtDown  (up> *Model))
(fkey *XtLeft  (left> *Model))
(fkey *XtRight (right> *Model))
(fkey *XtHome  (throt> *Model T))
(fkey *XtPgDn  (throt> *Model -1))
(fkey *XtPgUp  (throt> *Model +1))
(fkey *XtEnd   (throt> *Model))

# Init/Run
(de main ()
   (setq
      *FocLen 8000.0
      *Scene (new '(+Scene))
      *Model (new '(+Model)) ) )

(de go ()
   (when (z3dWindow "RC Simulator" 800 600)
      (quit @) )
   (zero "MSec")
   (task `(*/ -1000 *DT 1.0) 0  # -Milliseconds
      (let R (assoc @ *Run)
         (sim> *Scene)
         (sim> *Model)
         (use (Yaw Pitch)
            (dir> *Model 'Yaw 'Pitch)
            (z3dCamera *FocLen Yaw Pitch  0 0 *Tower  LightBlue DarkGreen) )
         (draw> *Scene)
         (draw> *Model)
         (z3dPut)
         (z3dText 20 580 (pack *Throttle " %"))
         (z3dText 120 580 (pack *Speed " km/h"))
         (z3dText 220 580 (pack *Altitude " m"))
         (z3dText 320 580
            (case *FocLen
               (2000.0 "(--)")
               (4000.0 "(-)")
               (16000.0 "(+)")
               (32000.0 "(++)") ) )
         (z3dSync)
         (let M (*/ (usec) 1000)
            (setq "MSec"
               (- M
                  (set (cdr R)
                     (min -2 (- M "MSec" `(*/ 1000 *DT 1.0))) ) ) ) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/misc/reverse.l0000644000175000017500000000044113167327615013535 0ustar  abuabu# 11oct17abu
# (c) Software Lab. Alexander Burger

(setq *Port (port 6789))

(loop
   (setq *Sock (listen *Port))
   (unless (fork)
      (close *Port)
      (in *Sock
         (until (eof)
            (out *Sock
               (prinl (flip (line))) ) ) )
      (bye) )
   (close *Sock) )
picoLisp/misc/sieve.l0000644000175000017500000000047011341501060013153 0ustar  abuabu# 25feb10abu
# (c) Software Lab. Alexander Burger

# Sieve of Eratosthenes
(de sieve (N)
   (let Sieve (range 1 N)
      (set Sieve)
      (for I (cdr Sieve)
         (when I
            (for (S (nth Sieve (* I I)) S (nth (cdr S) I))
               (set S) ) ) )
      (filter bool Sieve) ) )

# vi:et:ts=3:sw=3
picoLisp/misc/setf.l0000644000175000017500000000146310750302011013002 0ustar  abuabu# 31jan08abu
# (c) Software Lab. Alexander Burger

# 'setf' is the most perverse concept ever introduced into Lisp
(de setf "Args"
   (let "P" (car "Args")
      (set
         (if (atom "P")
            "P"
            (let (: ::  get prop  car prog  cadr cdr  caddr cadr  cadddr caddr)
               (eval "P") ) )
         (eval (cadr "Args")) ) ) )

### Test ###
(test 7
   (use A
      (setf A 7)
      A ) )

(test (7 2 3)
   (let L (1 2 3)
      (setf (car L) 7)
      L ) )

(test (1 7 3)
   (let L (1 2 3)
      (setf (cadr L) 7)
      L ) )

(test 7
   (put 'A 'a 1)
   (setf (get 'A 'a) 7)
   (get 'A 'a) )

(test 7
   (put 'A 'a 1)
   (with 'A
      (setf (: a) 7)
      (: a) ) )

# But also:
(undef 'foo)
(de foo (X)
   (cadr X) )

(test (1 7 3)
   (let L (1 2 3) (setf (foo L) 7) L) )

# vi:et:ts=3:sw=3
picoLisp/misc/stress.l0000644000175000017500000000310212645467340013402 0ustar  abuabu# 13jan16abu
# (c) Software Lab. Alexander Burger
# Use: nice pil misc/stress.l -main -go -bye; rm db/test jnl db/test2

(load "@lib/too.l")

(class +A +Entity)
(rel key (+Key +Number))               # Key  1 .. 999
(rel dat (+Ref +Number))               # Data 1 .. 999

(de rnd ()
   (rand 1 999) )

(de modify (N)
   (do N
      (do (rand 10 40)
         (let K (rnd)
            (with (db 'key '+A K)
               (unless (= K (: key))
                  (quit "key mismatch" K) ) ) ) )
      (dbSync)
      (let (D (rnd)  X (db 'key '+A (rnd)))
         (inc *DB (- D (get X 'dat)))
         (put> X 'dat D) )
      (commit 'upd) ) )

(de verify ()
   (dbCheck)
   (let N 0
      (scan (tree 'dat '+A)
         '((K V)
            (unless (= (car K) (get V 'dat))
               (quit "dat mismatch" K) )
            (inc 'N (car K)) ) )
      (unless (= N (val *DB))
         (quit "val mismatch" (- N (val *DB))) ) ) )

(de main ()
   (seed (in "/dev/urandom" (rd 8)))
   (call "mkdir" "-p" "db")
   (call "rm" "-f" "db/test" "jnl" "db/test2")
   (pool "db/test" NIL "jnl")
   (set *DB 0)
   (for K 999
      (let D (rnd)
         (new T '(+A)  'key K  'dat D)
         (inc *DB D) ) )
   (commit) )

(de go ()
   (do 10
      (let Pids
         (make
            (do 40
               (rand)
               (if (fork)
                  (link @)
                  (modify 999)
                  (bye) ) ) )
         (while (find '((P) (kill P 0)) Pids)
            (wait 1000) )
         (rollback) ) )
   (verify)
   (pool "db/test2")
   (journal "jnl")
   (call "cmp" "db/test" "db/test2") )
picoLisp/misc/travel.l0000644000175000017500000000242007745473003013354 0ustar  abuabu# 22oct03abu
# (c) Software Lab. Alexander Burger

(de travel (A B)
   (mini car
      (solve
         (quote
            @A A
            @B B
            (path @A @B @P @N) )
         (cons @N @P) ) ) )


(be path (@A @B @P @N) (path1 @A @B (@A) @P @N))

(be path1 (@A @A @L (@A) 0))
(be path1 (@A @B @L (@A . @P) @N)
   (edge @A @Z @X)
   (not (member @Z @L))
   (path1 @Z @B (@Z . @L) @P @Y)
   (@N + (-> @X) (-> @Y)) )

(be edge (@A @B @N) (vect @A @B @N))
(be edge (@A @B @N) (vect @B @A @N))

(be vect (Rheine Muenster 39))
(be vect (Rheine Osnabrueck 42))
(be vect (Muenster Osnabrueck 51))
(be vect (Warendorf Muenster 28))
(be vect (Warendorf Osnabrueck 43))
(be vect (Warendorf Rheda 24))
(be vect (Warendorf Guetersloh 27))
(be vect (Osnabrueck Bielefeld 48))
(be vect (Rheda Guetersloh 10))
(be vect (Bielefeld Guetersloh 16))
(be vect (Bielefeld Paderborn 39))
(be vect (Paderborn Guetersloh 31))
(be vect (Paderborn Rheda 32))
(be vect (Paderborn Soest 41))
(be vect (Soest Rheda 38))
(be vect (Soest Beckum 26))
(be vect (Beckum Rheda 24))
(be vect (Beckum Warendorf 27))
(be vect (Ahlen Warendorf 27))
(be vect (Ahlen Muenster 46))
(be vect (Ahlen Beckum 11))
(be vect (Ahlen Soest 27))

(test
   '(123 Rheine Muenster Warendorf Rheda Paderborn)
   (travel 'Rheine 'Paderborn) )
picoLisp/misc/trip.l0000644000175000017500000000431413015543044013027 0ustar  abuabu# 24nov16abu
# (c) Software Lab. Alexander Burger

(load "@lib/simul.l")

# Set up distance properties
# See "misc/travel.l" and "doc/travel"
(mapc
   '((L)
      (put (car L) (cadr L) (caddr L))
      (put (cadr L) (car L) (caddr L)) )
   (quote
      (Rheine Muenster 39)
      (Rheine Osnabrueck 42)
      (Muenster Osnabrueck 51)
      (Warendorf Muenster 28)
      (Warendorf Osnabrueck 43)
      (Warendorf Rheda 24)
      (Warendorf Guetersloh 27)
      (Osnabrueck Bielefeld 48)
      (Rheda Guetersloh 10)
      (Bielefeld Guetersloh 16)
      (Bielefeld Paderborn 39)
      (Paderborn Guetersloh 31)
      (Paderborn Rheda 32)
      (Paderborn Soest 41)
      (Soest Rheda 38)
      (Soest Beckum 26)
      (Beckum Rheda 24)
      (Beckum Warendorf 27)
      (Ahlen Warendorf 27)
      (Ahlen Muenster 46)
      (Ahlen Beckum 11)
      (Ahlen Soest 27) ) )

# Find a route from 'A' to 'B'
(de route (A B Lst)
   (if (get A B)
      (list A B)
      (and
         (pick
            '((X)
               (and
                  (not (memq X Lst))
                  (route X B (cons A Lst)) ) )
            (shuffle (mapcar cdr (getl A))) )
         (cons A @) ) ) )

# Minimize trip from 'A' to 'B'
(de trip (Pop Gen A B)
   (gen
      (make (do Pop (link (route A B))))  # Population
      '((Pop) (lt0 (dec 'Gen)))  # Condition
      '((X Y)  # Recombination
         (make
            (while (prog (link (++ X)) X)
               (when (member (car X) (cdr Y))
                  (setq Y @)
                  (xchg 'X 'Y) ) ) ) )
      '((L)  # Mutation
         (let (N (length L)  H (>> 1 N)  N1 (rand 1 H)  N2 (rand (inc H) N))
            (if (route (get L N1) (get L N2))
               (append
                  (head (dec N1) L)
                  @
                  (nth L (inc N2)) )
               L ) ) )
      '((L)  # Selection
         (let A (++ L)
            (-
               (sum
                  '((X) (get A (setq A X)))
                  L ) ) ) ) ) )

# Optimum hit percentage, e.g. (tst 12 8)
(de tst (Pop Gen)
   (let OK 0
      (do 100
         (when
            (=
               (trip Pop Gen 'Rheine 'Paderborn)
               '(Rheine Muenster Warendorf Rheda Paderborn) )
            (inc 'OK) ) )
      OK ) )
picoLisp/app/cusu.l0000644000175000017500000000250613514101403012647 0ustar  abuabu# 18jul19 Software Lab. Alexander Burger

(must "Customer/Supplier" Customer)

(menu ,"Customer/Supplier"
   (idForm ,"Customer/Supplier" '(choCuSu) 'nr '+CuSu T '(may Delete)
      '((: nr) " -- " (: nm))
      (
      )
      (
         (,"Name"
            ( 3
               ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10)
               ,"Salutation" (choSal 0)
               (gui '(+E/R +Obj +TextField) '(sal : home obj) '(nm +Sal) 20)
               ,"Name" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Name" 40)
               ,"Name 2" NIL (gui '(+E/R +TextField) '(nm2 : home obj) 40) ) )
         (,"Address"
            ( 2
               ,"Street" (gui '(+E/R +TextField) '(str : home obj) 40)
               NIL NIL
               ,"Zip" (gui '(+E/R +TextField) '(plz : home obj) 10)
               ,"City" (gui '(+E/R +TextField) '(ort : home obj) 40) ) )
         (,"Contact"
            ( 2
               ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40)
               ,"Fax" (gui '(+E/R +TelField) '(fax : home obj) 40)
               ,"Mobile" (gui '(+E/R +TelField) '(mob : home obj) 40)
               ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) )
         ((pack (and (: obj txt) "@ ") ,"Memo")
            (gui '(+BlobField) '(txt : home obj) 60 8) ) )
      (
      ) ) )
picoLisp/app/er.l0000644000175000017500000001203513223733514012307 0ustar  abuabu# 05jan18abu
# (c) Software Lab. Alexander Burger

### Entity/Relations ###
#
#           nr    nm                   nr    nm               nm
#            |    |                     |    |                |
#          +-*----*-+                 +-*----*-+           +--*-----+
#          |        |             sup |        |           |        |
#    str --*  CuSu  O-----------------*  Item  *-- inv     |  Role  @-- perm
#          |        |                 |        |           |        |
#          +-*-*--O-+                 +----O---+           +----@---+
#            | |  |                        |                    | usr
#   nm  tel -+ |  |                        |                    |
#    |         |  |                        | itm                | role
#  +-*-----+   |  |   +-------+        +---*---+           +----*---+
#  |       |   |  |   |       |    ord |       |           |        |
#  |  Sal  +---+  +---*  Ord  @--------*  Pos  |      nm --*  User  *-- pw
#  |       |      cus |       | pos    |       |           |        |
#  +-*---*-+          +-*---*-+        +-*---*-+           +--------+
#    |   |              |   |            |   |
#   hi   sex           nr  dat          pr   cnt

# Salutation
(class +Sal +Entity)
(rel nm (+Key +String))                # Salutation
(rel hi (+String))                     # Greeting
(rel sex (+Any))                       # T:male, 0:female

(dm url> (Tab)
   (and (may Customer) (list "app/sal.l" '*ID This)) )

(dm hi> (Nm)
   (or (text (: hi) Nm) ,"Dear Sir or Madam,") )


# Customer/Supplier
(class +CuSu +Entity)
(rel nr (+Need +Key +Number))          # Customer/Supplier Number
(rel sal (+Link) (+Sal))               # Salutation
(rel nm (+Sn +IdxFold +String))        # Name
(rel nm2 (+String))                    # Name 2
(rel str (+String))                    # Street
(rel plz (+Ref +String))               # Zip
(rel ort (+IdxFold +String))           # City
(rel tel (+Fold +Ref +String))         # Phone
(rel fax (+String))                    # Fax
(rel mob (+Fold +Ref +String))         # Mobile
(rel em (+String))                     # EMail
(rel txt (+Blob))                      # Memo

(dm url> (Tab)
   (and (may Customer) (list "app/cusu.l"  '*Tab Tab  '*ID This)) )

(dm check> ()
   (make
      (or (: nr) (link ,"No customer number"))
      (or (: nm) (link ,"No customer name"))
      (unless (and (: str) (: plz) (: ort))
         (link ,"Incomplete customer address") ) ) )


# Item
(class +Item +Entity)
(rel nr (+Need +Key +Number))          # Item Number
(rel nm (+IdxFold +String))            # Item Description
(rel sup (+Ref +Link) NIL (+CuSu))     # Supplier
(rel inv (+Number))                    # Inventory
(rel pr (+Ref +Number) NIL 2)          # Price
(rel txt (+Blob))                      # Memo
(rel jpg (+Blob))                      # Picture

(dm url> (Tab)
   (and (may Item) (list "app/item.l" '*ID This)) )

(dm cnt> ()
   (-
      (or (: inv) 0)
      (sum '((This) (: cnt))
         (collect 'itm '+Pos This) ) ) )

(dm check> ()
   (make
      (or (: nr) (link ,"No item number"))
      (or (: nm) (link ,"No item description")) ) )


# Order
(class +Ord +Entity)
(rel nr (+Need +Key +Number))          # Order Number
(rel dat (+Need +Ref +Date))           # Order date
(rel cus (+Ref +Link) NIL (+CuSu))     # Customer
(rel pos (+List +Joint) ord (+Pos))    # Positions

(dm lose> (Lst)
   (mapc 'lose> (: pos))
   (super Lst) )

(dm url> (Tab)
   (and (may Order) (list "app/ord.l" '*ID This)) )

(dm sum> ()
   (sum 'sum> (: pos)) )

(dm check> ()
   (make
      (or (: nr) (link ,"No order number"))
      (or (: dat) (link ,"No order date"))
      (if (: cus)
         (chain (check> @))
         (link ,"No customer") )
      (if (: pos)
         (chain (mapcan 'check> @))
         (link ,"No positions") ) ) )


(class +Pos +Entity)
(rel ord (+Dep +Joint)                 # Order
   (itm)
   pos (+Ord) )
(rel itm (+Ref +Link) NIL (+Item))     # Item
(rel pr (+Number) 2)                   # Price
(rel cnt (+Number))                    # Quantity

(dm sum> ()
   (* (: pr) (: cnt)) )

(dm check> ()
   (make
      (if (: itm)
         (chain (check> @))
         (link ,"Position without item") )
      (or (: pr) (link ,"Position without price"))
      (or (: cnt) (link ,"Position without quantity")) ) )


# Database sizes
(dbs
   (3 +Role +User +Sal (+User pw))              # 512 Prevalent objects
   (0 +Pos)                                     # A:64 Tiny objects
   (1 +Item +Ord)                               # B:128 Small objects
   (2 +CuSu)                                    # C:256 Normal objects
   (2 (+Role nm) (+User nm) (+Sal nm))          # D:256 Small indexes
   (4 (+CuSu nr plz tel mob))                   # E:1024 Normal indexes
   (4 (+CuSu nm))                               # F:1024
   (4 (+CuSu ort))                              # G:1024
   (4 (+Item nr sup pr))                        # H:1024
   (4 (+Item nm))                               # I:1024
   (4 (+Ord nr dat cus))                        # J:1024
   (4 (+Pos itm)) )                             # K:1024

# vi:et:ts=3:sw=3
picoLisp/app/gui.l0000644000175000017500000002031512713576252012474 0ustar  abuabu# 08may16abu
# (c) Software Lab. Alexander Burger

### GUI ###
(de menu (Ttl . Prg)
   (action
      (html 0 Ttl *Css NIL
         ( 7)
         (
            ((180 0 'menu)
               (
       @
                  (expires)
                  (
                     (,"Home" "!work")
                     (,"logout" (and *Login "!stop"))
                     (NIL (
      ))
                     (T ,"Data"
                        (,"Orders" (and (may Order) "app/ord.l"))
                        (,"Items" (and (may Item) "app/item.l"))
                        (,"Customers/Suppliers" (and (may Customer) "app/cusu.l"))
                        (,"Salutations" (and (may Customer) "app/sal.l")) )
                     (T ,"Report"
                        (,"Inventory" (and (may Report) "app/inventory.l"))
                        (,"Sales" (and (may Report) "app/sales.l")) )
                     (T ,"System"
                        (,"Role Administration" (and (may RoleAdmin) "@lib/role.l"))
                        (,"User Administration" (and *Login "@lib/user.l") (unless (may UserAdmin) *Login)) ) ) )
               ((NIL NIL 'main)
                  (
       @ (run Prg 1)) ) ) ) ) ) )

(de work ()
   (setq *Url "!work")
   (and (app) (setq *Menu 3))
   (menu "PicoLisp App"
      (
       NIL "PicoLisp App")
      ( "@img/7fachLogo.png" "7fach Logo" NIL "50%")
      (----)
      (form NIL
         (gui '(+Init +Map +TextField)
            (cons *Ctry *Lang)
            *Locales
            (mapcar car *Locales)
            ',"Language" )
         (gui '(+Button) ',"Change"
            '(let V (val> (field -1))
               (locale (car V) (cdr V) "app/loc/") ) ) )
      (loginForm) ) )

(de stop ()
   (logout)
   (work) )

# Search dialogs
(de choSal (Dst)
   (choDlg Dst ,"Salutations" '(nm +Sal)) )

(de choCuSu (Dst)
   (diaform '(Dst)
      ( "--.-.-."
         ,"Number" (gui 'nr '(+Var +NumField) '*CuSuNr 10)
         ,"Name" (gui 'nm '(+Focus +Var +TextField) '*CuSuNm 30)
         ,"Phone" (gui 'tel '(+Var +TelField) '*CuSuTel 20)
         (searchButton '(init> (: home query)))
         ,"Zip" (gui 'plz '(+Var +TextField) '*CuSuPlz 10)
         ,"City" (gui 'ort '(+Var +TextField) '*CuSuOrt 30)
         ,"Mobile" (gui 'mob '(+Var +TelField) '*CuSuMob 20)
         (resetButton '(nr nm tel plz ort mob query)) )
      (gui 'query '(+QueryChart) (cho)
         '(goal
            (quote
               @Nr (and *CuSuNr (cons @ T))
               @Nm *CuSuNm
               @Tel *CuSuTel
               @Plz *CuSuPlz
               @Ort *CuSuOrt
               @Mob *CuSuMob
               (select (@@)
                  ((nr +CuSu @Nr) (nm +CuSu @Nm) (tel +CuSu @Tel)
                     (plz +CuSu @Plz) (ort +CuSu @Ort) (mob +CuSu @Mob) )
                  (range @Nr @@ nr)
                  (tolr @Nm @@ nm)
                  (fold @Tel @@ tel)
                  (head @Plz @@ plz)
                  (part @Ort @@ ort)
                  (fold @Mob @@ mob) ) ) )
         9
         '((This) (list This (: nr) This (: nm2) (: em) (: plz) (: ort) (: tel) (: mob))) )
      (
 'chart (choTtl ,"Customers/Suppliers" 'nr '+CuSu)
         (quote
            (btn)
            (align "#")
            (NIL ,"Name")
            (NIL)
            (NIL ,"EMail")
            (NIL ,"Zip")
            (NIL ,"City")
            (NIL ,"Phone")
            (NIL ,"Mobile") )
         (do (cho)
            ( (alternating)
               (gui 1 '(+DstButton) Dst)
               (gui 2 '(+NumField))
               (gui 3 '(+ObjView +TextField) '(: nm))
               (gui 4 '(+TextField))
               (gui 5 '(+MailField))
               (gui 6 '(+TextField))
               (gui 7 '(+TextField))
               (gui 8 '(+TelField))
               (gui 9 '(+TelField)) ) ) )
      (
         (scroll (cho))
         (newButton T Dst '(+CuSu)
            '(nr genKey 'nr '+CuSu)
            'nm *CuSuNm
            'plz *CuSuPlz
            'ort *CuSuOrt
            'tel *CuSuTel
            'mob *CuSuMob )
         (cancelButton) ) ) )

(de choItem (Dst)
   (diaform '(Dst)
      ( "--.-."
         ,"Number" (gui 'nr '(+Focus +Var +NumField) '*ItemNr 10)
         ,"Supplier" (gui 'sup '(+Var +TextField) '*ItemSup 20)
         (searchButton '(init> (: home query)))
         ,"Description" (gui 'nm '(+Var +TextField) '*ItemNm 30)
         ,"Price" (gui 'pr '(+Var +FixField) '*ItemPr 2 12)
         (resetButton '(nr nm pr sup query)) )
      (gui 'query '(+QueryChart) (cho)
         '(goal
            (quote
               @Nr (and *ItemNr (cons @ T))
               @Nm *ItemNm
               @Pr (and *ItemPr (cons @ T))
               @Sup *ItemSup
               (select (@@)
                  ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr) (nm +CuSu @Sup (sup +Item)))
                  (range @Nr @@ nr)
                  (part @Nm @@ nm)
                  (range @Pr @@ pr)
                  (tolr @Sup @@ sup nm) ) ) )
         6
         '((This) (list This (: nr) This (: sup) (: sup ort) (: pr))) )
      (
 'chart (choTtl ,"Items" 'nr '+Item)
         (quote
            (btn)
            (align "#")
            (NIL ,"Description")
            (NIL ,"Supplier")
            (NIL ,"City")
            (align ,"Price") )
         (do (cho)
            ( (alternating)
               (gui 1 '(+DstButton) Dst)
               (gui 2 '(+NumField))
               (gui 3 '(+ObjView +TextField) '(: nm))
               (gui 4 '(+ObjView +TextField) '(: nm))
               (gui 5 '(+TextField))
               (gui 6 '(+FixField) 2) ) ) )
      (
         (scroll (cho))
         (newButton T Dst '(+Item)
            '(nr genKey 'nr '+Item)
            'nm *ItemNm
            'pr *ItemPr )
         (cancelButton) ) ) )

(de choOrd (Dst)
   (diaform '(Dst)
      ( "--.-.-."
         ,"Number" (gui 'nr '(+Focus +Var +NumField) '*OrdNr 10)
         ,"Customer" (gui 'cus '(+Var +TextField) '*OrdCus 20)
         ,"City" (gui 'ort '(+Var +TextField) '*OrdOrt 20)
         (searchButton '(init> (: home query)))
         ,"Date" (gui 'dat '(+Var +DateField) '*OrdDat 10)
         ,"Supplier" (gui 'sup '(+Var +TextField) '*OrdSup 20)
         ,"Item" (gui 'item '(+Var +TextField) '*OrdItem 20)
         (resetButton '(nr cus ort dat sup item query)) )
      (gui 'query '(+QueryChart) (cho)
         '(goal
            (quote
               @Nr (cons (or *OrdNr T))
               @Dat (cons (or *OrdDat T))
               @Cus *OrdCus
               @Ort *OrdOrt
               @Sup *OrdSup
               @Item *OrdItem
               (select (@@)
                  ((nr +Ord @Nr) (dat +Ord @Dat)
                     (nm +CuSu @Cus (cus +Ord))
                     (ort +CuSu @Ort (cus +Ord))
                     (nm +Item @Item (itm +Pos) ord)
                     (nm +CuSu @Sup (sup +Item) (itm +Pos) ord) )
                  (range @Nr @@ nr)
                  (range @Dat @@ dat)
                  (tolr @Cus @@ cus nm)
                  (part @Ort @@ cus ort)
                  (part @Item @@ pos itm nm)
                  (tolr @Sup @@ pos itm sup nm) ) ) )
         9
         '((This)
            (list This (: nr) This
               (: cus) (: cus ort)
               (: pos 1 itm sup) (: pos 1 itm)
               (: pos 2 itm sup) (: pos 2 itm) ) ) )
      (
 'chart (choTtl ,"Orders" 'nr '+Ord)
         (quote
            (btn)
            (align "#")
            (NIL ,"Date")
            (NIL ,"Customer")
            (NIL ,"City")
            (NIL ,"Supplier" "(1)")
            (NIL ,"Item" "(1)")
            (NIL ,"Supplier" "(2)")
            (NIL ,"Item" "(2)") )
         (do (cho)
            ( (alternating)
               (gui 1 '(+DstButton) Dst)
               (gui 2 '(+NumField))
               (gui 3 '(+ObjView +DateField) '(: dat))
               (gui 4 '(+ObjView +TextField) '(: nm))
               (gui 5 '(+TextField))
               (gui 6 '(+ObjView +TextField) '(: nm))
               (gui 7 '(+ObjView +TextField) '(: nm))
               (gui 8 '(+ObjView +TextField) '(: nm))
               (gui 9 '(+ObjView +TextField) '(: nm)) ) ) )
      (
         (scroll (cho))
         (newButton T Dst '(+Ord)
            '(nr genKey 'nr '+Ord)
            'dat (date) )
         (cancelButton) ) ) )

# vi:et:ts=3:sw=3
picoLisp/app/init.l0000644000175000017500000000600713230045154012640 0ustar  abuabu# 18jan18abu
# (c) Software Lab. Alexander Burger

`(not (seq *DB))

### Role ###
(obj ((+Role) nm "Administration") perm `*Perms)
(obj ((+Role) nm "Accounting") perm (Customer Item Order Report Delete))
(obj ((+Role) nm "Assistance") perm (Order))
(commit)

### User ###
(obj ((+User) nm "admin") pw `(passwd "admin") nam "Administrator" role `(db 'nm '+Role "Administration"))
(obj ((+User) nm "ben") pw `(passwd "ben") nam "Ben Affleck" role `(db 'nm '+Role "Accounting"))
(obj ((+User) nm "jodie") pw `(passwd "jodie") nam "Jodie Foster" role `(db 'nm '+Role "Accounting"))
(obj ((+User) nm "sandy") pw `(passwd "sandy") nam "Sandra Bullock" role `(db 'nm '+Role "Accounting"))
(obj ((+User) nm "depp") pw `(passwd "depp") nam "Johnny Depp" role `(db 'nm '+Role "Assistance"))
(obj ((+User) nm "tom") pw `(passwd "tom") nam "Tom Hanks" role `(db 'nm '+Role "Assistance"))
(commit)

(obj ((+Sal) nm "Department") hi "Dear Sir or Madam,")
(obj ((+Sal) nm "Mr.") hi "Dear Mr. @1,"  sex T)
(obj ((+Sal) nm "Mrs.") hi "Dear Mrs. @1,"  sex 0)
(obj ((+Sal) nm "Ms.") hi "Dear Ms. @1,"  sex 0)
(obj ((+Sal) nm "Mme") hi "Bonjour Mme @1,"  sex 0)
(obj ((+Sal) nm "Herr") hi "Sehr geehrter Herr @1,"  sex T)
(obj ((+Sal) nm "Herr Dr.") hi "Sehr geehrter Herr Dr. @1,"  sex T)
(obj ((+Sal) nm "Frau") hi "Sehr geehrte Frau @1,"  sex 0)
(obj ((+Sal) nm "Frau Dr.") hi "Sehr geehrte Frau Dr. @1,"  sex 0)
(obj ((+Sal) nm "Señor") hi "Estimado Señor @1,"  sex T)
(obj ((+Sal) nm "Señora") hi "Estimada Señora @1,"  sex 0)
(commit)

### Customer/Supplier ###
(obj ((+CuSu) nr 1)
   nm "Active Parts Inc."
   nm2 "East Division"
   str "Wildcat Lane"
   plz "3425"
   ort "Freetown"
   tel "37 4967 6846-0"
   fax "37 4967 68462"
   mob "37 176 86303"
   em "info@api.tld" )
(obj ((+CuSu) nr 2)
   nm "Seven Oaks Ltd."
   str "Sunny Side Heights 202"
   plz "1795"
   ort "Winterburg"
   tel "37 6295 5855-0"
   fax "37 6295 58557"
   em "info@7oaks.tld" )
(obj ((+CuSu) nr 3)
   sal `(db 'nm '+Sal "Mr.")
   nm "Miller"
   nm2 "Thomas Edwin"
   str "Running Lane 17"
   plz "1208"
   ort "Kaufstadt"
   tel "37 4773 82534"
   mob "37 129 276877"
   em "tem@shoppers.tld" )
(commit)

### Item ###
(obj ((+Item) nr 1) nm "Main Part" sup `(db 'nr '+CuSu 1) inv 100 pr 29900)
(obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250)
(obj ((+Item) nr 3) nm "Auxiliary Construction" sup `(db 'nr '+CuSu 1) inv 100 pr 15700)
(obj ((+Item) nr 4) nm "Enhancement Additive" sup `(db 'nr '+CuSu 2) inv 100 pr 999)
(obj ((+Item) nr 5) nm "Metal Fittings" sup `(db 'nr '+CuSu 1) inv 100 pr 7980)
(obj ((+Item) nr 6) nm "Gadget Appliance" sup `(db 'nr '+CuSu 2) inv 100 pr 12500)
(commit)

### Order ###
(let Ord (new (db: +Ord) '(+Ord) 'nr 1  'dat (date 2007 2 14)  'cus (db 'nr '+CuSu 3))
   (put> Ord 'pos
      (list
         (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 1)  'pr 29900  'cnt 1)
         (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 2)  'pr 1250  'cnt 8)
         (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 4)  'pr 999  'cnt 20) ) ) )
(commit)

# vi:et:ts=3:sw=3
picoLisp/app/inventory.l0000644000175000017500000000362212215340170013730 0ustar  abuabu# 15sep13abu
# (c) Software Lab. Alexander Burger

(must "Inventory" Report)

(menu ,"Inventory"
   (
 NIL ,"Inventory")
   (form NIL
      ( "-.-"
         ,"Number" NIL
         (prog
            (gui '(+Var +NumField) '*InvFrom 10)
            (prin " - ")
            (gui '(+Var +NumField) '*InvTill 10) )
         ,"Description" NIL (gui '(+Var +TextField) '*InvNm 30)
         ,"Supplier" (choCuSu 0)
         (gui '(+Var +Obj +TextField) '*InvSup '(nm +CuSu) 30) )
      (--)
      (gui '(+ShowButton) NIL
         '(csv ,"Inventory"
            (
 'chart NIL
               (
                  (quote
                     (align)
                     (NIL ,"Description")
                     (align ,"Inventory")
                     (NIL ,"Supplier")
                     NIL
                     (NIL ,"Zip")
                     (NIL ,"City")
                     (align ,"Price") ) )
               (catch NIL
                  (pilog
                     (quote
                        @Rng (cons *InvFrom (or *InvTill T))
                        @Nm *InvNm
                        @Sup *InvSup
                        (select (@Item)
                           ((nr +Item @Rng) (nm +Item @Nm) (sup +Item @Sup))
                           (range @Rng @Item nr)
                           (part @Nm @Item nm)
                           (same @Sup @Item sup) ) )
                     (with @Item
                        ( (alternating)
                           (<+> (: nr) This)
                           (<+> (: nm) This)
                           (<+> (cnt> This))
                           (<+> (: sup nm) (: sup))
                           (<+> (: sup nm2))
                           (<+> (: sup plz))
                           (<+> (: sup ort))
                           (<-> (money (: pr))) ) )
                     (at (0 . 10000) (or (flush) (throw))) ) ) ) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/app/item.l0000644000175000017500000000247613514101322012634 0ustar  abuabu# 18jul19 Software Lab. Alexander Burger

(must "Item" Item)

(menu ,"Item"
   (idForm ,"Item" '(choItem) 'nr '+Item T '(may Delete) '((: nr) " -- " (: nm))
      ( 4
         ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10) NIL
         ,"Description" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Item" 30) NIL
         ,"Supplier" (choCuSu 0)
         (gui '(+E/R +Obj +TextField) '(sup : home obj) '(nm +CuSu) 30)
         (gui '(+View +TextField) '(: home obj sup ort) 30)
         ,"Inventory" NIL (gui '(+E/R +NumField) '(inv : home obj) 12)
         (gui '(+View +NumField) '(cnt> (: home obj)) 12)
         ,"Price" NIL (gui '(+E/R +FixField) '(pr : home obj) 2 12) )
      (--)
      ( 2
         ,"Memo" (gui '(+BlobField) '(txt : home obj) 60 8)
         ,"Picture"
         (prog
            (gui '(+Able +UpField) '(not (: home obj jpg)) 30)
            (gui '(+Drop +Button) '(field -1)
               '(if (: home obj jpg) ,"Uninstall" ,"Install")
               '(cond
                  ((: home obj jpg)
                     (ask ,"Uninstall Picture?"
                        (put!> (: home top 1 obj) 'jpg NIL) ) )
                  ((: drop) (blob! (: home obj) 'jpg @)) ) ) ) )
      (gui '(+Upd +Img)
         '(and (: home obj jpg) (allow (blob (: home obj) 'jpg)))
         ,"Picture" ) ) )
picoLisp/app/lib.l0000644000175000017500000000501213306437043012444 0ustar  abuabu# 08jun18abu
# (c) Software Lab. Alexander Burger

### PDF-Print ###
(dm (pdf> . +Ord) ()
   (pdf *A4-DX *A4-DY (tmp ,"Order" (: nr) ".pdf")
      (font (11 . "serif"))
      (width "0.5")
      (let (I 0  Fmt (14 6 200 80 80 80) Lst (: pos))
         (while
            (page
               (image "@img/7fachLogo.png" "image/png" 420 0 120)
               (ifn (=1 *Page)
                  (indent 60
                     (down 40)
                     (font 9 (ps (text ,"Page @1" *Page)))
                     (down 80)
                     (hline 0 470 -8) )
                  (window 380 120 120 30
                     (font 21 (ps 0 ,"Order")) )
                  (brief NIL 8 "7fach GmbH, Bawaria"
                     (ps)
                     (with (: cus)
                        (ps
                           (pack
                              (and (: sal) (pack (: sal nm) " "))
                              (: nm2) " " (: nm) ) )
                        (ps (: str))
                        (ps (pack (: plz) " " (: ort))) ) )
                  (window 360 280 240 60
                     (let Fmt (80 12 60)
                        (table Fmt ,"Customer" ":" (ps NIL (: cus nr)))
                        (table Fmt ,"Order" ":" (ps NIL (: nr)))
                        (table Fmt ,"Date" ":" (ps (datStr (: dat)))) ) )
                  (down 360) )
               (indent 60
                  (hline 0 470 -8)
                  (bold
                     (table Fmt NIL NIL
                        (ps ,"Item")
                        (ps T ,"Price")
                        (ps T ,"Quantity")
                        (ps T ,"Total") ) )
                  (hline 4 470 -8)
                  (loop
                     (down 4)
                     (NIL Lst
                        (hline 4 470 -8)
                        (down 4)
                        (table Fmt NIL NIL NIL NIL NIL (ps T (money (sum> This))))
                        (hline 4 470 -8)
                        NIL )
                     (with (++ Lst)
                        (table Fmt
                           (ps T (inc 'I)) NIL
                           (ps (: itm nm))
                           (ps T (money (: pr)))
                           (ps T (: cnt))
                           (ps T (money (sum> This))) ) )
                     (T (>= *Pos 720)
                        (hline 4 470 -8)
                        (down 12)
                        (font 9 (ps (text ,"Continued on page @1" (inc *Page))))
                        T ) ) ) ) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/app/main.l0000600000175000017500000000315113377731703012624 0ustar  abuabu# 29nov18abu
# (c) Software Lab. Alexander Burger

(allowed ("app/")
   "!work" "!stop" "@lib.css" "!psh" )

(scl 2)
(load
   "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/svg.l"
   "@lib/adm.l" )  # "@lib/boss.l"

(setq
   *Css '("@lib.css" "app/menu.css")
   *Pool "db/app/"
   *Blob "db/app/blob/"
   *Salt (16 . "$6$@1$") )

(load "app/er.l" "app/lib.l" "app/gui.l")

(permission
   Customer    ,"Customer"
   Item        ,"Item"
   Order       ,"Order"
   Report      ,"Report"
   RoleAdmin   ,"Role Administration"
   UserAdmin   ,"User Administration"
   Password    ,"Password"
   Delete      ,"Delete" )

(de *Locales
   ("English" NIL)
   ("English (US)" "US")
   ("English (UK)" "UK")
   ("Deutsch (DE)" "DE" . "de")
   ("Deutsch (CH)" "CH" . "ch")
   ("Español (AR)" "AR" . "ar")
   ("Español (ES)" "ES" . "es")
   ("Français (FR)" "FR" . "fr")
   ("λληνικά (GR)" "GR" . "gr")
   ("Norsk" "NO" . "no")
   ("Русский" "RU" . "ru")
   ("Svenska" "SE" . "sv")
   ("日本語" "JP" . "jp") )

# Entry point
(de main ()
   (call "mkdir" "-p" *Blob)
   (pool *Pool *Dbs)
   (load "app/init.l") )

(de go (Rpc)
   (when Rpc
      (task (port @)  # Set up query server in the background
         (let? Sock (accept @)
            (unless (fork)  # Child process
               (in Sock
                  (while (rd)
                     (sync)
                     (tell)
                     (out Sock
                        (pr (eval @)) ) ) )
               (bye) )
            (close Sock) ) )
      (forked) )
   (rollback)
   (retire 20)
   (server (or (format (sys "PORT")) 8080) "!work") )

# vi:et:ts=3:sw=3
picoLisp/app/ord.l0000644000175000017500000000340513514101234012455 0ustar  abuabu# 18jul19 Software Lab. Alexander Burger

(must "Order" Order)

(menu ,"Order"
   (idForm ,"Order" '(choOrd) 'nr '+Ord T '(may Delete) '((: nr))
      ( 4
         ,"Date" NIL
         (gui '(+E/R +DateField) '(dat : home obj) 10)
         (gui '(+View +TextField)
            '(text ,"(@1 Positions)" (length (: home obj pos))) )
         ,"Customer" (choCuSu 0)
         (gui '(+E/R +Obj +TextField) '(cus : home obj) '(nm +CuSu) 30)
         (gui '(+View +TextField) '(field -1 'obj 'ort) 30) )
      (--)
      (gui '(+Set +E/R +Chart) '((L) (filter bool L)) '(pos : home obj) 8
         '((Pos I)
            (with Pos
               (list I NIL (: itm) (or (: pr) (: itm pr)) (: cnt) (sum> Pos)) ) )
         '((L D)
            (cond
               (D
                  (put!> D 'itm (caddr L))
                  (put!> D 'pr (cadddr L))
                  (put!> D 'cnt (; L 5))
                  (and (; D itm) D) )
               ((caddr L)
                  (new! '(+Pos) 'itm @) ) ) ) )
      (
 NIL NIL
         '(("align em2") (btn) (NIL ,"Item") (NIL ,"Price") (NIL ,"Quantity") (NIL ,"Total"))
         (do 8
            ( NIL
               (gui 1 '(+NumField))
               (choItem 2)
               (gui 3 '(+Obj +TextField) '(nm +Item) 30)
               (gui 4 '(+FixField) 2 12)
               (gui 5 '(+NumField) 8)
               (gui 6 '(+Sgn +Lock +FixField) 2 12)
               (gui 7 '(+DelRowButton))
               (gui 8 '(+BubbleButton)) ) )
         ( NIL NIL NIL (scroll 8 T) NIL NIL
            (gui '(+Sgn +View +FixField) '(sum> (: home obj)) 2 12) ) )
      (--)
      (gui '(+Rid +Button) ,"PDF-Print"
         '(if (check> (: home obj))
            (note ,"Can't print order" (uniq @))
            (url (pdf> (: home obj))) ) ) ) )
picoLisp/app/sales.l0000644000175000017500000000373311701247677013026 0ustar  abuabu# 05jan12abu
# (c) Software Lab. Alexander Burger

(must "Sales" Report)

(menu ,"Sales"
   (
 NIL ,"Sales")
   (form NIL
      ( "-.-"
         ,"Date" NIL
         (prog
            (gui '(+Var +DateField) '*SalFrom 10)
            (prin " - ")
            (gui '(+Var +DateField) '*SalTill 10) )
         ,"Customer" (choCuSu 0)
         (gui '(+Var +Obj +TextField) '*SalCus '(nm +CuSu) 30) )
      (--)
      (gui '(+ShowButton) NIL
         '(csv ,"Sales"
            (
 'chart NIL
               (
                  (quote
                     (align)
                     (NIL ,"Date")
                     (NIL ,"Customer")
                     NIL
                     (NIL ,"Zip")
                     (NIL ,"City")
                     (align ,"Total") ) )
               (catch NIL
                  (let Sum 0
                     (pilog
                        (quote
                           @Rng (cons *SalFrom (or *SalTill T))
                           @Cus *SalCus
                           (select (@Ord)
                              ((dat +Ord @Rng) (cus +Ord @Cus))
                              (range @Rng @Ord dat)
                              (same @Cus @Ord cus) ) )
                        (with @Ord
                           (let N (sum> This)
                              ( (alternating)
                                 (<+> (: nr) This)
                                 (<+> (datStr (: dat)) This)
                                 (<+> (: cus nm) (: cus))
                                 (<+> (: cus nm2))
                                 (<+> (: cus plz))
                                 (<+> (: cus ort))
                                 (<-> (money N)) )
                              (inc 'Sum N) ) )
                        (at (0 . 10000) (or (flush) (throw))) )
                     ( 'nil
                        ( ,"Total") - - - - -
                        ( (prin (money Sum))) ) ) ) ) ) ) ) )

# vi:et:ts=3:sw=3
picoLisp/app/sal.l0000644000175000017500000000061413514101433012450 0ustar  abuabu# 18jul19 Software Lab. Alexander Burger

(must "Salutation" Customer)

(menu ,"Salutation"
   (idForm ,"Salutation" '(choSal) 'nm '+Sal T '(may Delete) '((: nm))
      ( 2
         ,"Salutation" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Salutation" 40)
         ,"Greeting" (gui '(+E/R +TextField) '(hi : home obj) 40)
         ,"Sex" (gui '(+E/R +SexField) '(sex : home obj)) ) ) )
picoLisp/app/menu.css0000644000175000017500000000166012706400452013201 0ustar  abuabu/* 22apr16abu
 * Mansur Mamkin 
 */

body {
   background: #ebebeb;
}

.menu {
   background: #525e76;
}

.menu ul {
   list-style:none;
   margin: 0;
   padding: 0;
}

.menu .cmd1, .act1, .cmd2, .act2, .cmd3, .act3, .cmd4, .act4 {
   list-style: none;
   padding: 0;
}

.menu .sub1, .top1, .sub2, .top2, .sub3, .top3, .sub4, .top4 {
   list-style: none;
   padding: 0;
}

.menu .top1 ul {
   padding-left: 1em;
}

.menu .act1, .act2, .act3, .act4 {
   background: #e89a5c;
}

.menu ul li {
   position: relative;
   padding: 3px 0;
}

.menu a {
   color: #e8e8e8;
   display: block;
   text-decoration: none;
   transition: background 0.5s;
   -moz-transition: background 0.5s;
   -webkit-transition: background 0.5s;
   -o-transition: background 0.5s;
   font-family: tahoma;
   font-weight: bold;
   font-size: 12px;
   // text-transform: uppercase;
}

.menu a:hover {
   background: RGBA(255,255,255,0.2);
   color:#fff;
}
picoLisp/app/loc/ar0000644000175000017500000000012211245232763012622 0ustar  abuabu# 26aug09art
# Armadillo 

T "@app/loc/es"
"Mobile" "Celular"
picoLisp/app/loc/ch0000644000175000017500000000010211011254410012570 0ustar  abuabu# 10may08abu
# (c) Software Lab. Alexander Burger

T "app/loc/de"
picoLisp/app/loc/de0000644000175000017500000000316412332163654012621 0ustar  abuabu# 06may14abu
# (c) Software Lab. Alexander Burger

"(@1 Positions)" "(@1 Positionen)"

"Address" "Adresse"

"Can't print order" "Beleg kann nicht gedruckt werden"
"Change" "Ändern"
"City" "Ort"
"Contact" "Kontakt"
"Continued on page @1" "Fortsetzung auf Seite @1"
"Country" "Land"
"Customer" "Kunde"
"Customer/Supplier" "Kunde/Lieferant"
"Customers/Suppliers" "Kunden/Lieferanten"

"Data" "Daten"
"Date" "Datum"
"Dear Sir or Madam," "Sehr geehrte Damen und Herren,"
"Description" "Bezeichnung"

"EMail" "EMail"

"Fax" "Fax"

"Greeting" "Gruß"

"Home" "Startseite"

"Incomplete customer address" "Unvollständige Kundenadresse"
"Install" "Installieren"
"Inventory" "Lagerbestand"
"Item" "Artikel"
"Items" "Artikel"

"Memo" "Memo"
"Mobile" "Mobil"

"Name 2" "Name 2"
"No customer" "Kunde fehlt"
"No customer name" "Kundenname fehlt"
"No customer number" "Kundennummer fehlt"
"No item description" "Artikelbezeichnung fehlt"
"No item number" "Artikelnummer fehlt"
"No order date" "Belegdatum fehlt"
"No order number" "Belegnummer fehlt"
"No positions" "Keine Positionen"
"Number" "Nummer"

"Order" "Bestellung"
"Orders" "Bestellungen"

"Page @1" "Seite @1"
"PDF-Print" "PDF-Druck"
"Picture" "Bild"
"Position without item" "Position ohne Artikel"
"Position without price" "Position ohne Preis"
"Position without quantity" "Position ohne Menge"
"Price" "Preis"

"Quantity" "Menge"

"Report" "Auswertung"

"Sales" "Verkauf"
"Salutation" "Anrede"
"Salutations" "Anreden"
"Sex" "Geschlecht"
"Street" "Straße"
"Supplier" "Lieferant"
"System" "System"

"Total" "Gesamt"

"Uninstall" "De-installieren"
"Uninstall Picture?" "Bild de-installieren?"

"Zip" "PLZ"
picoLisp/app/loc/es0000644000175000017500000000331012332163772012632 0ustar  abuabu# 20aug09art
# Armadillo 

"(@1 Positions)" "(@1 Posiciones)"

"Address" "Dirección"

"Can't print order" "No se puede imprimir la órden"
"Change" "Cambiar"
"City" "Ciudad"
"Contact" "Contacto"
"Continued on page @1" "Continuado en la página @1"
"Country" "País"
"Customer" "Cliente"
"Customer/Supplier" "Cliente/Proveedor"
"Customers/Suppliers" "Clientes/Proveedores"

"Data" "Datos"
"Date" "Fecha"
"Dear Sir or Madam," "Estimado/a Sr/a,"
"Description" "Descripción"

"EMail" "EMail"

"Fax" "Fax"

"Greeting" "Saludos"

"Home" "Inicio"

"Incomplete customer address" "Dirección del cliente incompleta"
"Install" "Instalar"
"Inventory" "Inventario"
"Item" "Artículo"
"Items" "Artículos"

"Memo" "Memo"
"Mobile" "Móbil"

"Name 2" "Segundo nombre"
"No customer" "No cliente"
"No customer name" "Nombre de cliente indefinido"
"No customer number" "Número de cliente indefinido"
"No item description" "Descripción de artículo indefinida"
"No item number" "Número de artículo no definido"
"No order date" "Fecha de órden, indefinida"
"No order number" "Número de órden indefinido"
"No positions" "Posiciones indefinidas"
"Number" "Número"

"Order" "Orden"
"Orders" "Órdenes"

"Page @1" "Página @1"
"PDF-Print" "Imprimir-PDF"
"Picture" "Foto"
"Position without item" "Posición sin artículo"
"Position without price" "Posición sin precio"
"Position without quantity" "Posición sin cantidad"
"Price" "Precio"

"Quantity" "Cantidad"

"Report" "Reporte"

"Sales" "Ventas"
"Salutation" "Saludo"
"Salutations" "Saludos"
"Sex" "Género"
"Street" "Calle"
"Supplier" "Proveedor"
"System" "Sistema"

"Total" "Total"

"Uninstall" "Desinstalar"
"Uninstall Picture?" "Desinstalar foto?"

"Zip" "Código Postal"
picoLisp/app/loc/fr0000600000175000017500000000325513056247240012627 0ustar  abuabu# 02mar17abu
# Raman Gopalan 

"(@1 Positions)" "(@1 Situations)"

"Address" "Adresse"

"Can't print order" "Impossible d'imprimer la commande"
"Change" "Changer"
"City" "Ville"
"Contact" "Contact"
"Continued on page @1" "Suite à la page @1"
"Country" "Pays"
"Customer" "Client"
"Customer/Supplier" "Client/Fournisseur"
"Customers/Suppliers" "Clients/Fournisseurs"

"Data" "Données"
"Date" "Date"
"Dear Sir or Madam," "Cher Monsieur/Chère Madame,"
"Description" "Description"

"EMail" "Courriel "

"Fax" "Fax"

"Greeting" "Salutation"

"Home" "Accueil"

"Incomplete customer address" "Adresse du client incomplète"
"Install" "Installer"
"Inventory" "Inventaire"
"Item" "Article"
"Items" "Articles"

"Memo" "Note"
"Mobile" "Portable"

"Name 2" "Nom 2"
"No customer" "Aucun client"
"No customer name" "Aucun nom de client"
"No customer number" "Aucun numéro de client"
"No item description" "Aucune description d'article"
"No item number" "Aucun numéro d'article"
"No order date" "Aucune date de commande"
"No order number" "Aucun numéro de commande"
"No positions" "Pas de situation"
"Number" "Nombre"

"Order" "Commande"
"Orders" "Commandes"

"Page @1" "Page @1"
"PDF-Print" "Impression PDF"
"Picture" "Photo"
"Position without item" "Situation sans article"
"Position without price" "Situation sans prix"
"Position without quantity" "Situation sans quantité"
"Price" "Prix"

"Quantity" "Quantité"

"Report" "Rapport"

"Sales" "Ventes"
"Salutation" "Salutation"
"Salutations" "Salutations"
"Sex" "Sexe"
"Street" "Rue"
"Supplier" "Fournisseur"
"System" "Système"

"Total" "Total"

"Uninstall" "Désinstaller"
"Uninstall Picture?" "Désinstaller l'image?"

"Zip" "Code postal"
picoLisp/app/loc/gr0000644000175000017500000000515412761003312012630 0ustar  abuabu# 06aug2016
# A.Drakopoulos 

"(@1 Positions)" "(@1 Θέσεις)"

"Address" "Διεύθυνση"

"Can't print order" "Δεν μπορεί να τυπώσει την παραγγελία"
"Change" "Αλλάζω"
"City" "Πόλη"
"Contact" "Επαφή"
"Continued on page @1" "Συνεχίζει στην σελίδα @1"
"Country" "Χώρα"
"Customer" "Πελάτης"
"Customer/Supplier" "Πελάτης/Προμηθευτής"
"Customers/Suppliers" "Πελάτες/Προμηθευτές"

"Data" "Δεδομένα"
"Date" "Ημερομηνία"
"Dear Sir or Madam," "Αξιότιμε/η Κ/Κ,"
"Description" "Περιγραφή"

"eMail" "eMail"

"Fax" "Fax"
"Full Name" "Πλήρες Όνομα"

"Greeting" "Χαιρετισμοί"

"Home" "Αρχή"

"Incomplete customer address" "Ελλιπής διεύθυνση πελάτη"
"Install" "Εγκατάσταση"
"Inventory" "Απογραφή Εμπορευμάτων"
"Item" "Είδος"
"Items" "Είδη"

"Login Name" "Όνομα χρήστη"

"Memo" "Memo"
"Mobile" "Κινητό"

"Name" "Όνομα"
"Name 2" "Δεύτερο όνομα"
"No customer" "Όχι Πελάτης"
"No customer name" "Ακαθόριστο όνομα πελάτη"
"No customer number" "Ακαθόριστο νούμερο πελάτη"
"No item description" "Ακαθόριστη περιγραφή στοιχείου"
"No item number" "Ακαθόριστο νούμερο στοιχείου"
"No order date" "Ακαθόριστη ημερομηνία παραγγελίας"
"No order number" "Ακαθόριστο νούμερο παραγγελίας"
"No positions" "Ακαθόριστες θέσεις"
"Number" "Νούμερο"

"Order" "Παραγγελία"
"Orders" "Παραγγελίες"

"Page @1" "Σελίδα @1"
"PDF-Print" "Εκτύπωση-PDF"
"Phone" "Τηλέφωνο"
"Picture" "Φωτογραφία"
"Position without item" "Θέση χωρίς στοιχείο"
"Position without price" "Θέση χωρίς τιμή"
"Position without quantity" "Θέση χωρίς ποσότητα"
"Price" "Τιμή"

"Quantity" "Ποσότητα"

"Report" "Αναφορά"
"Role Administration" "Ρόλος Διαχειριστή"

"Sales" "Πωλήσεις"
"Salutation" "Χαιρετισμός"
"Salutations" "Χαιρετισμοί"
"Sex" "Φύλο"
"Street" "Οδός"
"Supplier" "Προμηθευτής"
"System" "Σύστημα"

"Total" "Σύνολο"

"Uninstall" "Απεγκατάσταση"
"Uninstall Picture?" "Απεγκατάσταση φωτογραφίας?"
"User Administration" "Διαχειριστής χρήστη"

"Zip" "Ταχυδρομικός κώδικας"
picoLisp/app/loc/jp0000644000175000017500000000344712332163751012644 0ustar  abuabu# 06may14abu
# (c) Software Lab. Alexander Burger

"(@1 Positions)" "(ポジション数：@1)"

"Address" "住所"

"Can't print order" "注文書の印刷ができない"
"Change" "変換"
"City" "都市"
"Contact" "問い合わせ"
"Continued on page @1" "@1ページに続く"
"Country" "国"
"Customer" "カスタマー"
"Customer/Supplier" "カスタマー/注文先"
"Customers/Suppliers" "カスタマー/注文先"

"Data" "データ"
"Date" "日付"
"Dear Sir or Madam," "拝啓,"
"Description" "仕様"

"EMail" "eメール"

"Fax" "Fax"

"Greeting" "手紙の書きだし"

"Home" "ホーム"

"Incomplete customer address" "カスタマーの住所不十分"
"Install" "インストール"
"Inventory" "在庫目録"
"Item" "商品"
"Items" "商品"

"Memo" "メモ"
"Mobile" "携帯電話"

"Name 2" "名前 2"
"No customer" "カスタマーなし"
"No customer name" "カスタマー名なし"
"No customer number" "カスタマー番号なし"
"No item description" "商品仕様なし"
"No item number" "商品番号なし"
"No order date" "注文書日付なし"
"No order number" "注文番号なし"
"No positions" "ポジションなし"
"Number" "番号"

"Order" "注文"
"Orders" "注文"

"Page @1" "@1 ページ"
"PDF-Print" "PDF印刷"
"Picture" "写真"
"Position without item" "ポジションに商品がない"
"Position without price" "ポジションに価格がない"
"Position without quantity" "ポジションに数量がない"
"Price" "価格"

"Quantity" "数量"

"Report" "レポート"

"Sales" "セールス"
"Salutation" "敬称"
"Salutations" "敬称"
"Sex" "性別"
"Street" "住所"
"Supplier" "注文先"
"System" "システム"

"Total" "総計"

"Uninstall" "アンインストール"
"Uninstall Picture?" "写真をアンインストールしますか？"

"Zip" "郵便番号"
picoLisp/app/loc/no0000644000175000017500000000317712332163734012650 0ustar  abuabu# 14jan10jk
# Jon Kleiser, jon.kleiser@usit.uio.no

"(@1 Positions)" "(@1 Posisjoner)"

"Address" "Adresse"

"Can't print order" "Kan ikke skrive ut bestilling"
"Change" "Endre"
"City" "By"
"Contact" "Kontakt"
"Continued on page @1" "Fortsettes på side @1"
"Country" "Land"
"Customer" "Kunde"
"Customer/Supplier" "Kunde/Leverandør"
"Customers/Suppliers" "Kunder/Leverandører"

"Data" "Data"
"Date" "Dato"
"Dear Sir or Madam," "Kjære frue/herre,"
"Description" "Beskrivelse"

"EMail" "e-post"

"Fax" "Fax"

"Greeting" "Hilsen"

"Home" "Startside"

"Incomplete customer address" "Ufullstendig kundeadresse"
"Install" "Installer"
"Inventory" "Lagerbeholdning"
"Item" "Artikkel"
"Items" "Artikler"

"Memo" "Merknad"
"Mobile" "Mobil"

"Name 2" "Navn 2"
"No customer" "Kunde mangler"
"No customer name" "Kundenavn mangler"
"No customer number" "Kundenummer mangler"
"No item description" "Artikkelbeskrivelse mangler"
"No item number" "Artikkelnummer mangler"
"No order date" "Bestillingsdato mangler"
"No order number" "Bestillingsnummer mangler"
"No positions" "Ingen posisjoner"
"Number" "Nummer"

"Order" "Bestilling"
"Orders" "Bestillinger"

"Page @1" "Side @1"
"PDF-Print" "PDF-utskrift"
"Picture" "Bilde"
"Position without item" "Posisjon uten artikkel"
"Position without price" "Posisjon uten pris"
"Position without quantity" "Posisjon uten antall"
"Price" "Pris"

"Quantity" "Antall"

"Report" "Rapport"

"Sales" "Salg"
"Salutation" "Titulering"
"Salutations" "Tituleringer"
"Sex" "Kjønn"
"Street" "Gate"
"Supplier" "Leverandør"
"System" "System"

"Total" "Total"

"Uninstall" "Av-installer"
"Uninstall Picture?" "Av-installere bilde?"

"Zip" "Postnr."
picoLisp/app/loc/ru0000644000175000017500000000421412332163717012654 0ustar  abuabu# 25apr08
# Mansur Mamkin 

"(@1 Positions)" "(@1 позиций)"

"Address" "Адрес"

"Can't print order" "Невозможно напечатать заказ"
"Change" "Изменить"
"City" "Город"
"Contact" "Контакт"
"Continued on page @1" "Продолжение на странице @1"
"Country" "Страна"
"Customer" "Покупатель"
"Customer/Supplier" "Покупатель/Поставщик"
"Customers/Suppliers" "Покупатели/Поставщики"

"Data" "Данные"
"Date" "Дата"
"Dear Sir or Madam," "Уважаемый(ая)"
"Description" "Описание"

"EMail" "емейл"

"Fax" "Факс"

"Greeting" "Приветствие"

"Home" "Домой"

"Incomplete customer address" "Неполный адрес покупателя"
"Install" "Установить"
"Inventory" "Инвентаризация"
"Item" "Товар"
"Items" "Товары"

"Memo" "Мемо"
"Mobile" "Мобильный"

"Name 2" "Имя 2"
"No customer" "Нет покупателя"
"No customer name" "Нет имени покупателя"
"No customer number" "Нет номера покупателя"
"No item description" "Нет описания товара"
"No item number" "Нет номера товара"
"No order date" "Нет даты заказа"
"No order number" "Нет номера заказа"
"No positions" "Нет позиций"
"Number" "Номер"

"Order" "Заказ"
"Orders" "Заказы"

"Page @1" "Страница @1"
"PDF-Print" "Печать PDF"
"Picture" "Картинка"
"Position without item" "Позиция без товара"
"Position without price" "Позиция без цены"
"Position without quantity" "Позиция без количества"
"Price" "Цена"

"Quantity" "Количество"

"Report" "Отчет"

"Sales" "Продажи"
"Salutation" "Приветствие"
"Salutations" "Приветствия"
"Sex" "Пол"
"Street" "Улица"
"Supplier" "Поставщик"
"System" "Система"

"Total" "Всего"

"Uninstall" "Удалить"
"Uninstall Picture?" "Удалить картинку?"

"Zip" "Индекс"
picoLisp/app/loc/sv0000644000175000017500000000316612333066530012657 0ustar  abuabu# 8may14mtsd
# Mattias Sundblad, mattias.sun@gmail.com  

"(@1 Positions)" "(@1 Positioner)"

"Address" "Adress"

"Can't print order" "Kan inte skriva ut beställning"
"Change" "Ändra"
"City" "Ort"
"Contact" "Kontakt"
"Continued on page @1" "Fortsätter på sidan @1"
"Country" "Land"
"Customer" "Kund"
"Customer/Supplier" "Kund/Leverantör"
"Customers/Suppliers" "Kunder/Leverantörer"

"Data" "Data"
"Date" "Datum"
"Dear Sir or Madam," "Kära herr/ fru"
"Description" "Beskrivning"

"EMail" "E-post"

"Fax" "Fax"

"Greeting" "Hälsning "

"Home" "Startsida"

"Incomplete customer address" "Ofullständig adress till kund"
"Install" "Installera"
"Inventory" "Lagersaldo"
"Item" "Artikel"
"Items" "Artiklar"

"Memo" "Notering"
"Mobile" "Mobil"

"Name 2" "Namn 2"
"No customer" "Kund saknas"
"No customer name" "Kundens namn saknas"
"No customer number" "Kundnummer saknas"
"No item description" "Artikelbeskrivning saknas"
"No item number" "Artikelnummer saknas"
"No order date" "Orderdatum saknas"
"No order number" "Ordernummer saknas"
"No positions" "Inga positioner"
"Number" "Nummer"

"Order" "Beställning"
"Orders" "Beställningar"

"Page @1" "Sida @1"
"PDF-Print" "PDF-utskrift"
"Picture" "Bild"
"Position without item" "Position saknar artikel"
"Position without price" "Position saknar pris"
"Position without quantity" "Position saknar antal"
"Price" "Pris"

"Quantity" "Antal"

"Report" "Rapporter"

"Sales" "Beställningar"
"Salutation" "Titel"
"Salutations" "Titlar"
"Sex" "Kön"
"Street" "Gatuadress"
"Supplier" "Leverantör"
"System" "System"

"Total" "Total"

"Uninstall" "Ta bort"
"Uninstall Picture?" "Ta bort bild?"

"Zip" "Postnr."
picoLisp/img/7fachLogo.png0000600000175000017500000001757412515655574014060 0ustar  abuabuPNG


IHDR>GbKGD	pHYs

B(xtIME4	IDATx]ol=8tH:^DŊ	>f	m&HT	KI QUzH8vM5uEV)t@%*Z
%܇'N<>3;3Pdv!XXXXRM3[
G8}@1\q+@3qr{oUgEuŀĂ@})-,,f㪅.X⳰Hnv4Y⳰#h8Ϋ1>?W+EBsҺ}ruȏY⳰H)J=~6gaafcy&7,,,PE c"nnNH9Z⳰H9"e8gL:|ޢXwH?kKM<]ˉ{,4ėp\Vd>f75a
ͿeR¯ǿAw2)'mYLxV@h!f*_@EUk%U`Hh;egInEԻpMʙFɶV/JzmK|^
D_BXdY0!R,pzT&w![Z9iͷp2Ign]bu]RZ4SȄK[4vCC/[BFzLE-`-ƒ%neA_%ko^7=nb{-ts56^QK|	B>_U^5qoecV:,Ԏ릩\qZKDCü^
^>_IW/O!IK|1`c~$q>@] RByUm[cR;AUeBDD
$OdY4/ݎ uV(㚹؍[ki܊,iQx	=
рIOw[&++'^^9mb(`d^>k/-
' =:vڳzadֺג%3k301L}[tM!oڤ[sF+MQB{fŤם/E@S&Ctv_Ҳ0dJiV͞~5I1
$L,,1&bRDG9ehО^}dh&LE- B\TJ7rd	+~*vk-Іx"|_%4YڴO:/ndIGx
-ff$pݢ=s"G~Deeg.&ۀ!J6@NO|hkZ"s9a'Cka}о`D._@v9ג&~7uSP0^Z^iUZ\9'2X,Æ=([dL
ln)8/nu,Pꉆ0*y2s"/LZ۾\D)Uk_gruE׬4
^Э*Y4[8gMhWn;
q>Do9Ջ̻5|
h;@$ :N|I>3cu,ms
{X׹#݋	 ѥFx˕i 0K8:oc1f@ǩR5	hx70vX"oa8"|&/Ϝ
0vh\K%/= c8l_`poCK2+?P@֐Lc
!PoZ4O|3PR**֮8%R',Uw6.ofn0!Y8ީEGcߚcMj;/4@zeO_KF#,g+FP1_ڠCfHLg9]ҕ-eG	}Ct]Eqx9ǝ3WxS:;Z
:dIeYTǵXIZV|)g,I\wkv?MLܧ;{&Gϛ;zLזEuaK|R@zB_6;Nf>'MhU=0⪉(.Ī>Oi8	]0=c
s9GGFWGC벉vhϚK"Wme~'z9S7WdpT?Oz[^b\bY0MT^13,Kop+Ɓ"`Njy`Fŷ.I񮇞x=B]	[]zq-9..>ޥv,@gϣ	B^l+\b6ψEXI q,rc;ƁAJ,q`j\?2@5K,ll;M>0̘#џw&ۛYa^~'<;0d~ŌϘ6<_`YaY9}KW5w˗+fyJf_]
#1`T!@h^13vC١=krFB (9Oz
XEnǫTYl-_a;WL כR
2Tuץ!(]T-(@yS.%
芮V- wS@6Cn)ɍrI䝙lnecu..p7)dAZIy
J~%`q?:M-L7HF,#݋3vW$&2K]we9U8쎏G/B_-_\Uu#uq-L<,ڌ֧f07?k'j	43槀MD><+u[#Vޕ?n
}TO)OF0|,@>_upppQM^SLqm(2Ч{4С{#V]Z/I/_u#0ǡ=풒OMd^ڻ10/d[_51bkug*
TvɓRꃒq!"`Ǥؑnu[.m7m=ı mnf~28YD$ugLM4kYJLMآ
Xz
HUTr.,E|3ܳMF]m'~t$y.V)0P.0M[#!r4shcAW
^=I֡y!pqwqsȘ&9ug$@g6=2@Y*7ߓ^\/t(xaFL"Z\@Eҥ0U7q%d\̹S~NpW
ʷOX-$..a|p:HQ6횐пC{: =_k:Z6zxP9n	UpggIz/ M{% alCDS
B|Us[#{5Ii
:$MB#z؇Cw|#hOws爪tY{B7W?u0	
5D2㜯Qr~u/ҏAcDq.J)QexMǣ{GgEO|ϢfJ3;4b.[>ǜHt]2JPE6LJW
LÒQ;1Gr;k$r"gN	aTs,%Z¢(+׿l\캚~o)q5\Ɯz8nTK󈯖L$|u`1
,(4[ ,lUז	M/IY$mX9WOXANz4˗nZ|=-$gXpnw
z357%..Xp{ķ9^5xx1|pY*{rxnƉ5J^5TEF53'\pQbSdHCƤyq2!TkX2PTxo&xWVtiXy)ᢉ1牍asJt慤5+Z[T-"
TY{"S-wWi$ѫ(\{D.-G/͆o@=A{:S8h5+.7W065qTқ+[{iО7	I
ѭ!17ڳ&ך%9{x{q{d~tWEa)T-{jUY)R?/Ck<~@ׯ4L˪K/N,ѩ#{{ﱔ$#UZN^ۋV$33U.k";')&J	׌]^DQ;-db:$dCA(Ƥ]60_4_:y [c+
pvə_?iVx&GF`7sKv|['nÐ@z@CVtBVLLE/ЄFx\de`UTp2?N^]CDhTpY,±JJLmv׵pI
wtsӡ7ɈvyϭojzO?'y&{55/zYac7
G+1ʪjF/C|
oRp]jE{KX-f7驙ePR&pD
Fd!׉I1u	)e@_PշC{?S+2`pLmEEZRxh*n-xOz߳;)m6Rds5SI8gTBwpB(cͽΪK/-.j]599F3w]NA`םsB{K1F|Рߥ4NnI8c]ZIb?c@'Y4QiUo0,hd}a]55C[k9ʎk^mp4`D?fGidML9,"ȋ>Ϳ,+ 	k)zV0bXc1/Wd3[d=:MD;
d<}0\ѭ›&Ѽpyp(=%
FMhpi1Pl$;*Lo!9p؞熜C?"1^	뾭}C{fzV3Ws	d73W
we^ɚ	Lx]]q0N.9M-|soCƳ&=?7`;z['MqG^nofv߫5BzZY8Rʴb}⮳ekk!kM#,#jfNӒ^`ҡ1
S{0ԉ$^X
0B}cp+W?4HϡJ	Ӓ#@'	Xg[جIk<~זٚ`2 fVMoM+=68.PZoУ7^䎍	in:h7"`8<9j
X
,+_[֚jU*V%POB'ZY3.6^g`Zo';ֆ.Nݦ^j]v»IoxHg%Z֞f|Tү\(ujLROQj2V#@FK
/dZoP!
>N5l,q
,RV7%=HQk0#Eyoץ&H].@H}XX,GM{qo"Y`A&Y̮nV4AZoLqFSYHЕ20"vN01Pd`%<BS0de=mXBjkop_2>XJƀɵ:NgFawcXXx빆H	K5˗+P_nb=٥dawkT9baa(V5gu{23x.#B|Fg~Iu',,~iޓ-12z{`*7#/$Einaa-ooD
[n0YPj\l^DlXX1/:'S6=22\H訅E#`"+E}R*:jaa3 ``oZo1$j|I|,,枫1("*؜cR;s=+jaaa"D<؊ȢKjfr|gRkEbD٥ca1ou3d@_V\ΧvXXUW&%ٞ]"sٛb[Uf	;<gaq>ǒIENDB`