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

New Newlisps cfold

Browse Source
This commit is contained in:
Sharjeel Khan
2022-11-11 03:53:13 -05:00
parent 85f46f0e8d
commit 4eb42d48f9
6 changed files with 439 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
koka_bench/newlisp/newlisp-slow-fexpr-cfold.nl Normal file
View File

@@ -0,0 +1,86 @@
#!/usr/bin/env newlisp
(define cont list)
(define cont? list?)
;(define cont (lambda (l) (array (length l) l)))
;(define cont? array?)
(define (evaluate_case access c) (cond
((and (list? c) (= 2 (length c)) (= 'unquote (c 0))) (list (list = access (c 1)) (lambda (b) b)))
((symbol? c) (list true (expand (lambda (b) (list let (list 'c 'access) b)) 'c 'access)))
((list? c) (letn (
tests (list and (list list? access) (list = (length c) (list length access)))
tests__body_func (local (recurse) (setq recurse (lambda (tests body_func i) (if (= i (length c))
(list tests body_func)
(letn ( inner_test__inner_body_func (evaluate_case (list access i) (c i))
inner_test (inner_test__inner_body_func 0)
inner_body_func (inner_test__inner_body_func 1)
)
(recurse (append tests (list inner_test))
(expand (lambda (b) (body_func (inner_body_func b))) 'body_func 'inner_body_func)
(+ i 1))))))
(recurse tests (lambda (b) b) 0))
) tests__body_func))
(true (list (list = access c) (lambda (b) b)))
))
(define (my-match-helper x_sym cases i) (cond ((< i (- (length cases) 1)) (let (test__body_func (evaluate_case x_sym (cases i)))
(append (list (list (test__body_func 0) ((test__body_func 1) (cases (+ i 1))))) (my-match-helper x_sym cases (+ i 2)))))
(true '((true ("none matched"))))))
(define-macro (my-match x) (eval (list let (list '__MATCH_SYM x) (cons cond (my-match-helper '__MATCH_SYM (args) 0)))))
(define (mk-expr n v) (cond ((= n 0) (cond ((= v 0) (list 'VR 1 0))
(true (list 'VL v 0))))
(true (list 'A (mk-expr (- n 1) (+ v 1)) (mk-expr (- n 1) (max (- v 1) 0))))))
(define (append-add a b) (my-match a
('A c d) (list 'A c (append-add d b))
a (list 'A a b)))
(define (append-mul a b) (my-match a
('M c d) (list 'M c (append-mul d b))
a (list 'M a b)))
(define (reassoc e) (my-match e
('A a b) (append-add (reassoc a) (reassoc b))
('M c d) (append-mul (reassoc a) (reassoc b))
e e))
(define (cfold e) (my-match e
('A a b) (letn (ap (cfold a)
bp (cfold b))
(my-match ap
('VL s t) (my-match bp
('VL m n) (list 'VL (+ s m) 0)
('A m ('VL n p)) (list 'A (list 'VL (+ s n) 0) m)
('A ('VL m n) p) (list 'A (list 'VL (+ s m) 0) p)
ep (list 'A ap bp)
)
ep (list 'A ap bp)
)
)
('M c d) (letn (cp (cfold c)
dp (cfold dec))
(my-match cp
('VL s t) (my-match dp
('VL m n) (list 'VL (* s m) 0)
('M m ('VL n p)) (list 'M (list 'VL (* s n) 0) m)
('M ('VL m n) p) (list 'M (list 'VL (* s m) 0) p)
ep (list 'M cp dp)
)
ep (list 'M ap bp)
)
)
e e))
(define (eval e) (my-match e
('VR a b) 0
('VL c d) c
('A e f) (+ (eval e) (eval f))
('M l r) (* (eval l) (eval r))))
(println (eval (cfold (reassoc (mk-expr (integer (main-args 2)) 1)))))
(exit)