miloignis/kraken
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Picolisp two examples

Browse Source
This commit is contained in:
Sharjeel Khan
2022-11-11 00:19:32 -05:00
parent a7248daca0
commit 70f151222e
2 changed files with 296 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

136
koka_bench/picolisp/picolisp-cfold.l Normal file
View File

@@ -0,0 +1,136 @@
#!/usr/bin/env bash
#{
# Thanks to http://rosettacode.org/wiki/Multiline_shebang#PicoLisp
exec pil $0 $1
# }#
(de cadddddr (l) (car (cddr (cdddr l))))
(de caddddr (l) (car (cdr (cdddr l))))
(de mkexpr (n v) (cond ((= 0 n) (cond ((= 0 v) (list "var" 1 0))
(T (list "val" v 0))
))
(T (list "add" (mkexpr (- n 1) (+ v 1)) (mkexpr (- n 1) (max (- v 1) 0))))
)
)
(de appendadd (expf exps) (let (S (car expf)
l (cadr expf)
r (caddr expf)
)
( case S
("add" (list "add" l (appendadd r exps)))
(T (list "add" expf exps))
)
)
)
(de appendmul (expf exps) (let (S (car expf)
l (cadr expf)
r (caddr expf)
)
( case S
("mul" (list "mul" l (appendmul r exps)))
(T (list "mul" expf exps))
)
)
)
(de reassoc (exp) (let (S (car exp)
l (cadr exp)
r (caddr exp)
)
( case S
("add" (appendadd (reassoc l) (reassoc r)))
("mul" (appendmul (reassoc l) (reassoc r)))
(T exp)
)
)
)
(de cfold (exp) (let (S (car exp)
l (cadr exp)
r (caddr exp)
)
(case S
("add" (let (lc (cfold l)
rc (cfold r)
lcS (car lc)
lcl (cadr lc)
lcr (caddr lc)
rcS (car rc)
rcl (cadr rc)
rcr (caddr rc)
)
(cond ((= lcS "val") (cond ((= rcS "val) (list "val" (+ lcl rcl) 0))
((= rcS "add") (let (rclS (car rcl)
rcll (cadr rcl)
rclr (caddr rcl)
rcrS (car rcr)
rcrl (cadr rcr)
rcrr (caddr rcr)
)
(cond ((= rcrS "val") (list "add" (list "val" (+ lcl rcrl) 0) rcl))
((= rclS "val") (list "add" (list "val" (+ lcl rcll) 0) rcr))
(T (list "add" lc rc))
)
)
(T (list "mul" lc rc))
)
)
)
(T (list "add" lc rc))
)
)
)
("mul" (let (lc (cfold l)
rc (cfold r)
lcS (car lc)
lcl (cadr lc)
lcr (caddr lc)
rcS (car rc)
rcl (cadr rc)
rcr (caddr rc)
)
(cond ((= lcS "val") (cond ((= rcS "val) (list "val" (* lcl rcl) 0))
((= rcS "mul") (let (rclS (car rcl)
rcll (cadr rcl)
rclr (caddr rcl)
rcrS (car rcr)
rcrl (cadr rcr)
rcrr (caddr rcr)
)
(cond ((= rcrS "val") (list "mul" (list "val" (* lcl rcrl) 0) rcl))
((= rclS "val") (list "mul" (list "val" (* lcl rcll) 0) rcr))
(T (list "mul" lc rc))
)
)
)
(T (list "mul" lc rc))
)
)
(T (list "mul" lc rc))
)
)
)
(T exp)
)
)
)
(de evalE (exp) (let ( S (car exp)
l (cadr exp)
r (caddr exp)
)
(case S
("add" (+ (evalE l) (evalE r) ))
("mul" (* (evalE l) (evalE r) ))
("var" 0)
("val" l)
)
)
)
(bye (println (evalE (cfold (reassoc (mkexpr (car (str (opt))) 1))))))

160
koka_bench/picolisp/picolisp-rbtree.l Normal file
View File

@@ -0,0 +1,160 @@
#!/usr/bin/env bash
#{
# Thanks to http://rosettacode.org/wiki/Multiline_shebang#PicoLisp
exec pil $0 $1
# }#
(de cadddddr (l) (car (cddr (cdddr l))))
(de caddddr (l) (car (cdr (cdddr l))))
(de isRed (t) (let ( nA (car t)
nB (cadr t)
nC (caddr t)
nD (cadddr t)
nE (caddddr t)
nF (cadddddr t)
)
(
case nB
("R" T)
(T NIL)
)
)
)
(de balanceLeft (l k v r) (let ( nA (car l)
nB (cadr l)
nC (caddr l)
nD (cadddr l)
nE (caddddr l)
nF (cadddddr l)
nLA (car nC)
nLB (cadr nC)
nLC (caddr nC)
nLD (cadddr nC)
nLE (caddddr nC)
nLF (cadddddr nC)
nRA (car nF)
nRB (cadr nF)
nRC (caddr nF)
nRD (cadddr nF)
nRE (caddddr nF)
nRF (cadddddr nF)
)
(
case nA
("N" (case (nLB)
("R" (list "N" "R" (list "N" "B" nLC nLD nLE nLF) nD nE (list "N" "B" nF k v r)))
(T (case (nRB)
("R" (list "N" "R" (list "N" "B" nC nD nE nRC) nRD nRE (list "N" "B" nRF k v r)))
(T (list "N" "B" (list "N" "R" nC nD nE nF) k v r))
))
))
(T (list "L" "C" 0 0 0 0))
)
)
)
(de balanceRight (l k v r) (let ( nA (car r)
nB (cadr r)
nC (caddr r)
nD (cadddr r)
nE (caddddr r)
nF (cadddddr r)
nLA (car nC)
nLB (cadr nC)
nLC (caddr nC)
nLD (cadddr nC)
nLE (caddddr nC)
nLF (cadddddr nC)
nRA (car nF)
nRB (cadr nF)
nRC (caddr nF)
nRD (cadddr nF)
nRE (caddddr nF)
nRF (cadddddr nF)
)
(
case nA
("N" (case nLB
("R" (list "N" "R" (list "N" "B" l k v nLC) nLD nLE (list "N" "B" nLF nD nE nF)))
(T (case nRB
("R" (list "N" "R" (list "N" "B" l k v nC) nD nE (list "N" "B" nRC nRD nRE nRF)))
(T (list "N" "B" l k v (list "N" "R" nC nD nE nF)))
))
))
(T (list "L" "C" 0 0 0 0))
)
)
)
(de ins (t k v) (let ( nA (car t)
nB (cadr t)
nC (caddr t)
nD (cadddr t)
nE (caddddr t)
nF (cadddddr t)
)
(
case nB
("R" (cond ((< k nD) (list "N" "R" (ins nC k v) nD nE nF))
((> k nD) (list "N" "R" nC nD nE (ins nF k v)))
(T (list "N" "R" nC nD nE nF))
))
("B" (cond ((< k nD) (if (isRed nC) (balanceLeft (ins nC k v) nD nE nF) (list "N" "B" (ins nC k v) nD nE nF)))
((> k nD) (if (isRed nF) (balanceRight nC nD nE (ins nF k v)) (list "N" "B" nC nD nE (ins nF k v))))
(T (list "N" "B" nC nD nE nF))
))
(T (list "N" "R" (list "L" "C" 0 0 0 0) nD nE (list "L" "C" 0 0 0 0)))
)
)
)
(de setBlack (t) (let (nA (car t)
nB (cadr t)
nC (caddr t)
nD (cadddr t)
nE (caddddr t)
nF (cadddddr t)
)
(
case nA
("N" (list nA "B" nC nD nE nF))
(T t)
)
)
)
(de insertT (t k v) (setBlack (ins t k v)))
(de foldT (t b) (let (nA (car t)
nB (cadr t)
nC (caddr t)
nD (cadddr t)
nE (caddddr t)
nF (cadddddr t)
)
(
case nA
("N" (foldT nF (+ (foldT nC b) 1)))
(T b)
)
)
)
(de makeTreeAux (n t) (cond ((<= n 0) t)
(T (let (nA (- n 1)
) (makeTreeAux nA (insertT t nA nA))
)
)
)
)
(de makeTree (n) (makeTreeAux n (list "L" "C" 0 0 0 0)))
(bye (println ( foldT (makeTree (car (str (opt)))) 0)))