picowiki

Subclass of \{+Entity} for storing binary or large text data in separate file.

Example of relation definition:

(class +C +Entity)
(rel r (+Blob))

(gui '(+BlobField) '(r : home obj) 70 25)

(prog
   (gui '(+Able +UpField) '(not (: home obj r)) 45)
   (gui '(+Button) '(if (: home obj r) ,"Uninstall" ,"Install")
      '(if (: home obj r)
         (ask ,"Uninstall Picture?"
            (put!> (: home top 1 r) 'r NIL) )
         (let? F (val> (field -1))
            (blob! (: home obj) 'r (tmp F)) ) ) ) )

(when (: home obj r)
   (<p> NIL (<img> (allow (blob (: home obj) 'r)) ,"Picture")) )

(de fempty (F)
   (use C
      (in F
         (loop
            (NIL (setq C (char)) T)
            (T (not (member C (chop " ^I^M^J"))) NIL)))))

(de blob? (Obj Var)
   (when (and Obj (get Obj Var))
      (let B (blob Obj Var)
         (when (and (info B) (not (fempty B)))
            B))))

Subclass of \{+Entity} for storing T or NIL.

Example of relation definition:

(class +C +Entity)
(rel r (+Bool))

Example of \{gui} element:

(gui '(+E/R +Checkbox) '(r : home obj))

Based on http://www.software-lab.de/ref.html#dbase.

\{+Entity}: superclass of all database/persistent classes, see http://www.software-lab.de/ref.html#dbase

Closure is "a class with one method, apply" (as Guy Steele succinctly noted on a mailing list I lost reference to) or to put it in another way, it is "a function that can access its outside lexical environment". See http://en.wikipedia.org/wiki/Lexical_closure for more elaborate description.

I would say that the difference between the class and function interpretations is at the syntax level, not in semantics.

http://www.software-lab.de/faq.html#closures has some explanation regarding closures in PicoLisp.

As closures are useful in various situations, lets discuss practical options how to use them in PicoLisp. Most of the summary here originated from http://www.mail-archive.com/picolisp@software-lab.de/msg00534.html mailing list.

(let @S '((I . 0))
   (def 'count1 (fill '(() (job '@S (inc 'I)))))
   (def 'reset (fill '(() (job '@S (zero I))))))

(count1) => 1
(count1) => 2
(reset) => 0
(count1) => 1

(let I '(0)
   (def 'count1 (curry (I) () (inc I)))
   (def 'reset (curry (I) () (set I 0))) )

(let @S '((I . 0))
   (def 'count1 (curry (@S) () (job '@S (inc 'I))))
   (def 'reset (curry (@S) () (job '@S (zero I)))) )

(let @S (list (cons 'I 0))

(let I (cons 0)

(class +Counter)
# i

(dm T ()
   (=: i 0) )

(dm count> ()
   (inc (:: i)) )

(dm reset> ()
   (=: i 0) )

(let @C (list (cons 'C (new '(+Counter))))
   (def 'count (curry (@C) () (job '@C (count> C))))
   (def 'reset (curry (@C) () (job '@C (reset> C)))) )

Geographical IP look up to find where an IP address is located.

The fast way using GeoIP software:

# sudo apt-get install geoip-bin
(de ip2country (Ip)
   (in (list "geoiplookup" Ip)
      (use (@A @B @C)
         (match '(@A ":" " " @B "," " " @C) (line))
         (mapcar pack (list @B @C)))))
...
: (ip2country "89.16.183.67")
-> ("GB" "United Kingdom")

Or the slow way using http://gumby.appspot.com/ Gumby web service:

(load "@lib/http.l" "@lib/xml.l")
...
(de ip2country (Ip)
   (client "gumby.appspot.com" 80 (pack "/api/?format=xml&ip=" Ip)
      (from "^M^J^M^J")
      (when (xml?)
         (nth (xml) 5 4 3 1))))
...
: (ip2country "89.16.183.67")
-> "GB"

\{ToDo} misc gui stuff

\{+RteField} Rich Text Formatting for \{+Blob} with text data

PicoLisp does not have multimethods. Sometimes, they are useful tool which can be implemented as described here. See for example http://en.wikipedia.org/wiki/Multimethods for more information on multimethods.

Suppose we have some classes and we want to define a function/method with behavior depending on the type of arguments. We could use:

• a \{ref:cond} statement with \{ref:isa} test or
• the http://en.wikipedia.org/wiki/Visitor_pattern if our language supports singe dispatch only.

However, the most convenient approach is to use multimethods, as implemented in http://en.wikipedia.org/wiki/Common_Lisp_Object_System for example. I will not go that far though.

So we want to achieve the following (dmm stands for define multimethod):

(class +Asteroid)
(class +Spaceship)

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS

We can "simply" define a dispatch table and a function that will look up the the function to handle specific arguments.

(put 'collide< 'mm
   (list
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss"))) ) )

…and a function collide\< would do the look up and \{ref:apply}.

I will try to be more sophisticated and allow for "don't care" cases, e.g. where any of the arguments can be of any type:

(cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))

Here NIL means "don't care" or that the argument can be of any type.

Lets define a few useful functions:

(de mmApplicable (K M)
   (use (KK MM)
      (loop
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM)) NIL))))

(de mmApply @
   (let (N (next) A (rest) K NIL)
      (for AA A
         (push 'K (type AA)))
      (setq K (flip K))
      (let *Mm (filter '((M) (mmApplicable K (car M))) (get N 'mm))
         (ifn *Mm
            (quit 'mm (list "No applicable method" N A K))
            (apply (cdr (pop '*Mm)) A)))))

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
            (loop
               (NIL L (put N 'mm (cons P (get N 'mm))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) )
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

Now we can run the following example:

(put 'collide< 'mm
   (list
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss")))
      (cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))
      (cons '((+Spaceship) NIL) '((X Y) (prinl "s?")))
      (cons '(NIL (+Asteroid)) '((X Y) (prinl "?a")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL NIL) '((X Y) (prinl "??"))) ) )

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(dmm collide< (X Y)
   (prinl "bang"))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS
(collide< A 1) # => a?
(collide< 2 A) # => ?a
(collide< S 3) # => s?
(collide< 4 S) # => ?s
(collide< 5 T) # => bang
(collide< T)   # => bang
(collide<)     # => bang

Notice that we defined the dispatch table first to get the right ordering and then we redefined some methods.

This implementation is not good enough yet though as we have to manually maintain the dispatch table (the proper ordering of methods).

Lets automate dispatch table maintainance and introduce function 'mmNext' equivalent to http://www.lispworks.com/documentation/HyperSpec/Body/f_call_n.htm (call-next-method) in CLOS.

(de subclass? (X Y)
   (if (pair Y)
      (loop
         (NIL Y T)
         (NIL (subclass? X (pop 'Y))) )
      (let Q (if (pair X) X (val X)) # dfs
         (use H
            (loop
               (NIL Q)
               (setq H (pop 'Q))
               (T (= H Y) T)
               (for HH (val H)
                  (push 'Q HH) ) ) ) ) ) )

(de mmApplicable (K M)
   (use (KK MM)
      (loop
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM) (subclass? KK MM)) NIL) ) ) )

(de mmApply @
   (let ("N" (next)
         "A" (rest)
         "K" (mapcar type "A")
         "Mm" (filter '((M) (mmApplicable "K" (car M))) (get "N" 'mm)) )
      (ifn "Mm"
         (quit 'mm (list "No applicable method" "N" "A" "K"))
         (let mmNext '(()
                       (ifn (cdr (pop '"Mm"))
                          (quit 'mm (list "No other method" "N" "A" "K"))
                          (apply @ "A") ) )
            (apply (cdr (pop '"Mm")) "A") ) ) ) )

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
            (loop
               (NIL L (put N 'mm (mmSort (cons P (get N 'mm)))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) ) # bug shared!?
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

(de mmLt (L R)
   (use (LH RH)
      (loop
         (NIL (or L R))
         (setq LH (pop 'L) RH (pop 'R))
         (T (and (not LH) RH) NIL)
         (T
          (when LH
             (or (not RH) (and (<> LH RH) (subclass? LH RH))) )
          T ) ) ) )

(de mmSort (L)
   (order L '((L R) (mmLt (car L) (car R)))) )

(de order (Lst Lt) # TODO built-in or better sort log(N) instead of N^2
   (let Q NIL
      (for X Lst
         (let S 0
            (for Y Lst
               (when (apply Lt NIL (car X) (car Y))
                  (inc 'S) ) )
            (push 'Q (cons S X))) )
      (flip (mapcar cdr (by car sort Q))) ) )

We introduced the predicate 'subclass?' which uses depth-first search in the superclass tree. We also modified slightly 'mmApplicable', 'mmApply' and 'mmDef' functions. The new functions 'mmLt', 'order' and 'mmSort' are for dispatch table ordering.

We can use the code as follows:

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< (X Y)
   (prin "?? Bang, what happened? ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prin "AA Look at the beautiful fireworks! ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prin "AS Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prin "SA Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prin "SS Who's fault was it? ")
   (println X Y) )

(collide< A A) # AA Look at the beautiful fireworks! $519672026 $519672026
(collide< A S) # AS Is it fatal? $519672026 $519672040
(collide< S A) # SA Is it fatal? $519672040 $519672026
(collide< S S) # SS Who's fault was it? $519672040 $519672040
(collide< A 1) # ?? Bang, what happened? $519672026 1
(collide< 2 A) # ?? Bang, what happened? 2 $519672026
(collide< S 3) # ?? Bang, what happened? $519672040 3
(collide< 4 S) # ?? Bang, what happened? 4 $519672040
(collide< 5 T) # ?? Bang, what happened? 5 T
(collide< T)   # ?? Bang, what happened? T NIL
(collide<)     # ?? Bang, what happened? NIL NIL

…or try the bank account example from PAIP:

(class +Acc)                        # account
(class +LtdAcc +Acc)                # account with withdrawal limit

(dmm withdraw< ((A +Acc) Amt)
   (with A
      (if (< (: bal) Amt)
         'insufficient-funds
         (dec (:: bal) Amt) ) ) )

(dmm withdraw< ((A +LtdAcc) Amt)
   (with A
      (if (< (: lim) Amt)
         'over-limit
         (mmNext) ) ) )

(setq F (new '(+Acc) 'nm "Fred" 'bal 5000 'irt 6))
(setq G (new '(+LtdAcc) 'nm "George" 'bal 4000 'irt 5 'lim 1000))

(withdraw< F 6000) # -> insufficient-funds
(withdraw< F 1000) # -> 4000
(withdraw< G 2000) # -> over-limit
(withdraw< G 200)  # -> 3800

There are some improvements that could be implemented:

<ul> <li>Add before, after and around methods as in CLOS</li> <li>Undefine methods</li> <li>Dispatch on value, e.g. (dmm collide\< ((A +Asteroid) (B (= "Bill"))) …).</li> <li>Add other types to dispatch on, e.g. atom pair num sym etc., e.g. (dmm collide\< ((A +Asteroid) (B pair)) …)</li> <li>more types: num sym atom pair T NIL null etc.</li> </ul>

Note that we cannot add a dispatch on any user defined predicate as we would not be able to sort the dispatch table automatically.

http://logand.com/sw/nb contains code for non-blocking I/O functions for picoLisp.

$ telnet localhost 4444

(off *H)

(class +Handler)
# s [w]

(dm T (S)
   (=: s S)
   (=: w (new))
   (push '*H (cons S This)) )

(dm rm> ()
   (prinl "q " (: s))
   (task (: s))
   (close (: s))
   (setq *H (delq (assoc (: s) *H) *H)) )

(dm wr> (Who Msg)
   (fifo (: w) (cons Who Msg)) )

(setq *N 1024 *B (need *N)) # read buffer

(dm cb> ()
   (block (: s) NIL)
   (let N (in (: s) (rdx *B *N))
      (prinl "r " (: s) " " N)
      (cond
         ((gt0 N) (for H *H (wr> (cdr H) S (head N *B))))
         ((= N (eagain)))
         (T (rm> This)) ) )
   (for H *H (fl> (cdr H))) )

(dm fl> ()
   (use X
      (while
         (and (setq X (cadr (val (: w)))) # peek head
              (let (S (cdr X)
                    M (length S)
                    N (out (: s) (wrx S M)))
                 (prinl "w " (: s) " " N "/" M)
                 (when (gt0 N)
                    (if (<= M N)
                       (fifo (: w))
                       (set (cdr (val (: w))) (tail (- M N) S)) ) ) ) ) ) ) )

(de chat (Port)
   (task (port Port)
      (when (accept @)
         (task @
            This (new '(+Handler) @)
            (cb> This) ) ) ) )

Welcome to picoWiki.

picoWiki is a PicoLisp \{http://en.wikipedia.org/wiki/Wiki wiki}. It contains links to and resources about PicoLisp and software implemented in PicoLisp.

Please use \{Sandbox} for experiments and learning the \{Formatting} markup.

The picoLisp built-in web server follows specific url conventions. Sometimes, it is useful to:

<ol> <li>have url format under control, i.e. having custom & "nice" application specific urls</li> <li>allow and collect any query parameters automatically</li> </ol>

The following code shows a sample web server which servers files from @public_html/ directory (relative to picoLisp home, which is not a problem as you can always create a symlink), e.g. http://localhost:8080/index.html is served from @public_html/index.html file.

(load "ext.l" "lib/http.l")

(de rewriteUrl (U)
   (chop (pack "public_html/" U)) )

# I'd recommend the following version of 'rewriteUrl'.
# It avoids the 'chop' following a 'pack' by using a constant
# pre-chopped "public..".
#
# (de rewriteUrl (U)
#    (append '`(chop "public_html/") (chop U)) )

(patch http
   '(if (<> *ConId *SesId) @X)
   (append '(if (<> *ConId *SesId))
      (list (car @X))
      (list '(setq @U (rewriteUrl @U)))
      (cdr @X) ) )

(redef http @
   (off *HtVars)
   (pass http) )

(redef _htSet @
   (push '*HtVars (cons (pack (next)) (next))) )

(allowed ("public_html/") "@start")

(de start ()
   (html 0 "Hello" NIL NIL
      "Hello World!" ) )

(server 8080 "@start")

Note that @start is never called but it could be if we used a more sophisticated rewriting function.

\{ToDo} SSI

Rich Text Formatting GUI element for \{+Blob} with text data. Uses \{http://tinymce.moxiecode.com TinyMCE} for the JavaScript part.

This class is not part of the PicoLisp distribution.

(class +RteField +BlobField)

(dm show> ("Var")
   (let (Id (pack *Form '- (: id))
         OnL ,"Plain text »"
         OffL ,"Rich formatting »")
      (<div> NIL
         (<div> (list (cons 'id (pack Id "d"))))
         (super "Var"))
      (prin "<script>rteSwitch('" Id "'," (if (able) "true" "false")
         ",'" OnL "','" OffL "');</script>")))

Usage:

(class +C +Entity)
(rel r (+Blob))
...
(gui '(+RteField) '(r : home obj) 70 25)

See \{http://logand.com/ed/ed.js} for the JavaScript part.

PicoLisp does not support tail call optimisation. However, there is a way around it, using a \{http://en.wikipedia.org/wiki/Trampoline_(computers) trampoline}:

Used in some LISP implementations, a trampoline is a loop that iteratively invokes thunk-returning functions. A single trampoline is sufficient to express all control transfers of a program; a program so expressed is trampolined or in "trampolined style"; converting a program to trampolined style is trampolining. Trampolined functions can be used to implement tail recursive function calls in stack-oriented languages.

First, lets see the final code and then discuss how to use and derive it:

(def 'continue list)

(de done (R)
   (cons NIL R) )

(de trampoline (F A)
   (use R
      (loop
         (NIL (car (setq R (apply F A))) (cdr R))
         (setq F (car R) A (cdr R)) ) ) )

There was a \{http://www.mail-archive.com/picolisp@software-lab.de/msg00136.html discussion} on the topic suggesting that it is better to rewrite your recursive code using loops but there could be cases when recursion is a better abstraction.

Lets suppose we have the following, mutually recursive functions (the example was taken from \{http://bc.tech.coop/blog/040613.html here}):

(de f1 (N)
   (println N)
   (if (= N 0)
      (println 'Blastoff!)
      (f2 N)))

(de f2 (N)
   (f1 (- N 1)))

(f1 90000) # => crash

If we call 'f1' with sufficiently big number, picoLisp interpreter runs out of stack eventually. This need not to be so. We can rewrite the code as follows:

(de f1 (N)
   (println N)
   (if (= N 0)
      (throw 'done 'Blastoff!)
      (list f2 N)))

(de f2 (N)
   (list f1 (- N 1)))

(de run-trampolined (F A)
   (catch 'done
      (loop
         (let R (apply F A)
            (setq F (car R) A (cdr R)) ) ) ) )

: (run-trampolined f1 '(9000))
9000
8999
...
1
0
-> Blastoff!

We could add some syntactic sugar:

(def 'continue list)

(de done (R)
   (throw 'trampoline R))

(de trampoline (F A)
   (catch 'trampoline
      (loop
         (let R (apply F A)
            (setq F (car R) A (cdr R)) ) ) ) )

(de f1 (N)
   (println N)
   (if (= N 0)
      (done 'Blastoff!)
      (continue f2 N)))

(de f2 (N)
   (continue f1 (- N 1)))

(run-trampolined f1 '(9000))

Now lets try usual factorial example:

(de fact (N)
   (if (< N 2)
      1
      (* N (fact (- N 1)))))

(fact 5) # => 120

We can rewrite 'fact' using tail call recursion:

(de fact/ (N R)
   (default R 1)
   (if (< N 2)
      R
      (fact/ (- N 1) (* N R))))

(fact/ 5)

and now we are ready for a trampoline:

(de fact/t (N R)
   (default R 1)
   (if (< N 2)
      (done R)
      (continue fact/t (- N 1) (* N R))))

(trampoline fact/t '(5))

Actually, we do not need throw/catch:

(def 'continue list)

(de done (R)
   (cons NIL R))

(de trampoline (F A)
   (use R
      (loop
         (NIL (car (setq R (apply F A))) (cdr R))
         (setq F (car R) A (cdr R)) ) ) )

What happens if we call 'fact/t' directly without 'trampoline'?

: (fact/t 5)
-> (((N R)
     (default R 1)
     (if (< N 2)
        (done R)
        (continue fact/t (- N 1) (* N R))))
    4 5)

In other words, we managed to split the original recursive call into a sequence of partial computations. The result above shows what function is to be called next (after the first iteration) and what arguments should be used.

As the \{http://en.wikipedia.org/wiki/Trampoline_(computers) Wikipedia article} suggests, a single trampoline is sufficient to express all control transfers of a program. That gives us very powerful tool which could be useful in some cases, especially when used together with the power of lisp to make higher level syntactic abstractions.

\{ToDo} continuations

\{ToDo} cps

\{ToDo} light-weight processes

\{ToDo} asynchronous server