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

Now actually have standard_grammar and with_import in scope let and all other ways in, having implemented let-vrec for mutually recursive vaus and fixing bugs. Tiny placeholder new_kraken definition and test.

Browse Source
This commit is contained in:
Nathan Braswell
2020-12-20 02:10:10 -05:00
parent 03b588f1f9
commit 5152e1d109
4 changed files with 224 additions and 193 deletions
Download Patch File Download Diff File Expand all files Collapse all files

195
new_kraken.kp
View File

@@ -1,194 +1,5 @@
((wrap (vau root_env (quote)
((wrap (vau _ (let1)
(let1 lambda (vau se (p b) (wrap (eval (array vau (quote _) p b) se)))
(let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil
(= i (- (len s) 1)) (eval (idx s i) se)
(eval (idx s i) se) (recurse recurse s (+ i 1) se)
true (recurse recurse s (+ i 1) se)))
(let1 do (vau se (& s) (do_helper do_helper s 0 se))
(let1 cons (lambda (h t) (let1 a (array-with-len (+ 1 (len t)))
(let1 helper (lambda (recurse d s i) (cond (< i (len s)) (do (set-idx! d (+ i 1) (idx s i))
(recurse recurse d s (+ i 1)))
true d))
(do (set-idx! a 0 h)
(helper helper a t 0)))))
(let1 current-env (vau de () de)
(let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env)))
(let1 vapply (lambda (f p ede) (eval (cons f p) ede))
(let1 Y (lambda (f)
((lambda (x) (x x))
(lambda (x) (f (lambda (& y) (lapply (x x) y))))))
(let1 vY (lambda (f)
((lambda (x) (x x))
(lambda (x) (f (vau de (& y) (vapply (x x) y de))))))
(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de)
true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de)))))
(let (
print_through (lambda (x) (do (println x) x))
rec-lambda (vau se (p b) (eval (array Y (array lambda (quote (recurse)) (array lambda p b))) se))
if (vau de (con than & else) (cond (eval con de) (eval than de)
(> (len else) 0) (eval (idx else 0) de)
true nil))
map (lambda (f l)
(let (helper (rec-lambda (f l n i)
(if (= i (len l))
n
(do (set-idx! n i (f (idx l i)))
(recurse f l n (+ i 1))))))
(helper f l (array-with-len (len l)) 0)))
map_i (lambda (f l)
(let (helper (rec-lambda (f l n i)
(if (= i (len l))
n
(do (set-idx! n i (f i (idx l i)))
(recurse f l n (+ i 1))))))
(helper f l (array-with-len (len l)) 0)))
concat_helper (lambda (recurse as o i j k) (if (< i (len as))
(if (< j (len (idx as i))) (do (set-idx! o k (idx (idx as i) j))
(recurse recurse as o i (+ j 1) (+ k 1)))
(recurse recurse as o (+ i 1) 0 k))
o))
concat (lambda (& as) (concat_helper concat_helper as (array-with-len (lapply + (map len as))) 0 0 0))
filter_i (lambda (f l)
(let (helper (rec-lambda (f l n i)
(if (= i (len l))
n
(if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1))
(recurse f l n (+ i 1))))))
(helper f l (array) 0)))
; Huge thanks to Oleg Kiselyov for his fantastic website
; http://okmij.org/ftp/Computation/fixed-point-combinators.html
Y* (lambda (& l)
((lambda (u) (u u))
(lambda (p)
(map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l))))
let-rec (vau de (name_func body)
(let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func)
funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func)
overwrite_name (idx name_func (- (len name_func) 2)))
(eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs)))
(lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names)))
body))))
flat_map (lambda (f l)
(let (helper (rec-lambda (f l n i)
(if (= i (len l))
n
(recurse f l (concat n (f (idx l i))) (+ i 1)))))
(helper f l (array) 0)))
map_with_idx (lambda (f l)
(let (helper (rec-lambda (f l n i)
(if (= i (len l))
n
(do (set-idx! n i (f i (idx l i)))
(recurse f l n (+ i 1))))))
(helper f l (array-with-len (len l)) 0)))
is_pair? (lambda (x) (and (array? x) (> (len x) 0)))
quasiquote (vY (lambda (recurse) (vau de (x)
(cond (is_pair? x)
(cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote"))
(eval (idx x 1) de)
true
(cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote"))
(concat (eval (idx (idx x 0) 1) de) (vapply recurse (array (slice x 1 -1)) de))
true
(concat (array (vapply recurse (array (idx x 0)) de)) (vapply recurse (array (slice x 1 -1)) de))))
true x))))
provide (vau de (& items) (array let
(flat_map (lambda (item) (array item (array quote (eval item de)))) items)))
scope_let_sans_import (provide
root_env
lambda
rec-lambda
let
let-rec
do
if
concat
map
flat_map
map_with_idx
lapply
vapply
Y
vY
Y*
quote
quasiquote
provide
print_through
)
insert_into_scope_let (lambda (scope_let name item) (array (idx scope_let 0) (concat (idx scope_let 1) (array name (array quote item)))))
; Gotta insert with_import into scope_let via vY combinator so it can use itself
with_import (vY (lambda (recurse) (vau de (lib_path code)
(let (imported_scope_let (eval (concat (insert_into_scope_let scope_let_sans_import (quote with_import) recurse)
(array (read-string (slurp (eval lib_path de))))) root_env))
(eval (concat imported_scope_let (array code)) de)))))
scope_let (insert_into_scope_let scope_let_sans_import (quote with_import) with_import)
gen_standard_grammar (rec-lambda () (array
(array (quote WS) (array "( | |
|(;[ -~]*
))+") (lambda (x) nil))
(array (quote atom) (array "-?[0-9]+") (lambda (x) (read-string x)))
(array (quote atom) (array "\"([#-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\\\*)|(\\0)|
|[ -!]|(\\\\\"))*\"") (lambda (x) (read-string x)))
(array (quote atom) (array "-|(([a-z]|[A-Z]|_|\\*|/|\\?|\\+|!|=|&|<|>|%)([a-z]|[A-Z]|_|[0-9]|\\*|\\?|\\+|-|!|=|&|<|>|%)*)") (lambda (x) (cond (= "true" x) true
(= "false" x) false
(= "nil" x) nil
true (read-string x))))
(array (quote form) (array (quote atom)) (lambda (x) x))
(array (quote form) (array "\\(" (quote WS) * "\\)" ) (lambda (_ _ _) (array)))
(array (quote form) (array "\\(" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\)" ) (lambda (_ _ head tail _ _) (concat (array head) (map (lambda (x) (idx x 1)) tail))))
(array (quote form) (array "\\[" (quote WS) * "\\]" ) (lambda (_ _ _) (array array)))
(array (quote form) (array "\\[" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\]" ) (lambda (_ _ head tail _ _) (concat (array array head) (map (lambda (x) (idx x 1)) tail))))
(array (quote form) (array "'" (quote WS) * (quote form)) (lambda (_ _ x) (array quote x)))
(array (quote form) (array "`" (quote WS) * (quote form)) (lambda (_ _ x) (array quasiquote x)))
(array (quote form) (array "~" (quote WS) * (quote form)) (lambda (_ _ x) (array (quote unquote) x)))
(array (quote form) (array "," (quote WS) * (quote form)) (lambda (_ _ x) (array (quote splice-unquote) x)))
(array (quote start_symbol) (array (quote WS) * (quote form) (quote WS) *) (lambda (_ f _) f))
(array (quote start_symbol) (array (quote WS) * "#lang" (quote WS) * (quote form) "[ -~]*")
(lambda (_ _ _ gram source) (read-string source
(eval (concat (insert_into_scope_let scope_let (quote standard_grammar) (recurse)) (array gram)) root_env)
(quote start_symbol))))
))
standard_grammar (gen_standard_grammar)
scope_let (insert_into_scope_let scope_let (quote standard_grammar) standard_grammar)
rep (vY (lambda (recurse) (wrap (vau de () (do (println (eval (read-string (get_line "> ") standard_grammar (quote start_symbol)) de))
(eval (array recurse) de))))))
)
(do
(println "Welcome to Kraken! Parameters were" *ARGV*)
(cond (and (>= (len *ARGV*) 3) (= "-C" (idx *ARGV* 1))) (eval (concat scope_let (array (read-string (idx *ARGV* 2) standard_grammar (quote start_symbol)))) root_env)
(> (len *ARGV*) 1) (eval (concat scope_let (array (read-string (slurp (idx *ARGV* 1)) standard_grammar (quote start_symbol)))) root_env)
true (eval (concat scope_let (array (array rep))) root_env)
)
)
new_kraken_untyped standard_grammar
)
(provide new_kraken_untyped)
)
)))))))))) ; end of all the let1's
; impl of let1
)) (vau de (s v b) (eval (array (array vau (quote _) (array s) b) (eval v de)) de)))
; impl of quote
)) (vau _ (x) x))