From 5152e1d109f42afed6d790e6caa764bc1f4ff425 Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Sun, 20 Dec 2020 02:10:10 -0500 Subject: [PATCH] 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. --- k_prime.krak | 2 +- new_kraken.kp | 195 +--------------------------------------- new_kraken_test.kp | 3 + prelude.kp | 217 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 224 insertions(+), 193 deletions(-) create mode 100644 new_kraken_test.kp create mode 100644 prelude.kp diff --git a/k_prime.krak b/k_prime.krak index 286207d..80ab4e2 100644 --- a/k_prime.krak +++ b/k_prime.krak @@ -1307,6 +1307,6 @@ fun main(argc: int, argv: **char): int { params.add(kpString(str(argv[i]))) } env->set(str("*ARGV*"), kpArray(params)) - println(rep(grammar, env, str("(eval (read-string (slurp \"./new_kraken.kp\")))"))) + println(rep(grammar, env, str("(eval (read-string (slurp \"./prelude.kp\")))"))) return 0 } diff --git a/new_kraken.kp b/new_kraken.kp index d9bf627..3bb390b 100644 --- a/new_kraken.kp +++ b/new_kraken.kp @@ -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)) - diff --git a/new_kraken_test.kp b/new_kraken_test.kp new file mode 100644 index 0000000..80f7ced --- /dev/null +++ b/new_kraken_test.kp @@ -0,0 +1,3 @@ +#lang (with_import "./new_kraken.kp" new_kraken_untyped) + +(println "THIS IS ININ the real real finally") diff --git a/prelude.kp b/prelude.kp new file mode 100644 index 0000000..61ee084 --- /dev/null +++ b/prelude.kp @@ -0,0 +1,217 @@ + +((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)))) + vY* (lambda (& l) + ((lambda (u) (u u)) + (lambda (p) + (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) 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) de))) + let-vrec (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 vY*) (map (lambda (f) (array lambda names f)) funcs))) + (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) + body) de))) + + 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_gram ( + provide + root_env + lambda + rec-lambda + let + let-rec + let-vrec + 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))))) + scope_let (let-vrec ( + with_import (vau de (lib_path code) + (let (imported_scope_let (eval (concat + (insert_into_scope_let + (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) + (quote with_import) with_import) + (array (read-string (slurp (eval lib_path de))))) root_env)) + (eval (concat imported_scope_let (array code)) de))) + gen_standard_grammar (vau de () (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) (do (println "gonna do that # yo") (read-string source + (eval (concat + (insert_into_scope_let + (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) + (quote with_import) with_import) + (array gram)) root_env) + (quote start_symbol))))) + )) + ) + (insert_into_scope_let + (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) + (quote with_import) with_import) + ) + standard_grammar (eval (concat scope_let (array (quote standard_grammar))) root_env) + + 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) + ) + ) +) +)))))))))) ; 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)) +