Finished TidBit 3.

Added some things extra.

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

11-tidbit-3-tidbit-3-tidbit-3/main.rkt

@@ -8,6 +8,7 @@ The grammar:
             | { * <TIDBIT> <TIDBIT> }
             | { / <TIDBIT> <TIDBIT> }
             | { with { <id> <TIDBIT> } <TIDBIT> }
+            | { recur { <id> <TIDBIT> } <TIDBIT> }
             | <id>
             | { fun <id> <TIDBIT> }
             | { call <TIDBIT> <TIDBIT> }
@@ -20,31 +21,32 @@ The grammar:
 |#
 
 (define-type TIDBIT
-             [Num Number]
+  [Num Number]
-             [Add TIDBIT TIDBIT]
+  [Add TIDBIT TIDBIT]
-             [Sub TIDBIT TIDBIT]
+  [Sub TIDBIT TIDBIT]
-             [Mul TIDBIT TIDBIT]
+  [Mul TIDBIT TIDBIT]
-             [Div TIDBIT TIDBIT]
+  [Div TIDBIT TIDBIT]
-             [Id Symbol]
+  [Id Symbol]
-             [With Symbol TIDBIT TIDBIT]
+  [With Symbol TIDBIT TIDBIT]
-             [Fun (Listof Symbol) TIDBIT]
+  [Recur Symbol TIDBIT TIDBIT]
-             [Call TIDBIT (Listof TIDBIT)]
+  [Fun (Listof Symbol) TIDBIT]
-             [Bind (Listof Symbol) (Listof TIDBIT) TIDBIT]
+  [Call TIDBIT (Listof TIDBIT)]
-             [Bind* (Listof Symbol) (Listof TIDBIT) TIDBIT]
+  [Bind (Listof Symbol) (Listof TIDBIT) TIDBIT]
-             [If0 TIDBIT TIDBIT TIDBIT])
+  [Bind* (Listof Symbol) (Listof TIDBIT) TIDBIT]
+  [If0 TIDBIT TIDBIT TIDBIT])
 
 (define-type Idx = Integer)
 
 (define-type CORE
-             [CNum Number]
+  [CNum Number]
-             [CAdd CORE CORE]
+  [CAdd CORE CORE]
-             [CSub CORE CORE]
+  [CSub CORE CORE]
-             [CMul CORE CORE]
+  [CMul CORE CORE]
-             [CDiv CORE CORE]
+  [CDiv CORE CORE]
-             [CIdx Idx]
+  [CIdx Idx]
-             [CFun CORE]
+  [CFun CORE]
-             [CCall CORE CORE]
+  [CCall CORE CORE]
-             [CIf0 CORE CORE CORE]) ; No way to implement equality check with only arithmetic and functions.
+  [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]
+    ['() body]
-      [(cons f r) (currycall (CCall body (preprocess f bd)) r bd)]))
+    [(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)]
+    [(Num n) (CNum n)]
-         [(Add l r) (CAdd (preprocess l bd) (preprocess r bd))]
+    [(Add l r) (CAdd (preprocess l bd) (preprocess r bd))]
-         [(Sub l r) (CSub (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))]
+    [(Mul l r) (CMul (preprocess l bd) (preprocess r bd))]
-         [(Div l r) (CDiv (preprocess l bd) (preprocess r bd))]
+    [(Div l r) (CDiv (preprocess l bd) (preprocess r bd))]
-         [(Id s) (CIdx (bd s))]
+    [(Id s) (CIdx (bd s))]
-         [(With name value body) (CCall (CFun (preprocess body (binding-encountered bd name)))
+    [(With name value body) (CCall (CFun (preprocess body (binding-encountered bd name)))
-                                        (preprocess value bd))]
+                                   (preprocess value bd))]
-         [(Fun params body) (curryfn params body bd)]
+    [(Recur name value body)
-         [(Call body args) (currycall (preprocess body bd) args bd)]
+     (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)]
-         [(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))]))
+    [(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)]
+    [(CNum n) (NumV n)]
-         [(CAdd l r) (arith-op + (eval l env) (eval r env))]
+    [(CAdd l r) (arith-op + (eval l env) (eval r env))]
-         [(CSub 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))]
+    [(CMul l r) (arith-op * (eval l env) (eval r env))]
-         [(CDiv 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))]
+    [(CIdx n) (list-ref env (sub1 n))]
-         [(CFun body) (FunV body env)]
+    [(CFun body) (FunV body env)]
-         [(CCall fun-expr arg-expr)
+    [(CCall fun-expr arg-expr)
-          (let ([fval (eval fun-expr env)])
+     (let ([fval (eval fun-expr env)])
-            (cases fval
+       (cases fval
-                   [(FunV body f-env) (eval body (cons (eval arg-expr env) f-env))]
+         [(FunV body f-env) (eval body (cons (eval arg-expr env) f-env))]
-                   [else (error 'eval "`call' expects a function, got: ~s" fval)]))]
+         [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))]))
+    [(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}}}
+                  {with {foo {fun {x} {+ x 1}}}
-                {{identity of foo} of 123}}}")
+                        {{identity of foo} of 123}}}")
       => 124)
 (test (run "{with {add3 {fun {x} {+ x 3}}}
-              {with {add1 {fun {x} {+ x 1}}}
+                  {with {add1 {fun {x} {+ x 1}}}
-                {with {x 3}
+                        {with {x 3}
-                  {add1 of {add3 of x}}}}}")
+                              {add1 of {add3 of x}}}}}")
       => 7)
 (test (run "{with {x 3}
-              {with {f {fun {y} {+ x y}}}
+                  {with {f {fun {y} {+ x y}}}
-                {with {x 5}
+                        {with {x 5}
-                  {f of 4}}}}")
+                              {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}
+                  {with {x 100}
-                {f of 4}}}")
+                        {f of 4}}}")
       => 7)
 (test (run "{call {call {fun {x} {x of 1}}
                         {fun {x} {fun {y} {+ x y}}}}
                   123}")
       => 124)
+
+#|
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+// 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;
+}
+
+|#

11-tidbit-3-tidbit-3-tidbit-3/ski.c

@@ -0,0 +1,130 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+// 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;
+}