diff --git a/koka_bench/picolisp/picolisp-cfold.l b/koka_bench/picolisp/picolisp-cfold.l new file mode 100644 index 0000000..a673e79 --- /dev/null +++ b/koka_bench/picolisp/picolisp-cfold.l @@ -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)))))) diff --git a/koka_bench/picolisp/picolisp-rbtree.l b/koka_bench/picolisp/picolisp-rbtree.l new file mode 100644 index 0000000..f5a4d9e --- /dev/null +++ b/koka_bench/picolisp/picolisp-rbtree.l @@ -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))) \ No newline at end of file