# -*- picolisp -*- # @@PLEAC@@_NAME # @@SKIP@@ PicoLisp # @@PLEAC@@_WEB # @@SKIP@@ http://picolisp.com # @@PLEAC@@_1.0 # PicoLisp has no special string type. Instead, symbols are used. Syntactically, # "transient" symbols resemble strings in other languages. Also, there is no # separate character type. Instead, characters are represented by strings of # length 1 (using 1 .. 3 bytes (UTF-8)). #----------------------------- (setq String "^J") # a newline character (setq String "\^J") # two characters, '^' and 'J' #----------------------------- : "Jon \"Maddog\" Orwant" # literal double quotes -> "Jon \"Maddog\" Orwant" # Single quotes do not delimit strings, and are not special inside strings #----------------------------- : "This is a multiline string containing a newline" -> "This is a multiline string^Jcontaining a newline" : "This is a multiline string \ without a newline" -> "This is a multiline string without a newline" #----------------------------- # @@PLEAC@@_1.1 # First 'chop' the string to convert it to a list of characters, and then use # the rich set of list processing functions. Optionally, you can 'pack' the # result to a string (not necessary in many cases, as many functions that expect # a string also accept a list of characters). #----------------------------- # get a 5-byte string, skip 3, then grab 2 8-byte strings, then the rest : (let S (chop "This is a suitable string") (prinl (cut 5 'S)) (cut 3 'S) (prinl (cut 8 'S)) (prinl (cut 8 'S)) (prinl S) ) This a suitab le strin g #----------------------------- # split at five byte boundaries : (make (for (S (chop "This is what you have") S) (link (pack (cut 5 'S))) ) ) -> ("This " "is wh" "at yo" "u hav" "e") #----------------------------- (let S (chop "This is what you have") (prinl (car S)) (prinl (tail 2 (head 4 S))) (prinl (tail -13 S)) (prinl (tail 1 S)) (prinl (tail 4 S)) (prinl (head 3 (tail 8 S))) ) T is you have e have you #----------------------------- # You can test for substrings with 'pre?' and 'sub?' : (pre? "a" "abc") -> "abc" : (sub? "bc" "abcdef") -> "abcdef" : (sub? "x" "abc") -> NIL # or use the 'match' function : (match '("a" "b" @X "d" "e") (chop "abcde")) -> T : @X -> ("c") #----------------------------- # substitute "at" for "is", restricted to first five characters : (match '(@A "i" "s" @Z) (head 5 (chop "Me is You"))) (pack @A "at" @Z) -> "Me at" #----------------------------- # exchange the first and last letters in a string : (let S (chop "make a hat") (xchg S (tail 1 S)) (pack S) ) -> "take a ham" #----------------------------- # extract column : (pack (tail 6 (head 12 (chop "To be or not to be")))) -> "or not" #----------------------------- # skip every second character : (pack (filter prog2 (chop "To be or not to be") '(T NIL .))) -> "T eo o ob" #----------------------------- # @@PLEAC@@_1.2 #----------------------------- # Use B if B is true, else C (setq A (or B C)) # set X to Y unless X is already true (default X Y) #----------------------------- # use B if B is defined, else C (setq A (or (fun? B) C)) (def 'A (or (fun? B) C)) #----------------------------- (setq Dir (or (opt) "/tmp")) #----------------------------- (setq Dir (if (argv) (car @) "/tmp")) #----------------------------- # find the user name on Unix systems (setq User (or (sys "USER") (sys "LOGNAME") (native "@" "getlogin" 'S) # 'native' only in 64-bits (car (native "@" "getpwuid" '(S) UserID)) (pack "Unknown uid number " UserID) ) ) #----------------------------- : (default StartingPoint "Greenwich") -> "Greenwich" #----------------------------- (setq A (if B B C)) # assign B if nonempty, else C #----------------------------- # @@PLEAC@@_1.3 #----------------------------- (xchg 'Var1 'Var2) #----------------------------- (setq Temp A A B B Temp) #----------------------------- (setq A "alpha" B "omega") (xchg 'A 'B) #----------------------------- : (setq Alpha 'January Beta 'March Production 'August) -> August : (setq Alpha Beta Beta Production Production Alpha) -> March : Alpha -> March : Beta -> August #----------------------------- # @@PLEAC@@_1.4 #----------------------------- (char Character) -> Number (char Number) -> Character #----------------------------- : (let Num 101 (prinl "Number " Num " is character " (char Num)) ) Number 101 is character e -> "e" #----------------------------- : (mapcar char (chop "sample")) -> (115 97 109 112 108 101) : (pack (mapcar char (115 97 109 112 108 101))) -> "sample" #----------------------------- : (pack (mapcar '((C) (char (inc (char C)))) (chop "HAL") ) ) -> "IBM" #----------------------------- # @@PLEAC@@_1.5 #----------------------------- (for Char (chop String) (doSomethingWith Char) ) #----------------------------- : (prinl "unique chars are: " (sort (uniq (chop "an apple a day")))) unique chars are: adelnpy # Analog to Perl : (let Seen NIL (for C (chop "an apple a day") (accu 'Seen C 1) ) (pack (sort (mapcar car Seen))) ) -> " adelnpy" #----------------------------- : (sum char (chop "an apple a day")) -> 1248 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/sum #----------------------------- $ ./sum lib.l lib/misc.l 52659 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/slowcat #----------------------------- # @@PLEAC@@_1.6 #----------------------------- (setq RevChars (flip (chop String)) RevWords (glue " " (flip (split (chop String) " "))) ) #----------------------------- # reverse word order : (glue " " (flip (split (chop "Yoda said, \"can you see this?\"") " ") ) ) -> "this?\" see you \"can said, Yoda" #----------------------------- : (de palindrome? (S) (= (setq S (chop S)) (reverse S)) ) : (palindrome? "reviver") -> T #----------------------------- : (in "/usr/share/dict/words" (until (eof) (let L (line) (and (> (length L) 5) (= L (reverse L)) (prinl L) ) ) ) ) deified redder #----------------------------- # @@PLEAC@@_1.7 #----------------------------- (let Str (line) (use (@A @Z) # Expand tabs (while (match '(@A "^I" @Z) Str) (setq Str (conc @A (need (- 8 (% (length @A) 8)) " ") @Z ) ) ) ) Str ) #----------------------------- (let Str (line) (make # Compress tabs (while (nth Str 9) (let S (trim (cut 8 'Str)) (chain S) (or (= 8 (length S)) (link "^I")) ) ) (and Str (chain @)) ) ) #----------------------------- # @@PLEAC@@_1.8 #----------------------------- : (let Dept 123 (prinl "You owe " Dept " to me.") (pack "You owe " Dept " to me.") ) You owe 123 to me. -> "You owe 123 to me." #----------------------------- : (text "I am @1 high and @2 long" 24 80) -> "I am 24 high and 80 long" #----------------------------- (let (@Rows 24 @Cols 80) (fill '(I am @Rows high and @Cols long)) ) -> (I am 24 high and 80 long) #----------------------------- # expand variables in 'Lst', but put an error message in # if the variable isn't defined (let (@Rows 24 Lst '(I am @Rows high and @Cols long)) (for Var (fish pat? Lst) (unless (val Var) (set Var (pack "[NO VARIABLE: " Var "]")) ) ) (fill Lst) ) -> (I am 24 high and "[NO VARIABLE: @Cols]" long) #----------------------------- # @@PLEAC@@_1.9 #----------------------------- : (uppc "bo peep") -> "BO PEEP" : (lowc "JOHN") -> "john" : (let S (chop "dromedary") (pack (uppc (car S)) (cdr S))) -> "Dromedary" #----------------------------- # capitalize each word's first character, downcase the rest (let Str "thIS is a loNG liNE" (glue " " (mapcar '((W) (cons (uppc (car W)) (mapcar lowc (cdr W)))) (split (chop Str) " ") ) ) ) -> "This Is A Long Line" #----------------------------- (when (= (uppc A) (uppc B)) (prinl "A and B are the same") ) #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/randcap #----------------------------- # @@PLEAC@@_1.10 #----------------------------- : (let N 7 (prinl "I have " (+ N 2) " guanacos.") (pack "I have " (+ N 2) " guanacos.") ) I have 9 guanacos. -> "I have 9 guanacos." #----------------------------- : (let N 7 (text "I have @1 guanacos." (+ N 2)) ) #----------------------------- (mail "localhost" 25 "Your Bank" Naughty "Subject" (prinl "Dear " Naughty) "" (prinl "Today, you bounced check number " (+ 500 (rand 0 99)) " to us.") "Your account is now closed." "" "Sincerely," "the management" ) #----------------------------- # @@PLEAC@@_1.11 #----------------------------- (de myhere (Target) # The built-in 'here' cannot be used (char) (setq Target (chop Target)) (make (for (L (line) (and L (<> L Target)) (line)) (link L) ) ) ) #----------------------------- (setq Var (mapcar clip (myhere "HERE_TARGET"))) your text goes here HERE_TARGET # or with two steps (setq Var (myhere "HERE_TARGET")) your text goes here HERE_TARGET (setq Var (mapcar clip Var)) #----------------------------- (prinl "Here's your poem:") (prinl) (let (Str (prog (char) (line)) Cnt 1) (for (S Str (and S (sp? (car S))) (cdr S)) (inc 'Cnt) ) (loop (prinl (nth Str Cnt)) (T (eof)) (setq Str (line)) (T (= '`(chop "EVER_ON_AND_ON") Str)) ) ) Now far ahead the Road has gone, And I must follow, if I can, Pursuing it with eager feet, Until it joins some larger way Where many paths and errands meet. And whither then? I cannot say. --Bilbo in /usr/src/perl/pp_ctl.c EVER_ON_AND_ON #----------------------------- # @@PLEAC@@_1.12 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/wrapdemo #----------------------------- # @@PLEAC@@_1.13 #----------------------------- # backslash : (let (CharList '(a d g) Str "abcdefghi") (pack (mapcar '((C) (pack (and (member C CharList) "\\") C)) (chop Str) ) ) ) -> "\\abc\\def\\ghi" # double : (let (CharList '(a d g) Str "abcdefghi") (pack (mapcar '((C) (pack (and (member C CharList) C) C)) (chop Str) ) ) ) -> "aabcddefgghi" #----------------------------- # @@PLEAC@@_1.14 #----------------------------- (trim (chop String)) # Remove trailing white space (clip (chop String)) # Remove white space from both ends #----------------------------- # print what's typed, but surrounded by >< symbols (in NIL (until (eof) (prinl ">" (clip (line)) "<") ) ) #----------------------------- # @@PLEAC@@_1.15 #----------------------------- (for (I . Line) (let *Uni T (str "XYZZY,\"\",\"O'Reilly, Inc\",\"Wall, Larry\",\"a \ \\\"glug\\\" bit,\",5, \"Error, Core Dumped\"" ) ) (prinl I " : " Line) ) 1 : XYZZY 2 : 3 : O'Reilly, Inc 4 : Wall, Larry 5 : a "glug" bit, 6 : 5 7 : Error, Core Dumped #----------------------------- # @@PLEAC@@_1.16 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/soundex #----------------------------- $ ./soundexUsers Lookup user: sshd ("sshd" "x" 71 65 "SSH daemon" "/var/lib/sshd" "/bin/false") #----------------------------- # @@PLEAC@@_1.17 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/fixstyle #----------------------------- # @@PLEAC@@_1.18 #----------------------------- # @@INCLUDE@@ include/picolisp/ch01/psgrep #----------------------------- # @@PLEAC@@_2.1 #----------------------------- # PicoLisp has only a single numeric type, the bignum. # The function 'format' returns NIL if the argument is # not a legal number : (format "12345") -> 12345 # is a number : (format "123a5") -> NIL # is not #----------------------------- : (format "1234.5678") -> 1235 : (format "1234,5678" 2 ",") -> 123457 : (format "-1,234.5" 2 "." ",") -> -123450 #----------------------------- # @@PLEAC@@_2.2 # PicoLisp has no real floating point numbers # Only scaled (fixpoint) integers #----------------------------- : (= (format "1234.5678" 2) (format "1234.572" 2)) -> T #----------------------------- # @@PLEAC@@_2.3 #----------------------------- : (format "1234.5678") -> 1235 : (format "1234.5678" 2) -> 123457 : (scl 3) -> 3 : (setq A 0.255) -> 255 : (prinl "Unrounded: " (format A *Scl) "^JRounded: " (round A 2)) Unrounded: 0.255 Rounded: 0.26 -> "0.26" #----------------------------- : (scl 1) -> 1 : (let Fmt (7 7 7 7) (tab Fmt "number" "int" "floor" "ceil") (for N (3.3 3.5 3.7 -3.3) (tab Fmt (format N *Scl) (format (* 1.0 (/ N 1.0)) *Scl) (format (* 1.0 (*/ (- N 0.5) 1.0)) *Scl) (format (* 1.0 (*/ (+ N 0.5) 1.0)) *Scl) ) ) ) number int floor ceil 3.3 3.0 3.0 4.0 3.5 3.0 3.0 4.0 3.7 3.0 3.0 4.0 -3.3 -3.0 -4.0 -3.0 -> NIL #----------------------------- # @@PLEAC@@_2.4 #----------------------------- : (bin 54) -> "110110" : (bin "110110") -> 54 #----------------------------- # @@PLEAC@@_2.5 #----------------------------- : (prin "Infancy is: ") (for N 3 (printsp (dec N))) (prinl) Infancy is: 0 1 2 #----------------------------- : (prin "Toddling is: ") (println 3 4) Toddling is: 3 4 #----------------------------- : (prin "Childhood is: ") (apply println (range 5 12)) Childhood is: 5 6 7 8 9 10 11 12 # or : (prin "Childhood is: ") (mapc printsp (range 5 12)) (prinl) Childhood is: 5 6 7 8 9 10 11 12 # or : (prin "Childhood is: ") (for (N 5 (>= 12 N) (inc N)) (printsp N)) (prinl) #----------------------------- # @@PLEAC@@_2.6 #----------------------------- : (de roman (N) (pack (make (mapc '((C D) (while (>= N D) (dec 'N D) (link C) ) ) '(M CM D CD C XC L XL X IX V IV I) (1000 900 500 400 100 90 50 40 10 9 5 4 1) ) ) ) ) -> roman : (prinl "Roman for fifteen is " (roman 15)) Roman for fifteen is XV -> "XV" : (de arabic (R) (let N 0 (for (L (chop (uppc R)) L) (find '((C D) (when (head C L) (cut (length C) 'L) (inc 'N D) ) ) '`(mapcar chop '(M CM D CD C XC L XL X IX V IV I)) (1000 900 500 400 100 90 50 40 10 9 5 4 1) ) ) N ) ) -> arabic : (prinl "Converted back, " (roman 15) " is " (arabic (roman 15))) Converted back, XV is 15 -> 15 #----------------------------- # @@PLEAC@@_2.7 #----------------------------- : (rand) -> 643875838651014379 #----------------------------- : (rand 1 6) # Dice -> 3 #----------------------------- : (rand 900000 999999) -> 989901 #----------------------------- : (rand T) # Boolean -> NIL : (rand T) -> T #----------------------------- : (setq Password (pack (head 8 (by '(NIL (rand)) sort (conc (chop "!@$%\^&*") (mapcar char (conc (range `(char "A") `(char "Z")) (range `(char "a") `(char "z")) (range `(char "0") `(char "9")) ) ) ) ) ) ) ) #----------------------------- # @@PLEAC@@_2.8 #----------------------------- : (seed 42) -> 62419389940 : (seed "Hello world") -> -967786026117696633 : (seed (time)) -> -54340987292621 #----------------------------- # @@PLEAC@@_2.9 #----------------------------- : (in "/dev/urandom" (rd 12)) -> 50416291644794614409246112035 #----------------------------- # @@PLEAC@@_2.10 #----------------------------- (load "@lib/math.l") (de rand2 () (rand `(inc -1.0) `(dec 1.0)) ) (de gaussianRand () (use (U1 U2 W) (while (>= (setq W (+ (*/ (setq U1 (rand2)) U1 1.0) (*/ (setq U2 (rand2)) U2 1.0) ) ) 1.0 ) ) (setq W (sqrt (*/ 1.0 -2.0 (log W) W))) (*/ U2 W 1.0) ) ) (prinl "You have been hired at $" (round (+ 25.0 (* 2 (gaussianRand))) 2) ) #----------------------------- # @@PLEAC@@_2.11 #----------------------------- (load "@lib/math.l") (de deg2rad (Deg) (*/ Deg pi 180.0) ) (de rad2deg (Rad) (*/ Rad 180.0 pi) ) #----------------------------- # @@PLEAC@@_2.12 #----------------------------- (load "@lib/math.l") : (format (cos 0.333333) *Scl) -> "0.944957" : (format (acos 0.944957) *Scl) -> "0.333333" : (format (tan pi/2) *Scl) -> "3060023.306953" #----------------------------- # @@PLEAC@@_2.13 #----------------------------- (load "@lib/math.l") : (format (log 10.0) *Scl) -> "2.302585" (de logBase(Base Val) (*/ (log Val) 1.0 (log Base)) ) : (format (logBase 10.0 10000.0) *Scl) -> "4.000000" #----------------------------- # @@PLEAC@@_2.14 #----------------------------- (de mmult (Mat1 Mat2) (unless (= (length Mat1) (length (car Mat2))) (quit "IndexError: matrices don't match") ) (mapcar '((Row) (apply mapcar Mat2 '(@ (apply + (mapcar * Row (rest)))) ) ) Mat1 ) ) #----------------------------- : (mmult '((3 2 3) (5 9 8)) '((4 7) (9 3) (8 8)) ) -> ((54 51) (165 126)) #----------------------------- # @@PLEAC@@_2.15 # PicoLisp doesn't have a complex library, but a set of # functions for complex numbers can be easily written #----------------------------- (load "@lib/math.l") (de addComplex (A B) (cons (+ (car A) (car B)) # Real (+ (cdr A) (cdr B)) ) ) # Imag (de mulComplex (A B) (cons (- (*/ (car A) (car B) 1.0) (*/ (cdr A) (cdr B) 1.0) ) (+ (*/ (car A) (cdr B) 1.0) (*/ (cdr A) (car B) 1.0) ) ) ) (de invComplex (A) (let Denom (+ (*/ (car A) (car A) 1.0) (*/ (cdr A) (cdr A) 1.0) ) (cons (*/ (car A) 1.0 Denom) (- (*/ (cdr A) 1.0 Denom)) ) ) ) (de negComplex (A) (cons (- (car A)) (- (cdr A))) ) (de sqrtComplex (A) (let (R (sqrt (+ (* (car A) (car A)) (* (cdr A) (cdr A)))) Y (sqrt (* (- R (car A)) 0.5)) X (*/ (cdr A) 0.5 Y) ) (cons # Return both results (cons X Y) (cons (- X) (- Y)) ) ) ) (de fmtComplex (A) (pack (round (car A) (dec *Scl)) (and (gt0 (cdr A)) "+") (round (cdr A) (dec *Scl)) "i" ) ) #----------------------------- : (let (A (3.0 . 5.0) B (2.0 . -2.0)) (prinl "c = " (fmtComplex (mulComplex A B))) ) c = 16.00000+4.00000i #----------------------------- : (let D (3.0 . 4.0) (prinl "sqrt(" (fmtComplex D) ") = " (fmtComplex (car (sqrtComplex D)))) ) sqrt(3.00000+4.00000i) = 2.00000+1.00000i #----------------------------- # @@PLEAC@@_2.16 #----------------------------- (prin "Gimme a number in decimal, octal, or hex: ") (let Num (in NIL (clip (line))) (setq Num (if2 (= "0" (car Num)) (= "x" (cadr Num)) (hex (cddr Num)) (oct (cdr Num)) NIL (format Num) ) ) (prinl Num " " (hex Num) " " (oct Num)) ) #----------------------------- (prin "Enter file permission in octal: ") (let Permissions (oct (in NIL (clip (line)))) (prinl "The decimal value is " Permissions) ) #----------------------------- # @@PLEAC@@_2.17 #----------------------------- : (let Cnt -1740525205 (prinl "Your web page received " (format Cnt 0 "." ",") " accesses last month." ) ) Your web page received -1,740,525,205 accesses last month. #----------------------------- # @@PLEAC@@_2.18 #----------------------------- (prinl "It took " Time " hour" (unless (= 1 Time) "s")) (prinl Time " hour" (unless (= 1 Time) "s") (if (= 1 Time) " is" " are") " enough." ) (prinl "It took " Time " centur" (if (= 1 Time) "y" "ies")) #----------------------------- (de nounPlural (Str) (let (S (chop Str) @A) (cond ((find tail '((s s) (p h) (s h) (c h) (z)) (circ S)) (pack Str "es") ) ((tail '(f f) S) (pack S "s")) ((match '(@A f) S) (pack @A "ves")) ((tail '(e y) S) (pack S "s")) ((match '(@A y) S) (pack @A "ies")) ((match '(@A i x) S) (pack @A "ices")) ((or (tail '(s) S) (tail '(x) S)) (pack S "es") ) (T (pack S "s")) ) ) ) #----------------------------- (for S (quote fish fly ox species genus phylum cherub radius jockey index matrix mythos phenomenon formula ) (prinl "One " S ", two " (nounPlural S) ".") ) #----------------------------- # @@PLEAC@@_2.19 #----------------------------- # @@INCLUDE@@ include/picolisp/ch02/bigfact #----------------------------- $ ./bigfact 17 60 125 239322000000000000000000 17 PRIME 60 2**2 3 5 125 5**3 239322000000000000000000 2**19 3 5**18 39887 #----------------------------- # @@PLEAC@@_3.0 # Dates and times are handled in PicoLisp by the built-in 'date' and 'time' # functions, and additional functions like 'day' and 'week', and various # functions for formatting and localization #----------------------------- : (prinl "Today is day " (- (date) (date (car (date (date))) 1 1) -1) " of the current year." ) Today is day 365 of the current year. #----------------------------- # @@PLEAC@@_3.1 #----------------------------- : (date (date)) -> (2010 12 31) #----------------------------- : (prinl "The current date is " (dat$ (date) " ")) The current date is 2010 12 31 #----------------------------- : (prinl "The current date is " (dat$ (date) "-")) The current date is 2010-12-31 #----------------------------- : (prinl (stamp)) 2010-12-31 13:31:27 #----------------------------- # @@PLEAC@@_3.2 #----------------------------- : (- (+ (* 86400 (date T)) (time T)) (* 86400 (date 1970 1 1))) -> 1293799342 : (- (+ (* 86400 (date 2010 12 30)) (time 6 57 52)) (* 86400 (date 1970 1 1))) -> 1293692272 : (- (+ (* 86400 ($dat "20101230")) ($tim "6:57:52")) (* 86400 (date 1970 1 1))) -> 1293692272 #----------------------------- # @@PLEAC@@_3.3 #----------------------------- : (let (Secs (+ 1293692272 (* 86400 (date 1970 1 1))) Date (/ Secs 86400) Time (% Secs 86400) ) (prinl "Date: " (datSym Date) ", time: " (tim$ Time T)) ) Date: 30dec10, time: 06:57:52 #----------------------------- # @@PLEAC@@_3.4 # See also the add/subtract in above epoch calculations #----------------------------- : (let D (date) (prinl "Today: " (day D) ", " (datStr D) " -> next week: " (day (inc 'D 7)) ", " (datStr D) ) ) Today: Friday, 2010-12-31 -> next week: Friday, 2011-01-07 #----------------------------- # @@PLEAC@@_3.5 #----------------------------- : (prinl "Today Jimi Hendrix would be " (- (date) (date 1942 11 27)) " days old" ) Today Jimi Hendrix would be 24871 days old #----------------------------- # @@PLEAC@@_3.6 #----------------------------- : (prinl "Today is " (day (date))) Today is Friday : (prinl "Jimi Hendrix was born on a " (day (date 1942 11 27))) Jimi Hendrix was born on a Friday #----------------------------- : (prinl "This is the " (week (date)) "th week") This is the 52th week #----------------------------- : (prinl "This is the " (cadr (date (date))) "th month") This is the 12th month #----------------------------- : (prinl "This is the year " (car (date (date)))) This is the year 2010 #----------------------------- # @@PLEAC@@_3.7 #----------------------------- # Calculate the days since the epoch : (- (date) ($dat "1998-06-03" "-")) -> 4594 #----------------------------- : (date (expDat "31")) -> (2010 12 31) : (date (expDat "3112")) -> (2010 12 31) : (date (expDat "311210")) -> (2010 12 31) : (date (expDat "31.12.10")) -> (2010 12 31) : (date (expDat "31.12")) -> (2010 12 31) #----------------------------- # @@PLEAC@@_3.8 #----------------------------- (load "@lib/http.l") : (httpDate (date T) (time T)) Fri, 31 Dec 2010 13:21:03 GMT #----------------------------- : (stamp) -> "2010-12-31 14:21:47" #----------------------------- : (datStr (date)) -> "2010-12-31" : (locale "DE" "de") : (datStr (date)) -> "31.12.2010" : (locale "JP" "jp") : (datStr (date)) -> "2010/12/31" #----------------------------- # @@PLEAC@@_3.9 #----------------------------- : (usec) # Microseconds -> 250502252 #----------------------------- : (let U (usec) (prin "Press return when ready: ") (line) (prinl "You took " (format (- (usec) U) 6) " seconds") ) Press return when ready: You took 2.711455 seconds #----------------------------- : (bench (prin "Press return when ready: ") (line)) Press return when ready: 1.332 sec #----------------------------- # Generate, sort and count 1 million random numbers : (bench (length (sort (make (do 1000000 (link (rand))))))) 2.839 sec -> 1000000 #----------------------------- # @@PLEAC@@_3.10 #----------------------------- (wait 250) # Sleep 0.25 secs #----------------------------- : (key 4000) # Wait max. 4 secs for a keypress -> "a" # (pressed "a" after 2 seconds) : (key 4000) -> NIL # (timed out) #----------------------------- # @@PLEAC@@_3.11 #----------------------------- # @@INCLUDE@@ include/picolisp/ch03/hopdelta #----------------------------- $ ./hopdelta
("The boy stood on the burning deck," "It was as hot as glass.") #----------------------------- (setq Bigarray (in "mydatafile" (make (until (eof) (link (line T)) ) ) ) ) #----------------------------- (setq PerlHost "www.perl.com" HostInfo (in (list 'nslookup PerlHost) (till NIL T)) ) #----------------------------- : (split (chop "Costs only $4.95") " ") -> (("C" "o" "s" "t" "s") ("o" "n" "l" "y") ("$" "4" "." "9" "5")) : (mapcar pack (split (chop "Costs only $4.95") " ")) -> ("Costs" "only" "$4.95") #----------------------------- (setq Ships '("Niña" "Pinta" "Santa María")) #----------------------------- # @@PLEAC@@_4.2 #----------------------------- : (pack "The " (glue ", " '(big brown dirty hungry)) " fox") -> "The big, brown, dirty, hungry fox" #----------------------------- (setq Array '(red yellow green)) : (prinl "I have " Array " marbles.") I have redyellowgreen marbles. : (prinl "I have " (glue " " Array) " marbles.") I have red yellow green marbles. #----------------------------- # @@INCLUDE@@ include/picolisp/ch04/commify_series #----------------------------- The list is: just one thing. The list is: Mutt and Jeff. The list is: Peter, Paul, and Mary. The list is: To our parents, Mother Theresa, and God. The list is: pastrami, ham and cheese, peanut butter and jelly, and tuna. The list is: recycle tired, old phrases and ponder big, happy thoughts. The list is: recycle tired, old phrases; ponder big, happy thoughts; and sleep and dream peacefully. #----------------------------- # @@PLEAC@@_4.3 #----------------------------- (de whatAboutThatArray () (prinl "The array now has " (length People) " elements.") (prinl "Element #4 is `" (get People 4) "'.") ) (de People Crosby Stills Nash Young ) : (whatAboutThatArray) The array now has 4 elements. Element #4 is `Young'. #----------------------------- (con (tail 2 People)) : (whatAboutThatArray) The array now has 3 elements. Element #4 is `'. #----------------------------- (setq People (need -10000 People)) : (whatAboutThatArray) The array now has 10000 elements. Element #4 is `'. #----------------------------- # @@PLEAC@@_4.4 #----------------------------- (for Item List (doSomething Item) ) #----------------------------- (for User BadUsers (complain User) ) #----------------------------- (for User AllUsers (let DiskSpace (getUsage User) (when (> DiskSpace MAX_QUOTA) (complain User) ) ) ) #----------------------------- (in '(who) (while (line T) (and (sub? "tchrist" @) (prinl @)) ) ) #----------------------------- (until (eof) (prinl (glue " " (flip (split (line) " ")))) ) #----------------------------- (for Item Array (prinl "i = " Item) ) #----------------------------- (setq Array (1 2 3)) (map dec Array) : Array -> (0 1 2) #----------------------------- # @@PLEAC@@_4.5 #----------------------------- # iterate over elements of list in $ARRAYREF (map '((L) (foo (car L)) # Do something with the element (set L) ) # Modify an element (destructively) List ) (for I (length List) (doSomethingWith (get List I)) ) #----------------------------- (setq Fruits '(Apple Blackberry) FruitRef 'Fruits ) : (for Fruit (val FruitRef) (prinl Fruit " tastes good in a pie.") ) Apple tastes good in a pie. Blackberry tastes good in a pie. #----------------------------- # @@PLEAC@@_4.6 #----------------------------- : (let Uniq NIL (for Item '(a b c b c d c d e d e f) (unless (memq Item Uniq) (push 'Uniq Item) ) ) Uniq ) -> (f e d c b a) #----------------------------- : (let Seen NIL (for Item '(a b c b c d c d e d e f) (accu 'Seen Item 1) ) Seen ) -> ((f . 1) (e . 2) (d . 3) (c . 3) (b . 2) (a . 1)) #----------------------------- : (uniq '(a b c b c d c d e d e f)) -> (a b c d e f) #----------------------------- # generate a list of users logged in, removing duplicates : (in '(who) (uniq (make (while (split (line) " ") (link (pack (car @))) ) ) ) ) -> ("tim" "abu" "ben") #----------------------------- : (println 'Users 'logged 'in: (sort @)) Users logged in: ("abu" "ben" "tim") #----------------------------- # @@PLEAC@@_4.7 #----------------------------- # find only elements in A and not in B : (sect '(a b c d e f) '(a c f h)) -> (a c f) #----------------------------- # Using symbol values : (setq key1 1 key2 2) -> 2 : key1 -> 1 : key2 -> 2 #----------------------------- # Using properties : (put 'Hash 'key1 1) -> 1 : (put 'Hash 'key2 2) -> 2 : (get 'Hash 'key1) -> 1 #----------------------------- # Using association lists : (de Hash (key1 . 1) (key2 . 2)) -> Hash : (assoc 'key1 Hash) -> (key1 . 1) : (asoq 'key1 Hash) -> (key1 . 1) : (get Hash 'key1) -> 1 #----------------------------- # Using index tree : (idx 'Hash '(key1 . 1) T) -> NIL : (idx 'Hash '(key2 . 2) T) -> NIL : (lup Hash 'key1) -> (key1 . 1) #----------------------------- # @@PLEAC@@_4.8 #----------------------------- (setq A (1 3 5 6 7 8) B (2 3 5 7 9) ) #----------------------------- # Union : (uniq (append A B)) -> (1 3 5 6 7 8 2 9) #----------------------------- # Intersection : (sect A B) -> (3 5 7) #----------------------------- # Difference : (diff A B) -> (1 6 8) #----------------------------- # @@PLEAC@@_4.9 #----------------------------- (setq Members '(Time Flies) Initiates '(An Arrow) ) #----------------------------- : (append Members Initiates) # Non-destructive -> (Time Flies An Arrow) #----------------------------- : (conc Members Initiates) # Destructive -> (Time Flies An Arrow) # 'Members' is now (Time Flies An Arrow) #----------------------------- : (insert 3 Members 'Like) # Non-destructive -> (Time Flies Like An Arrow) #----------------------------- : (set Members 'Fruit) # Destructive -> Fruit : (set (tail 1 Members) 'Banana) -> Banana : Members -> (Fruit Flies An Banana) #----------------------------- # @@PLEAC@@_4.10 #----------------------------- (reverse List) # Non-destructive #----------------------------- (flip List) # Destructive #----------------------------- : (sort (2 8 3 7 5 9 6)) -> (2 3 5 6 7 8 9) : (by - sort (2 8 3 7 5 9 6)) -> (9 8 7 6 5 3 2) #----------------------------- : (flip (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2))) -> (T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL) #----------------------------- # @@PLEAC@@_4.11 #----------------------------- # remove N elements from front of List : (setq List '(a b c d e f g)) -> (a b c d e f g) : (cut 3 'List) -> (a b c) : List -> (d e f g) #----------------------------- # remove N elements from end of List : (setq List '(a b c d e f g)) -> (a b c d e f g) : (tail 3 List) -> (e f g) : (con (nth List 4)) -> NIL : List -> (a b c d) #----------------------------- (setq Friends '(Peter Paul Mary Jim Tim) This (pop 'Friends) Thas (pop 'Friends) ) : This -> Peter : That -> NIL : Friends -> (Mary Jim Tim) #----------------------------- (setq Beverages '(Dew Jolt Cola Sprite Fresca) Pair (tail 2 Beverages) Beverages (head 3 Beverages) ) : Pair -> (Sprite Fresca) : Beverages -> (Dew Jolt Cola) #----------------------------- # @@PLEAC@@_4.12 #----------------------------- (with (find '((This) (== 'engineer (: category))) Employees ) (prinl "Highest paid engineer is: " (: name)) ) #----------------------------- # @@PLEAC@@_4.13 #----------------------------- (de Nums 84598 4439223 248749 2488711 233716 3375644 211118) : (filter '((N) (> N 1000000)) Nums) -> (4439223 2488711 3375644) #----------------------------- : (filter > Nums (1000000 .)) -> (4439223 2488711 3375644) #----------------------------- (filter '((This) (== 'Engineer (: position))) Employees) #----------------------------- # @@PLEAC@@_4.14 #----------------------------- # Pids is an unsorted array of process IDs (sort Pids) #----------------------------- # Descending sort : (flip (sort (4 19 8 4))) -> (19 8 4 4) : (sort (4 19 8 4) >) -> (19 8 4 4) : (by - sort (4 19 8 4)) -> (19 8 4 4) #----------------------------- # @@PLEAC@@_4.15 #----------------------------- : (by cdr sort '((4 . 7) (19 . 3) (8 . 1) (4 . 2))) # (recommended) -> ((8 . 1) (4 . 2) (19 . 3) (4 . 7)) : (sort # (slower and bigger) '((4 . 7) (19 . 3) (8 . 1) (4 . 2)) '((X Y) (> (cdr Y) (cdr X))) ) -> ((8 . 1) (4 . 2) (19 . 3) (4 . 7)) #----------------------------- (for This (by '((This) (: name)) sort Employees) (prinl (: name) " earns $" (: salary)) ) #----------------------------- (by '((This) (cons (: name) (: age))) sort Employees) #----------------------------- (by '((S) (cadr (chop S))) sort Names) #----------------------------- (by length sort Strings) #----------------------------- (sort (in "/etc/passwd" (make (while (split (line) ":") (link (mix @ 4 3 1)) ) ) ) ) #----------------------------- # @@PLEAC@@_4.16 #----------------------------- : (circ 'a) -> (a .) : (circ 'a 'b 'c) -> (a b c .) : (rot @) -> (c a b .) #----------------------------- # @@PLEAC@@_4.17 #----------------------------- (by '(NIL (rand)) sort Lst) # OK #----------------------------- # @@PLEAC@@_4.18 #----------------------------- # @@INCLUDE@@ include/picolisp/ch04/words #----------------------------- # @@PLEAC@@_4.18 #----------------------------- (de permute (Lst) (ifn (cdr Lst) (cons Lst) (mapcan '((X) (mapcar '((Y) (cons X Y)) (permute (delete X Lst)) ) ) Lst ) ) ) : (mapc println (permute '(man bites dog))) (man bites dog) (man dog bites) (bites man dog) (bites dog man) (dog man bites) (dog bites man) #----------------------------- (de factorial (N) (apply * (range 1 N)) ) : (for N 15 (tab (-20 -10) N (factorial N))) 1 1 2 2 3 6 4 24 5 120 6 720 7 5040 8 40320 9 362880 10 3628800 11 39916800 12 479001600 13 6227020800 14 87178291200 15 1307674368000 : (factorial 500) -> 12201368259911100687...00000000000000000000 : (length @) -> 1135 #----------------------------- # @@INCLUDE@@ include/picolisp/ch04/permute #----------------------------- # @@PLEAC@@_5.0 # To associate keys with values, PicoLisp uses (besides the built-in database) # 1. Symbol properties ('put', 'get', ':' etc.) # 2. Association lists ('assoc', 'asoq', 'get') # 3. Binary trees ('idx', 'lup') # For the examples in this section we use association lists #----------------------------- (de Age (Nat . 24) (Jules . 25) (Josh . 17) ) #----------------------------- (push 'Age (cons 'Nat 24) (cons 'Jules 25) (cons 'Josh 17) ) #----------------------------- (de FoodColor (Apple . "red") (Banana . "yellow") (Lemon . "yellow") (Carrot . "orange") ) #----------------------------- # @@PLEAC@@_5.1 #----------------------------- # FoodColor defined per the introduction (push 'FoodColor '(Raspberry . "pink")) : (prinl "Known foods:") (for F FoodColor (println (car F))) Known foods: Raspberry Apple Banana Lemon Carrot #----------------------------- # @@PLEAC@@_5.2 #----------------------------- # FoodColor per the introduction : (for Name '("Banana", "Martini") (prinl Name (if (assoc Name FoodColor) " is a food." " is a drink.")) ) Banana is a food. Martini is a drink. #----------------------------- # @@PLEAC@@_5.3 #----------------------------- (del Key Var) #----------------------------- # FoodColor per the introduction (de printFoods () (prin "Keys: ") (apply println (mapcar car FoodColor)) (prin "Values: ") (apply println (mapcar cdr FoodColor)) ) (prinl "Initially:") (printFoods) (prinl) (prinl "With Banana undef:") (del (assoc 'Banana FoodColor) 'FoodColor) (printFoods) #----------------------------- Initially: Keys: Raspberry Apple Banana Lemon Carrot Values: "pink" "red" "yellow" "yellow" "orange" With Banana undef: Keys: Raspberry Apple Lemon Carrot Values: "pink" "red" "yellow" "orange" #----------------------------- # @@PLEAC@@_5.4 #----------------------------- # FoodColor as per the introduction : (for F FoodColor (prinl (car F) " is " (cdr F)) ) Apple is red Banana is yellow Lemon is yellow Carrot is orange : (mapc '((Food Color) (prinl Food " is " Color)) (mapcar car FoodColor) (mapcar cdr FoodColor) ) Apple is red Banana is yellow Lemon is yellow Carrot is orange #----------------------------- : (for F (sort FoodColor) (prinl (car F) " is " (cdr F)) ) Apple is red Banana is yellow Carrot is orange Lemon is yellow #----------------------------- # @@INCLUDE@@ include/picolisp/ch05/countfrom #----------------------------- # @@PLEAC@@_5.5 #----------------------------- # FoodColor as per the introduction : FoodColor -> ((Apple . "red") (Banana . "yellow") (Lemon . "yellow") (Carrot . "orange")) : (mapc println FoodColor) (Apple . "red") (Banana . "yellow") (Lemon . "yellow") (Carrot . "orange") : (for X FoodColor (prinl (car X) " => " (cdr X)) ) Apple => red Banana => yellow Lemon => yellow Carrot => orange #----------------------------- # @@PLEAC@@_5.6 #----------------------------- (queue 'FoodColor (cons 'Banana "Yellow")) (queue 'FoodColor (cons 'Apple "Green")) (queue 'FoodColor (cons 'Lemon "Yellow")) : FoodColor -> ((Banana . "Yellow") (Apple . "Green") (Lemon . "Yellow")) # In insertion order, the foods are: : (for Food FoodColor (prinl " " (car Food)) ) In insertion order, the foods are: Banana Apple Lemon # Still in insertion order, the foods' colors are: : (for Food FoodColor (prinl (car Food) " is colored " (cdr Food) ".") ) Banana is colored Yellow. Apple is colored Green. Lemon is colored Yellow. #----------------------------- # @@PLEAC@@_5.7 #----------------------------- : (setq Ttys (sort (group (in '(who) (make (while (read) (link (cons @ (read))) (line) ) ) ) ) ) ) -> ((abu tty1 pts/1 pts/3 pts/4 pts/5) (root tty2)) : (for U Ttys (prin (car U) ": ") (apply println (cdr U)) ) abu: tty1 pts/1 pts/3 pts/4 pts/5 root: tty2 #----------------------------- (for U Ttys (prinl (car U) ": " (length (cdr U)) " ttys.") (for Tty (sort (cdr U)) (prinl "^I" Tty " (owned by " (car U) ")") ) ) #----------------------------- # Delete all pts/3 .. pts/5 (for U Ttys (con U (diff (cdr U) '(pts/3 pts/4 pts/5))) ) : Ttys -> ((abu tty1 pts/1) (root tty2)) #----------------------------- # @@PLEAC@@_5.8 #----------------------------- (setq Surname '((Mickey . Mantle) (Babe . Ruth)) FirstName (mapcar '((X) (cons (cdr X) (car X))) Surname) ) : (get FirstName 'Mantle) -> Mickey #----------------------------- # @@INCLUDE@@ include/picolisp/ch05/foodfind #----------------------------- # FoodColor as per the introduction : (extract '((F) (and (= "yellow" (cdr F)) (car F))) FoodColor ) -> (Banana Lemon) #----------------------------- # @@PLEAC@@_5.9 #----------------------------- : (setq FoodColor (sort FoodColor)) -> ((Apple . "red") (Banana . "yellow") (Carrot . "orange") (Lemon . "yellow")) : (setq FoodColor (by cdr sort FoodColor)) -> ((Carrot . "orange") (Apple . "red") (Banana . "yellow") (Lemon . "yellow")) #----------------------------- # @@PLEAC@@_5.10 #----------------------------- # FoodColor per the introduction (setq DrinkColor '((Galliano . "yellow") ("Mai Tai" . "blue")) IngestedColor (append FoodColor DrinkColor) ) #----------------------------- : (setq AllColors (uniq (mapcar cdr IngestedColor))) -> ("red" "yellow" "orange" "blue") #----------------------------- # @@PLEAC@@_5.11 #----------------------------- # FoodColor per the introduction # CitrusColor is a hash mapping citrus food name to its color. (de CitrusColor (Lemon . "yellow") (Orange . "orange") (Lime . "green") ) # build up a list of non-citrus foods : (filter '((F) (not (assoc (car F) CitrusColor))) FoodColor) -> ((Apple . "red") (Banana . "yellow") (Carrot . "orange")) #----------------------------- # @@PLEAC@@_5.12 #----------------------------- (setq Files (extract '((File) (and (info File) (cons File (car @)))) '("/etc/termcap", "/vmunix", "/bin/cat") ) ) (prinl "open files " (glue ", " (mapcar car Files))) (for F Files (prinl (car F) " is " (cdr F) " bytes long.") ) #----------------------------- # @@PLEAC@@_5.13 #----------------------------- # Has no meaning in PicoLisp. All data structures grow dynamically. #----------------------------- # @@PLEAC@@_5.14 #----------------------------- : (off Count) -> NIL : (for Element '(a b c b c d) (accu 'Count Element 1) ) -> (d . 1) : Count -> ((d . 1) (c . 2) (b . 2) (a . 1)) #----------------------------- # @@PLEAC@@_5.15 #----------------------------- (de Father (Cain . Adam) (Abel . Adam) (Seth . Adam) (Enoch . Cain) (Irad . Enoch) (Mehujael . Irad) (Methusael . Mehujael) (Lamech . Methusael) (Jubal . Lamech) (Tubalcain . Lamech) (Enos . Seth) ) (de ancestor (Name) (while (assoc Name Father) (setq Name (cdr @)) ) Name ) # Always 'Adam' (setq Children (mapcar '((L) (cons (cdar L) (mapcar car L))) (by cdr group Father) ) ) (de children (Name) (prinl Name " begat " (if (get Children Name) (glue ", " @) "nobody" ) ) ) #----------------------------- : (children 'Adam) Adam begat Cain, Abel, Seth : (children 'Enos) Enos begat nobody #----------------------------- # @@PLEAC@@_5.16 #----------------------------- # @@INCLUDE@@ include/picolisp/ch05/dutree #----------------------------- # @@PLEAC@@_6.0 # PicoLisp has no strings, and doesn't operate on symbol names directly. # (see the "Strings" section). Instead, patterns are applied to lists. #----------------------------- (match Pattern List) (fill Pattern [Symbol|List]) #----------------------------- : (match '(@Name had a @Adj lamb) '(Mary had a little lamb)) -> T : @Name -> (Mary) : @Adj -> (little) #----------------------------- # @@PLEAC@@_6.1 #----------------------------- : (replace '(here in this town) 'this 'that 'town 'village) -> (here in that village) #----------------------------- # strip to basename : (let F (chop "abc/def/ghi") (prinl (last (split F '/))) # Using 'split' (prinl (stem F '/)) ) # or 'stem' ghi ghi #----------------------------- # Make All Words Title-Cased : (mapcar '((W) (pack (uppc (car W)) (cdr W))) (split (chop "Mary had a little lamb") " ") ) -> ("Mary" "Had" "A" "Little" "Lamb") #----------------------------- : (glue '/ (replace (split (chop "/usr/man/man3/foo.1") "/") '("m" "a" "n" "3") '("c" "a" "t" "3") ) ) -> "/usr/man/cat3/foo.1" #----------------------------- : (mapcar '((S) (pack (glue '/ (head -1 (split (chop S) '/))) "/lib")) '("/usr/bin" "/bin" "/usr/local/bin") ) -> ("/usr/lib" "/lib" "/usr/local/lib") #----------------------------- # @@PLEAC@@_6.2 #----------------------------- (not (find '((C) (nor (>= "Z" C "A") (>= "z" C "a"))) List ) ) # it is purely alphabetic #----------------------------- # @@PLEAC@@_6.3 #----------------------------- # as many non-whitespace bytes as possible : (make (find '((C) (or (sp? C) (nil (link C)))) (chop "abcd efg"))) -> ("a" "b" "c" "d") # as many letters, apostrophes, and hyphens : (make (find '((C) (nand (or (>= "Z" C "A") (>= "z" C "a") (sub? C "`-")) (link C) ) ) (chop "ab`c-d/e") ) ) -> ("a" "b" "`" "c" "-" "d") #----------------------------- # ... #----------------------------- # @@PLEAC@@_7.0 #----------------------------- (in "/usr/local/widgets/data" (until (eof) (and (sub? "blue" (line T)) (prinl @)) ) ) #----------------------------- (setq Var (in NIL (till NIL T))) # Read standard input till EOF #----------------------------- (out LogFile ...) (setq Fd (open LogFile)) ... (close Fd) #----------------------------- (out "+LogFile" # switch to LOGFILE for output (prinl "Countdown initiated ...") ) # return to original output (prinl "You have 30 seconds to reach minimum safety distance.") #----------------------------- # @@PLEAC@@_7.1 #----------------------------- (in "file" # Open for input .. ) (out "file" # Open for output .. ) (out "+file" # Open for output (appending) .. ) #----------------------------- # @@PLEAC@@_7.2 #----------------------------- # Just like any other file, right?