diff --git a/11-tidbit-3-tidbit-3-tidbit-3/.clang-format b/11-tidbit-3-tidbit-3-tidbit-3/.clang-format new file mode 100644 index 0000000..6db1dc6 --- /dev/null +++ b/11-tidbit-3-tidbit-3-tidbit-3/.clang-format @@ -0,0 +1,14 @@ +--- +AlignConsecutiveShortCaseStatements: + Enabled: true + AcrossEmptyLines: true + AcrossComments: true +IndentCaseLabels: true +AllowShortBlocksOnASingleLine: Always +AllowShortCaseLabelsOnASingleLine: true +AllowShortEnumsOnASingleLine: true +AllowShortIfStatementsOnASingleLine: AllIfsAndElse +AllowShortLoopsOnASingleLine: true +IndentWidth: 4 +PointerAlignment: Left +AlignAfterOpenBracket: BlockIndent diff --git a/11-tidbit-3-tidbit-3-tidbit-3/main.rkt b/11-tidbit-3-tidbit-3-tidbit-3/main.rkt index 644a2ac..678e84c 100644 --- a/11-tidbit-3-tidbit-3-tidbit-3/main.rkt +++ b/11-tidbit-3-tidbit-3-tidbit-3/main.rkt @@ -8,6 +8,7 @@ The grammar: | { * } | { / } | { with { } } + | { recur { } } | | { fun } | { call } @@ -20,31 +21,32 @@ The grammar: |# (define-type TIDBIT - [Num Number] - [Add TIDBIT TIDBIT] - [Sub TIDBIT TIDBIT] - [Mul TIDBIT TIDBIT] - [Div TIDBIT TIDBIT] - [Id Symbol] - [With Symbol TIDBIT TIDBIT] - [Fun (Listof Symbol) TIDBIT] - [Call TIDBIT (Listof TIDBIT)] - [Bind (Listof Symbol) (Listof TIDBIT) TIDBIT] - [Bind* (Listof Symbol) (Listof TIDBIT) TIDBIT] - [If0 TIDBIT TIDBIT TIDBIT]) + [Num Number] + [Add TIDBIT TIDBIT] + [Sub TIDBIT TIDBIT] + [Mul TIDBIT TIDBIT] + [Div TIDBIT TIDBIT] + [Id Symbol] + [With Symbol TIDBIT TIDBIT] + [Recur Symbol TIDBIT TIDBIT] + [Fun (Listof Symbol) TIDBIT] + [Call TIDBIT (Listof TIDBIT)] + [Bind (Listof Symbol) (Listof TIDBIT) TIDBIT] + [Bind* (Listof Symbol) (Listof TIDBIT) TIDBIT] + [If0 TIDBIT TIDBIT TIDBIT]) (define-type Idx = Integer) (define-type CORE - [CNum Number] - [CAdd CORE CORE] - [CSub CORE CORE] - [CMul CORE CORE] - [CDiv CORE CORE] - [CIdx Idx] - [CFun CORE] - [CCall CORE CORE] - [CIf0 CORE CORE CORE]) ; No way to implement equality check with only arithmetic and functions. + [CNum Number] + [CAdd CORE CORE] + [CSub CORE CORE] + [CMul CORE CORE] + [CDiv CORE CORE] + [CIdx Idx] + [CFun CORE] + [CCall CORE CORE] + [CIf0 CORE CORE CORE]) ; No way to implement equality check with only arithmetic and functions. (define-type BINDING-DEPTH = (Symbol -> Idx)) @@ -58,8 +60,8 @@ The grammar: (: currycall : CORE (Listof TIDBIT) BINDING-DEPTH -> CORE) (define (currycall body args bd) (match args - ['() body] - [(cons f r) (currycall (CCall body (preprocess f bd)) r bd)])) + ['() body] + [(cons f r) (currycall (CCall body (preprocess f bd)) r bd)])) (: curryfn : (Listof Symbol) TIDBIT BINDING-DEPTH -> CORE) (define (curryfn params body bd) @@ -78,23 +80,43 @@ The grammar: ['() body] [else (With (first names) (first vals) (binds* (rest names) (rest vals) body))])) +(: Z : -> TIDBIT) +; Z combinator! +(define (Z) + (Fun (list 'f) + (Call + (Fun (list 'x) + (Call (Id 'f) + (list (Fun (list 'v) + (Call (Call (Id 'x) (list (Id 'x))) (list (Id 'v))))))) + (list (Fun (list 'x) + (Call (Id 'f) + (list (Fun (list 'v) + (Call (Call (Id 'x) (list (Id 'x))) (list (Id 'v))))))))))) + (: preprocess : TIDBIT BINDING-DEPTH -> CORE) (define (preprocess tb bd) (cases tb - [(Num n) (CNum n)] - [(Add l r) (CAdd (preprocess l bd) (preprocess r bd))] - [(Sub l r) (CSub (preprocess l bd) (preprocess r bd))] - [(Mul l r) (CMul (preprocess l bd) (preprocess r bd))] - [(Div l r) (CDiv (preprocess l bd) (preprocess r bd))] - [(Id s) (CIdx (bd s))] - [(With name value body) (CCall (CFun (preprocess body (binding-encountered bd name))) - (preprocess value bd))] - [(Fun params body) (curryfn params body bd)] - [(Call body args) (currycall (preprocess body bd) args bd)] + [(Num n) (CNum n)] + [(Add l r) (CAdd (preprocess l bd) (preprocess r bd))] + [(Sub l r) (CSub (preprocess l bd) (preprocess r bd))] + [(Mul l r) (CMul (preprocess l bd) (preprocess r bd))] + [(Div l r) (CDiv (preprocess l bd) (preprocess r bd))] + [(Id s) (CIdx (bd s))] + [(With name value body) (CCall (CFun (preprocess body (binding-encountered bd name))) + (preprocess value bd))] + [(Recur name value body) + (preprocess + (With name + (Call (Z) (list (Fun (list name) value))) + body) + bd)] + [(Fun params body) (curryfn params body bd)] + [(Call body args) (currycall (preprocess body bd) args bd)] - [(Bind names vals body) (preprocess (binds names vals body) bd)] - [(Bind* names vals body) (preprocess (binds* names vals body) bd)] - [(If0 n body alt) (CIf0 (preprocess n bd) (preprocess body bd) (preprocess alt bd))])) + [(Bind names vals body) (preprocess (binds names vals body) bd)] + [(Bind* names vals body) (preprocess (binds* names vals body) bd)] + [(If0 n body alt) (CIf0 (preprocess n bd) (preprocess body bd) (preprocess alt bd))])) (: parse-bind : (Listof Sexpr) (Listof Sexpr) TIDBIT -> TIDBIT) (define (parse-bind names vals body) @@ -118,6 +140,11 @@ The grammar: [(list 'with (list (symbol: name) named) body) (With name (parse-sexpr named) (parse-sexpr body))] [else (error 'parse-sexpr "bad `with' syntax in ~s" sexpr)])] + [(cons 'recur more) + (match sexpr + [(list 'recur (list (symbol: name) named) body) + (Recur name (parse-sexpr named) (parse-sexpr body))] + [else (error 'parse-sexpr "bad `recur' syntax in ~s" sexpr)])] ; Function declaration. [(cons 'fun more) @@ -184,19 +211,19 @@ The grammar: ;; evaluates CORE expressions by reducing them to values (define (eval expr env) (cases expr - [(CNum n) (NumV n)] - [(CAdd l r) (arith-op + (eval l env) (eval r env))] - [(CSub l r) (arith-op - (eval l env) (eval r env))] - [(CMul l r) (arith-op * (eval l env) (eval r env))] - [(CDiv l r) (arith-op / (eval l env) (eval r env))] - [(CIdx n) (list-ref env (sub1 n))] - [(CFun body) (FunV body env)] - [(CCall fun-expr arg-expr) - (let ([fval (eval fun-expr env)]) - (cases fval - [(FunV body f-env) (eval body (cons (eval arg-expr env) f-env))] - [else (error 'eval "`call' expects a function, got: ~s" fval)]))] - [(CIf0 n body alt) (if (zero? (NumV->number (eval n env))) (eval body env) (eval alt env))])) + [(CNum n) (NumV n)] + [(CAdd l r) (arith-op + (eval l env) (eval r env))] + [(CSub l r) (arith-op - (eval l env) (eval r env))] + [(CMul l r) (arith-op * (eval l env) (eval r env))] + [(CDiv l r) (arith-op / (eval l env) (eval r env))] + [(CIdx n) (list-ref env (sub1 n))] + [(CFun body) (FunV body env)] + [(CCall fun-expr arg-expr) + (let ([fval (eval fun-expr env)]) + (cases fval + [(FunV body f-env) (eval body (cons (eval arg-expr env) f-env))] + [else (error 'eval "`call' expects a function, got: ~s" fval)]))] + [(CIf0 n body alt) (if (zero? (NumV->number (eval n env))) (eval body env) (eval alt env))])) (: run : String -> Number) ;; evaluate a TIDBIT program contained in a string @@ -207,6 +234,38 @@ The grammar: [else (error 'run "evaluation returned a non-number: ~s" result)]))) +; Factorial implemented with the Z combinator implemented in SKI-logic generated +; with C to be interpreted by TIDBIT which is built on CORE. +(test (run "{with {I {fun {x} x}} {with {K {fun {x} {fun {y} x}}} {with {S {fun +{f} {fun {g} {fun {x} {call {call f x} {call g x}}}}}} {with {Z {call {call S +{call {call S {call {call S {call K S}} {call {call S {call K K}} I}}} {call +{call S {call {call S {call K S}} {call {call S {call {call S {call K S}} {call +{call S {call K K}} {call K S}}}} {call {call S {call {call S {call K S}} {call +{call S {call {call S {call K S}} {call {call S {call K K}} {call K S}}}} {call +{call S {call {call S {call K S}} {call {call S {call K K}} {call K K}}}} {call +K I}}}}} {call {call S {call {call S {call K S}} {call {call S {call K K}} {call +K K}}}} {call K I}}}}}} {call {call S {call K K}} {call K I}}}}} {call {call S +{call {call S {call K S}} {call {call S {call K K}} I}}} {call {call S {call +{call S {call K S}} {call {call S {call {call S {call K S}} {call {call S {call +K K}} {call K S}}}} {call {call S {call {call S {call K S}} {call {call S {call +{call S {call K S}} {call {call S {call K K}} {call K S}}}} {call {call S {call +{call S {call K S}} {call {call S {call K K}} {call K K}}}} {call K I}}}}} {call +{call S {call {call S {call K S}} {call {call S {call K K}} {call K K}}}} {call +K I}}}}}} {call {call S {call K K}} {call K I}}}}}} {with {fact {call Z {fun {f} +{fun {n} {if0 n 1 {* n {call f {- n 1}}}}}}}} {call fact 5}}}}}} ") => 120) +; C program for generating SKI/TIDBIT code at the bottom of this file. + +(test (run + "{recur {Y {fun {n} {if0 n 1 {* n {call Y {- n 1}}}}}} {call Y 5}}") + + => 120) +(test (run + "{recur {fact {fun {Y} {if0 Y 1 {* Y {call fact {- Y 1}}}}}} {call fact 5}}") + + => 120) + +(test (run "{recur {fact {fun {n} {if0 n 1 {* n {call fact {- n 1}}}}}} {call fact 5}}") => 120) + (test (run "{if0 0 1 2}") => 1) (test (run "{if0 1 1 2}") => 2) @@ -236,7 +295,7 @@ The grammar: (test (run "{{fun {x} {+ x 1}} of 4}") => 5) (test (run "{with {add3 {fun {x} {+ x 3}}} - {add3 of 1}}") + {add3 of 1}}") => 4) (test (run "{with {x 1} {with {y 2} {+ x y}}}") => 3) (test (run "{call {call {fun {x} {fun {y} {+ x y}}} 1} 2}") => 3) @@ -250,28 +309,163 @@ The grammar: (test (run "{fun {x} x}") =error> "run: evaluation returned a non-number: (FunV (CIdx 1) ())") (test (run "{with {identity {fun {x} x}} - {with {foo {fun {x} {+ x 1}}} - {{identity of foo} of 123}}}") + {with {foo {fun {x} {+ x 1}}} + {{identity of foo} of 123}}}") => 124) (test (run "{with {add3 {fun {x} {+ x 3}}} - {with {add1 {fun {x} {+ x 1}}} - {with {x 3} - {add1 of {add3 of x}}}}}") + {with {add1 {fun {x} {+ x 1}}} + {with {x 3} + {add1 of {add3 of x}}}}}") => 7) (test (run "{with {x 3} - {with {f {fun {y} {+ x y}}} - {with {x 5} - {f of 4}}}}") + {with {f {fun {y} {+ x y}}} + {with {x 5} + {f of 4}}}}") => 7) (test (run "{call {with {x 3} - {fun {y} {+ x y}}} + {fun {y} {+ x y}}} 4}") => 7) (test (run "{with {f {with {x 3} {fun {y} {+ x y}}}} - {with {x 100} - {f of 4}}}") + {with {x 100} + {f of 4}}}") => 7) (test (run "{call {call {fun {x} {x of 1}} {fun {x} {fun {y} {+ x y}}}} 123}") => 124) + +#| + +#include +#include +#include + +// AST; variable, application, lambda. +typedef enum { VAR, APP, LAM } Tag; + +typedef struct Term { + Tag tag; + const char* name; // For VAR. + struct Term *f, *a; // For APP: function and argument. + const char* param; // For LAM: bound variable name. + struct Term* body; // For LAM: body expression. +} Term; + +static Term* var(const char* n) { + Term* t = malloc(sizeof *t); + t->tag = VAR; + t->name = n; + return t; +} + +static Term* app(Term* f, Term* a) { + Term* t = malloc(sizeof *t); + t->tag = APP; + t->f = f; + t->a = a; + return t; +} + +static Term* lam(const char* p, Term* b) { + Term* t = malloc(sizeof *t); + t->tag = LAM; + t->param = p; + t->body = b; + return t; +} + +static Term* elim(Term* t); + +// [v]t → SKI +static Term* bracket(const char* v, Term* t) { + if (t->tag == VAR) + return strcmp(v, t->name) == 0 + ? var("I") + : app(var("K"), t); // [v]v = I, [v]x = K x + if (t->tag == APP) + return app( + app(var("S"), bracket(v, t->f)), bracket(v, t->a) + ); // [v](p q) = S ([v]p) ([v]q) + fprintf(stderr, "tf did you just do\n"); + exit(1); +} + +// Eliminate the λs. +static Term* elim(Term* t) { + switch (t->tag) { + case VAR: return t; + case APP: return app(elim(t->f), elim(t->a)); + case LAM: return bracket(t->param, elim(t->body)); + } + return NULL; +} + +// Man I love how C provides such a rich standard library for strings. +typedef struct { + char* buf; + size_t len, cap; +} Str; + +static void sb_init(Str* s) { + s->buf = NULL; + s->len = s->cap = 0; +} + +static void sb_putc(Str* s, char c) { + if (s->len + 1 >= s->cap) { + s->cap = s->cap ? s->cap * 2 : 256; + s->buf = realloc(s->buf, s->cap); + } + s->buf[s->len++] = c; + s->buf[s->len] = 0; +} + +static void sb_puts(Str* s, const char* p) { + while (*p) sb_putc(s, *p++); +} + +static void spit_out(Str* s, Term* t) { + switch (t->tag) { + case VAR: sb_puts(s, t->name); return; + case APP: + sb_puts(s, "{call "); + spit_out(s, t->f); + sb_putc(s, ' '); + spit_out(s, t->a); + sb_putc(s, '}'); + return; + default: fprintf(stderr, "Tried to spit out a lambda D:\n"); exit(1); + } +} + +int main(void) { + // First we construct the z combinator in SKI... + Term* z = + lam("f", + app(lam("x", app(var("f"), + lam("v", app(app(var("x"), var("x")), var("v"))))), + lam("x", app(var("f"), lam("v", app(app(var("x"), var("x")), + var("v"))))))); + Term* z_ski = elim(z); + Str z_txt; + sb_init(&z_txt); + spit_out(&z_txt, z_ski); + + // Then print the factorial function using it. + printf( + "{with {I {fun {x} x}} " + "{with {K {fun {x} {fun {y} x}}} " + "{with {S {fun {f} {fun {g} {fun {x} {call {call f x} {call g x}}}}}} " + "{with {Z %s} " // <<<< Z combinator goes here. + "{with {fact {call Z {fun {f} {fun {n} {if0 n 1 {* n {call f {- n " + "1}}}}}}}} " + "{call fact 5}}}}}}\n", + z_txt.buf + ); + + free(z_txt.buf); + return 0; +} + +|# diff --git a/11-tidbit-3-tidbit-3-tidbit-3/ski.c b/11-tidbit-3-tidbit-3-tidbit-3/ski.c new file mode 100644 index 0000000..cb648a2 --- /dev/null +++ b/11-tidbit-3-tidbit-3-tidbit-3/ski.c @@ -0,0 +1,130 @@ +#include +#include +#include + +// AST; variable, application, lambda. +typedef enum { VAR, APP, LAM } Tag; + +typedef struct Term { + Tag tag; + const char* name; // For VAR. + struct Term *f, *a; // For APP: function and argument. + const char* param; // For LAM: bound variable name. + struct Term* body; // For LAM: body expression. +} Term; + +static Term* var(const char* n) { + Term* t = malloc(sizeof *t); + t->tag = VAR; + t->name = n; + return t; +} + +static Term* app(Term* f, Term* a) { + Term* t = malloc(sizeof *t); + t->tag = APP; + t->f = f; + t->a = a; + return t; +} + +static Term* lam(const char* p, Term* b) { + Term* t = malloc(sizeof *t); + t->tag = LAM; + t->param = p; + t->body = b; + return t; +} + +static Term* elim(Term* t); + +// [v]t → SKI +static Term* bracket(const char* v, Term* t) { + if (t->tag == VAR) + return strcmp(v, t->name) == 0 + ? var("I") + : app(var("K"), t); // [v]v = I, [v]x = K x + if (t->tag == APP) + return app( + app(var("S"), bracket(v, t->f)), bracket(v, t->a) + ); // [v](p q) = S ([v]p) ([v]q) + fprintf(stderr, "tf did you just do\n"); + exit(1); +} + +// Eliminate the λs. +static Term* elim(Term* t) { + switch (t->tag) { + case VAR: return t; + case APP: return app(elim(t->f), elim(t->a)); + case LAM: return bracket(t->param, elim(t->body)); + } + return NULL; +} + +// Man I love how C provides such a rich standard library for strings. +typedef struct { + char* buf; + size_t len, cap; +} Str; + +static void sb_init(Str* s) { + s->buf = NULL; + s->len = s->cap = 0; +} + +static void sb_putc(Str* s, char c) { + if (s->len + 1 >= s->cap) { + s->cap = s->cap ? s->cap * 2 : 256; + s->buf = realloc(s->buf, s->cap); + } + s->buf[s->len++] = c; + s->buf[s->len] = 0; +} + +static void sb_puts(Str* s, const char* p) { + while (*p) sb_putc(s, *p++); +} + +static void spit_out(Str* s, Term* t) { + switch (t->tag) { + case VAR: sb_puts(s, t->name); return; + case APP: + sb_puts(s, "{call "); + spit_out(s, t->f); + sb_putc(s, ' '); + spit_out(s, t->a); + sb_putc(s, '}'); + return; + default: fprintf(stderr, "Tried to spit out a lambda D:\n"); exit(1); + } +} + +int main(void) { + // First we construct the z combinator in SKI... + Term* z = + lam("f", + app(lam("x", app(var("f"), + lam("v", app(app(var("x"), var("x")), var("v"))))), + lam("x", app(var("f"), lam("v", app(app(var("x"), var("x")), + var("v"))))))); + Term* z_ski = elim(z); + Str z_txt; + sb_init(&z_txt); + spit_out(&z_txt, z_ski); + + // Then print the factorial function using it. + printf( + "{with {I {fun {x} x}} " + "{with {K {fun {x} {fun {y} x}}} " + "{with {S {fun {f} {fun {g} {fun {x} {call {call f x} {call g x}}}}}} " + "{with {Z %s} " // <<<< Z combinator goes here. + "{with {fact {call Z {fun {f} {fun {n} {if0 n 1 {* n {call f {- n " + "1}}}}}}}} " + "{call fact 5}}}}}}\n", + z_txt.buf + ); + + free(z_txt.buf); + return 0; +}