From e8e3383947ec7d4bd7e81417c5f9aabf06c76615 Mon Sep 17 00:00:00 2001 From: Edward Amsden Date: Thu, 21 Oct 2021 18:05:52 -0400 Subject: [PATCH] initial commit --- first-pass/nock-a.rkt | 64 ++++++ first-pass/nock-b-cps.rkt | 64 ++++++ first-pass/nock-c-lambda-lift.rkt | 139 +++++++++++++ first-pass/nock-d-first-order-ks.rkt | 146 ++++++++++++++ first-pass/nock-e-registerise.rkt | 233 ++++++++++++++++++++++ nock-a.rkt | 102 ++++++++++ nock-b-scry.rkt | 115 +++++++++++ nock-c-exceptions.rkt | 151 ++++++++++++++ nock-d-cps.rkt | 197 +++++++++++++++++++ nock-e-fast-tree-edit.rkt | 232 ++++++++++++++++++++++ nock-f-explicit-apply.rkt | 236 ++++++++++++++++++++++ nock-g-closure-convert.rkt | 281 +++++++++++++++++++++++++++ notes/nock.txt | 37 ++++ second-pass/nock-b-optimize-edit.rkt | 122 ++++++++++++ second-pass/nock.rkt | 109 +++++++++++ third-pass/nock-a.rkt | 265 +++++++++++++++++++++++++ 16 files changed, 2493 insertions(+) create mode 100644 first-pass/nock-a.rkt create mode 100644 first-pass/nock-b-cps.rkt create mode 100644 first-pass/nock-c-lambda-lift.rkt create mode 100644 first-pass/nock-d-first-order-ks.rkt create mode 100644 first-pass/nock-e-registerise.rkt create mode 100644 nock-a.rkt create mode 100644 nock-b-scry.rkt create mode 100644 nock-c-exceptions.rkt create mode 100644 nock-d-cps.rkt create mode 100644 nock-e-fast-tree-edit.rkt create mode 100644 nock-f-explicit-apply.rkt create mode 100644 nock-g-closure-convert.rkt create mode 100644 notes/nock.txt create mode 100644 second-pass/nock-b-optimize-edit.rkt create mode 100644 second-pass/nock.rkt create mode 100644 third-pass/nock-a.rkt diff --git a/first-pass/nock-a.rkt b/first-pass/nock-a.rkt new file mode 100644 index 0000000..1c243b2 --- /dev/null +++ b/first-pass/nock-a.rkt @@ -0,0 +1,64 @@ +#lang racket +(define nock-eval + (lambda (nock) + (match nock + ; Cell at head of formula, evaluate both formulae and return as cell + ([cons (var a) (cons (cons (var b) (var c)) (var d))] + (cons + (nock-eval (cons a (cons b c))) + (nock-eval (cons a (cons d))))) + ; literal tree index into subject + ([cons (var a) (cons 0 b)] (nock-tree-find a b)) + ; literal + ([cons _ (cons 1 b)] b) + ; evaluate b with subject a + ; evaluate c with subject a + ; evaluate result of c with result of b as subject + ([cons (var a) (cons 2 (cons (var b) (var c)))] (nock-eval (cons (nock-eval (cons a b)) (nock-eval (cons a c))))) + ; evaluate b with a as subject, return + ([cons (var a) (cons 3 (var b))] (if (pair? (nock-eval (cons a b))) 0 1)) + ([cons (var a) (cons 4 (var b))] (+ 1 (nock-eval (cons a b)))) + ([cons (var a) (cons 5 (cons (var b) (var c)))] (if (eqv? (nock-eval (cons a b) (cons a c))) 0 1)) + ; Here we deviate from slavishly following the spec to a symbolically-evaluated reduction of the spec + ; Evaluate b with subject a. If 0 then evaluate c with subject a, else evaluate d with subject a + ([cons (var a) (cons 6 (cons (var b) (cons (var c) (var d))))] + (let ([bval (nock-eval (cons a b))]) + (if (= bval 0) + (nock-eval (cons a c)) + (nock-eval (cons a d))))) + ; Evaluate b with subject a, use result as subject and evaluate c + ([cons (var a) (cons 7 (cons (var b) (var c)))] (nock-eval (cons (nock-eval (cons a b)) c))) + ; Evaluate b with subject a, add result to subject a and evaluate c + ([cons (var a) (cons 8 (cons (var b) (var c)))] (nock-eval (cons (cons (nock-eval (cons a b)) a) c))) + ; Evaluate c with subject a to get a core, look up address b in the core and use it as a formula with the core + ; as the subject + ([cons (var a) (cons 9 (cons (var b) (var c)))] + (let ([core (nock-eval (cons a c))]) + (nock-eval (cons core (nock-tree-find core b))))) + ; Replace the address specified by b in the result of c with subject a with the result of d with subject a + ([cons (var a) (cons 10 (cons (cons (var b) (var c)) (var d)))] + (nock-tree-edit (nock-eval a c) b (nock-eval a d))) + ; Cell hint, compute then discard + ([cons (var a) (cons 11 (cons (cons (var b) (var c)) (var d)))] + ((const (nock-eval (cons b c))) (nock-eval (cons a d)))) + ; Atom hint, discard + ([cons (var a) (cons 11 (cons _ (var c)))] + (nock-eval a c)) + ; Atom, return + ([var a] a)))) + +; / operator in nock spec: tree addressing +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (nock-tree-find (if (even? address) (car tree) (cdr tree)) (quotient address 2))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree) + (if (= address 1) subtree + (if (even? address) + (cons (nock-tree-edit subtree (quotient address 2) (car tree)) (cdr tree)) + (cons (car tree) (nock-tree-edit subtree (quotient address 2) (cdr tree))))))) + +(nock-eval (cons (cons 2 3) (cons 0 3))) diff --git a/first-pass/nock-b-cps.rkt b/first-pass/nock-b-cps.rkt new file mode 100644 index 0000000..1c243b2 --- /dev/null +++ b/first-pass/nock-b-cps.rkt @@ -0,0 +1,64 @@ +#lang racket +(define nock-eval + (lambda (nock) + (match nock + ; Cell at head of formula, evaluate both formulae and return as cell + ([cons (var a) (cons (cons (var b) (var c)) (var d))] + (cons + (nock-eval (cons a (cons b c))) + (nock-eval (cons a (cons d))))) + ; literal tree index into subject + ([cons (var a) (cons 0 b)] (nock-tree-find a b)) + ; literal + ([cons _ (cons 1 b)] b) + ; evaluate b with subject a + ; evaluate c with subject a + ; evaluate result of c with result of b as subject + ([cons (var a) (cons 2 (cons (var b) (var c)))] (nock-eval (cons (nock-eval (cons a b)) (nock-eval (cons a c))))) + ; evaluate b with a as subject, return + ([cons (var a) (cons 3 (var b))] (if (pair? (nock-eval (cons a b))) 0 1)) + ([cons (var a) (cons 4 (var b))] (+ 1 (nock-eval (cons a b)))) + ([cons (var a) (cons 5 (cons (var b) (var c)))] (if (eqv? (nock-eval (cons a b) (cons a c))) 0 1)) + ; Here we deviate from slavishly following the spec to a symbolically-evaluated reduction of the spec + ; Evaluate b with subject a. If 0 then evaluate c with subject a, else evaluate d with subject a + ([cons (var a) (cons 6 (cons (var b) (cons (var c) (var d))))] + (let ([bval (nock-eval (cons a b))]) + (if (= bval 0) + (nock-eval (cons a c)) + (nock-eval (cons a d))))) + ; Evaluate b with subject a, use result as subject and evaluate c + ([cons (var a) (cons 7 (cons (var b) (var c)))] (nock-eval (cons (nock-eval (cons a b)) c))) + ; Evaluate b with subject a, add result to subject a and evaluate c + ([cons (var a) (cons 8 (cons (var b) (var c)))] (nock-eval (cons (cons (nock-eval (cons a b)) a) c))) + ; Evaluate c with subject a to get a core, look up address b in the core and use it as a formula with the core + ; as the subject + ([cons (var a) (cons 9 (cons (var b) (var c)))] + (let ([core (nock-eval (cons a c))]) + (nock-eval (cons core (nock-tree-find core b))))) + ; Replace the address specified by b in the result of c with subject a with the result of d with subject a + ([cons (var a) (cons 10 (cons (cons (var b) (var c)) (var d)))] + (nock-tree-edit (nock-eval a c) b (nock-eval a d))) + ; Cell hint, compute then discard + ([cons (var a) (cons 11 (cons (cons (var b) (var c)) (var d)))] + ((const (nock-eval (cons b c))) (nock-eval (cons a d)))) + ; Atom hint, discard + ([cons (var a) (cons 11 (cons _ (var c)))] + (nock-eval a c)) + ; Atom, return + ([var a] a)))) + +; / operator in nock spec: tree addressing +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (nock-tree-find (if (even? address) (car tree) (cdr tree)) (quotient address 2))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree) + (if (= address 1) subtree + (if (even? address) + (cons (nock-tree-edit subtree (quotient address 2) (car tree)) (cdr tree)) + (cons (car tree) (nock-tree-edit subtree (quotient address 2) (cdr tree))))))) + +(nock-eval (cons (cons 2 3) (cons 0 3))) diff --git a/first-pass/nock-c-lambda-lift.rkt b/first-pass/nock-c-lambda-lift.rkt new file mode 100644 index 0000000..67b8fbe --- /dev/null +++ b/first-pass/nock-c-lambda-lift.rkt @@ -0,0 +1,139 @@ +#lang racket +(define (nock-eval nock k) + (match nock + ; Cell at head of formula, evaluate both formulae and return as cell + ([cons (var a) (cons (cons (var b) (var c)) (var d))] + (nock-eval (cons a (cons b c)) (nock-cell-1 a d k))) + ; literal tree index into subject + ([cons (var a) (cons 0 b)] (nock-tree-find a b k)) + ; literal + ([cons _ (cons 1 b)] (apply-k k b)) + ; evaluate b with subject a + ; evaluate c with subject a + ; evaluate result of c with result of b as subject + ([cons (var a) (cons 2 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-2-1 a c k))) + ; evaluate b with a as subject, return 0 if cell and 1 if atom + ([cons (var a) (cons 3 (var b))] + (nock-eval (cons a b) (nock-3-1 k))) + ; evaluate b with a as subject, return atom-value of result incremented by 1 + ([cons (var a) (cons 4 (var b))] + (nock-eval (cons a b) (nock-4-1 k))) + ; Test for structural equality between 2 nouns + ([cons (var a) (cons 5 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-5-1 a c k))) + ; Here we deviate from slavishly following the spec to a symbolically-evaluated reduction of the spec + ; Evaluate b with subject a. If 0 then evaluate c with subject a, else evaluate d with subject a + ; + ; Note that in the CPS transformation we do *not* evaluate the branches first and then + ; test for which result to feed the continuation. + ([cons (var a) (cons 6 (cons (var b) (cons (var c) (var d))))] + (nock-eval (cons a b) (nock-6-1 a c d k))) + ; Evaluate b with subject a, use result as subject and evaluate c + ([cons (var a) (cons 7 (cons (var b) (var c)))] + (nock-eval (cons a b)) (nock-7-1 c k)) + ; Evaluate b with subject a, add result to subject a and evaluate c + ([cons (var a) (cons 8 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-8-1 a c k))) + ; Evaluate c with subject a to get a core, look up address b in the core and use it as a formula with the core + ; as the subject + ([cons (var a) (cons 9 (cons (var b) (var c)))] + (nock-eval (cons a c) (nock-9-1 b k))) + ; Replace the address specified by b in the result of c with subject a with the result of d with subject a + ([cons (var a) (cons 10 (cons (cons (var b) (var c)) (var d)))] + (nock-eval (cons a c) (nock-10-1 a b d k))) + ; Cell hint, compute then discard + ([cons (var a) (cons 11 (cons (cons (var b) (var c)) (var d)))] + (nock-eval (cons b c) (nock-11-1 a d k))) + ; Atom hint, discard + ([cons (var a) (cons 11 (cons _ (var c)))] + (nock-eval a c k)) + ; Atom, return + ([var a] (apply-k k a)))) + +; continuation definitions for the cell-formula case +(define (nock-cell-1 a d k) + (lambda (abc) (nock-eval (cons a d) (nock-cell-2 abc k)))) + +(define (nock-cell-2 abc k) + (lambda (ad) (apply-k k (cons abc ad)))) + +; continuation definitions for nock 2 +(define (nock-2-1 a c k) + (lambda (ab) (nock-eval (cons a c) (nock-2-2 ab k)))) + +(define (nock-2-2 ab k) + (lambda (ac) (nock-eval (cons ab ac) k))) + +; continuation definition for nock 3 +(define (nock-3-1 k) + (lambda (ab) (if (pair? ab) (apply-k k 0) (apply-k k 1)))) + +; continuation definition for nock 4 +(define (nock-4-1 k) + (lambda (ab) (apply-k k (+ 1 ab)))) + +; continuation definitions for nock 5 +(define (nock-5-1 a c k) + (lambda (ab) (nock-eval (cons a c) (nock-5-2 ab k)))) + +(define (nock-5-2 ab k) + (lambda (ac) (if (= ab ac) (apply-k k 0) (apply-k k 1)))) + +; continuation definitions for nock 6 +(define (nock-6-1 a c d k) + (lambda (ab) (if (= ab 0) (nock-eval (cons a c) k) (nock-eval (cons a d) k)))) + +; continuation definitions for nock 7 +(define (nock-7-1 c k) + (lambda (ab) (nock-eval (cons ab c) k))) + +; continuation definitions for nock 8 +(define (nock-8-1 a c k) + (lambda (ab) (nock-eval (cons (cons ab a) c) k))) + +; continuation definitions for nock 9 +(define (nock-9-1 b k) + (lambda (core) (nock-tree-find core b (nock-9-2 core k)))) + +(define (nock-9-2 core k) + (lambda (arm) (nock-eval (cons core arm) k))) + +; continuation definitions for nock 10 +(define (nock-10-1 a b d k) + (lambda (ac) (nock-eval (cons a d) nock-10-2))) + +(define (nock-10-2 ac b k) + (lambda (ad) (nock-tree-edit ac b ad k))) + +; continuation definitions for nock 11 +(define (nock-11-1 a d k) + (lambda (_) (nock-eval (cons a d) k))) + +; / operator in nock spec: tree addressing +(define (nock-tree-find tree address k) + (if (= address 1) (apply-k k tree) + (nock-tree-find (if (even? address) (car tree) (cdr tree)) (quotient address 2) k))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree k) + (if (= address 1) (apply-k k subtree) + (if (even? address) + (nock-tree-edit subtree (quotient address 2) (car tree) (nock-tree-edit-even tree k)) + (nock-tree-edit subtree (quotient address 2) (cdr tree) (nock-tree-edit-odd tree k))))) + +(define (nock-tree-edit-even tree k) (lambda (x) (k (cons x (cdr tree))))) +(define (nock-tree-edit-odd tree k) (lambda (x) (k (cons (car tree) x)))) + +(define (apply-k k^ v) + (k^ v)) + +(define tree23 (cons 2 3)) +(define (get x) (cons 0 x)) +(define (const x) (cons 1 x)) +(define (call x y) (cons 9 (cons x y))) +(define (declare x y) (cons 8 (cons x y))) + +(nock-eval (cons tree23 (get 1)) identity) +(nock-eval (cons 4 (declare (const tree23) (get 4))) identity) +(nock-eval (cons (declare (const tree23) (get 4)) (call 1 (get 1))) identity) diff --git a/first-pass/nock-d-first-order-ks.rkt b/first-pass/nock-d-first-order-ks.rkt new file mode 100644 index 0000000..320ae78 --- /dev/null +++ b/first-pass/nock-d-first-order-ks.rkt @@ -0,0 +1,146 @@ +#lang racket +(define (nock-eval nock k) + (match nock + ; Cell at head of formula, evaluate both formulae and return as cell + ([cons (var a) (cons (cons (var b) (var c)) (var d))] + (nock-eval (cons a (cons b c)) (nock-cell-1 a d k))) + ; literal tree index into subject + ([cons (var a) (cons 0 b)] (nock-tree-find a b k)) + ; literal + ([cons _ (cons 1 b)] (apply-k k b)) + ; evaluate b with subject a + ; evaluate c with subject a + ; evaluate result of c with result of b as subject + ([cons (var a) (cons 2 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-2-1 a c k))) + ; evaluate b with a as subject, return 0 if cell and 1 if atom + ([cons (var a) (cons 3 (var b))] + (nock-eval (cons a b) (nock-3-1 k))) + ; evaluate b with a as subject, return atom-value of result incremented by 1 + ([cons (var a) (cons 4 (var b))] + (nock-eval (cons a b) (nock-4-1 k))) + ; Test for structural equality between 2 nouns + ([cons (var a) (cons 5 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-5-1 a c k))) + ; Here we deviate from slavishly following the spec to a symbolically-evaluated reduction of the spec + ; Evaluate b with subject a. If 0 then evaluate c with subject a, else evaluate d with subject a + ; + ; Note that in the CPS transformation we do *not* evaluate the branches first and then + ; test for which result to feed the continuation. + ([cons (var a) (cons 6 (cons (var b) (cons (var c) (var d))))] + (nock-eval (cons a b) (nock-6-1 a c d k))) + ; Evaluate b with subject a, use result as subject and evaluate c + ([cons (var a) (cons 7 (cons (var b) (var c)))] + (nock-eval (cons a b)) (nock-7-1 c k)) + ; Evaluate b with subject a, add result to subject a and evaluate c + ([cons (var a) (cons 8 (cons (var b) (var c)))] + (nock-eval (cons a b) (nock-8-1 a c k))) + ; Evaluate c with subject a to get a core, look up address b in the core and use it as a formula with the core + ; as the subject + ([cons (var a) (cons 9 (cons (var b) (var c)))] + (nock-eval (cons a c) (nock-9-1 b k))) + ; Replace the address specified by b in the result of c with subject a with the result of d with subject a + ([cons (var a) (cons 10 (cons (cons (var b) (var c)) (var d)))] + (nock-eval (cons a c) (nock-10-1 a b d k))) + ; Cell hint, compute then discard + ([cons (var a) (cons 11 (cons (cons (var b) (var c)) (var d)))] + (nock-eval (cons b c) (nock-11-1 a d k))) + ; Atom hint, discard + ([cons (var a) (cons 11 (cons _ (var c)))] + (nock-eval a c k)) + ; Atom, return + ([var a] (apply-k k a)))) + +; continuation definitions for the cell-formula case +(define (nock-cell-1 a d k) (list 'nock-cell-1 a d k)) + +(define (nock-cell-2 abc k) (list 'nock-cell-2 abc k)) + +; continuation definitions for nock 2 +(define (nock-2-1 a c k) (list 'nock-2-1 a c k)) + +(define (nock-2-2 ab k) (list 'nock-2-2 ab k)) + +; continuation definition for nock 3 +(define (nock-3-1 k) (list 'nock-3-1 k)) + +; continuation definition for nock 4 +(define (nock-4-1 k) (list 'nock-4-1 k)) + +; continuation definitions for nock 5 +(define (nock-5-1 a c k) (list 'nock-5-1 a c k)) + +(define (nock-5-2 ab k) + (lambda (ac) (if (= ab ac) (apply-k k 0) (apply-k k 1)))) + +; continuation definitions for nock 6 +(define (nock-6-1 a c d k) (list 'nock-6-1 a c d k)) + +; continuation definitions for nock 7 +(define (nock-7-1 c k) (list 'nock-7-1 c k)) + +; continuation definitions for nock 8 +(define (nock-8-1 a c k) (list 'nock-8-1 a c k)) + +; continuation definitions for nock 9 +(define (nock-9-1 b k) (list 'nock-9-1 b k)) + +(define (nock-9-2 core k) (list 'nock-9-2 core k)) + +; continuation definitions for nock 10 +(define (nock-10-1 a b d k) '(nock-10-1 a b d k)) + +(define (nock-10-2 ac b k) '(nock-11-1 ac b k)) + +; continuation definitions for nock 11 +(define (nock-11-1 a d k) + (lambda (_) (nock-eval (cons a d) k))) + +; / operator in nock spec: tree addressing +(define (nock-tree-find tree address k) + (if (= address 1) (apply-k k tree) + (nock-tree-find (if (even? address) (car tree) (cdr tree)) (quotient address 2) k))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree k) + (if (= address 1) (apply-k k subtree) + (if (even? address) + (nock-tree-edit subtree (quotient address 2) (car tree) (nock-tree-edit-even tree k)) + (nock-tree-edit subtree (quotient address 2) (cdr tree) (nock-tree-edit-odd tree k))))) + +(define (nock-tree-edit-even tree k) (list 'nock-tree-edit-even tree k)) +(define (nock-tree-edit-odd tree k) (list 'nock-tree-edit-odd tree k)) + +(define (apply-k k^ v) + (if (procedure? k^) (k^ v) + (match k^ + ([list 'nock-cell-1 (var a) (var d) (var k)] (nock-eval (cons a d) (nock-cell-2 v k))) + ([list 'nock-cell-2 (var abc) (var k)] (apply-k k (cons abc v))) + ([list 'nock-2-1 (var a) (var c) (var k)] (nock-eval (cons a c) (nock-2-2 v k))) + ([list 'nock-2-2 (var ab) (var k)] (nock-eval (cons ab v) k)) + ([list 'nock-3-1 (var k)] (if (pair? v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-4-1 (var k)] (apply-k k (+ 1 v))) + ([list 'nock-5-1 (var a) (var c) (var k)] (nock-eval (cons a c) (nock-5-2 v k))) + ([list 'nock-5-2 (var ab) (var k)] (if (= ab v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-6-1 (var a) (var c) (var d) (var k)] (if (= v 0) (nock-eval (cons a c) k) (nock-eval (cons a d) k))) + ([list 'nock-7-1 (var c) (var k)] (nock-eval (cons v c) k)) + ([list 'nock-8-1 (var a) (var c) (var k)] (nock-eval (cons (cons v a) c) k)) + ([list 'nock-9-1 (var b) (var k)] (nock-tree-find v b (nock-9-2 v k))) + ([list 'nock-9-2 (var core) (var k)] (nock-eval (cons core v) k)) + ([list 'nock-10-1 (var a) (var b) (var d) (var k)] (nock-eval (cons a d) (nock-10-2 v b k))) + ([list 'nock-10-2 (var ac) (var b) (var k)] (nock-tree-edit ac b v k)) + ([list 'nock-11-1 (var a) (var d) (var k)] (nock-eval (cons a d) k)) + ([list 'nock-tree-edit-even (var tree) (var k)] (k (cons v (cdr tree)))) + ([list 'nock-tree-edit-odd (var tree) (var k)] (k (cons (car tree) v)))))) + + +;;;;; Examples +(define tree23 (cons 2 3)) +(define (get x) (cons 0 x)) +(define (const x) (cons 1 x)) +(define (call x y) (cons 9 (cons x y))) +(define (declare x y) (cons 8 (cons x y))) + +(nock-eval (cons tree23 (get 1)) identity) +(nock-eval (cons 4 (declare (const tree23) (get 4))) identity) +(nock-eval (cons (declare (const tree23) (get 4)) (call 1 (get 1))) identity) diff --git a/first-pass/nock-e-registerise.rkt b/first-pass/nock-e-registerise.rkt new file mode 100644 index 0000000..f15bdde --- /dev/null +++ b/first-pass/nock-e-registerise.rkt @@ -0,0 +1,233 @@ +#lang racket +; registers +(define nock 0) +(define tree 0) +(define address 0) +(define subtree 0) +(define k 0) +(define k^ 0) +(define v 0) + +(define (nock-eval) + (match nock + ; Cell at head of formula, evaluate both formulae and return as cell + ([cons (var a) (cons (cons (var b) (var c)) (var d))] + (begin + (set! nock (cons a (cons b c))) + (set! k (nock-cell-1 a d k)) + (nock-eval))) + ; literal tree index into subject + ([cons (var a) (cons 0 b)] + (begin + (set! tree a) + (set! address b) + (nock-tree-find))) + ; literal + ([cons _ (cons 1 b)] + (begin + (set! k^ k) + (set! v b) + (apply-k))) + ; evaluate b with subject a + ; evaluate c with subject a + ; evaluate result of c with result of b as subject + ([cons (var a) (cons 2 (cons (var b) (var c)))] + (begin + (set! nock (cons a b)) + (set! k (nock-2-1 a c k)) + (nock-eval))) + ; evaluate b with a as subject, return 0 if cell and 1 if atom + ([cons (var a) (cons 3 (var b))] + (begin + (set! nock (cons a b)) + (set! k (nock-3-1 k)) + (nock-eval))) + ; evaluate b with a as subject, return atom-value of result incremented by 1 + ([cons (var a) (cons 4 (var b))] + (begin + (set! nock (cons a b)) + (set! k (nock-4-1 k)) + (nock-eval))) + ; Test for structural equality between 2 nouns + ([cons (var a) (cons 5 (cons (var b) (var c)))] + (begin + (set! nock (cons a b)) + (set! k (nock-5-1 a c k)) + (nock-eval))) + ; Here we deviate from slavishly following the spec to a symbolically-evaluated reduction of the spec + ; Evaluate b with subject a. If 0 then evaluate c with subject a, else evaluate d with subject a + ; + ; Note that in the CPS transformation we do *not* evaluate the branches first and then + ; test for which result to feed the continuation. + ([cons (var a) (cons 6 (cons (var b) (cons (var c) (var d))))] + (begin + (set! nock (cons a b)) + (set! k (nock-6-1 a c d k)) + (nock-eval))) + ; Evaluate b with subject a, use result as subject and evaluate c + ([cons (var a) (cons 7 (cons (var b) (var c)))] + (begin + (set! nock (cons a b)) + (set! k (nock-7-1 c k)) + (nock-eval))) + ; Evaluate b with subject a, add result to subject a and evaluate c + ([cons (var a) (cons 8 (cons (var b) (var c)))] + (begin + (set! nock (cons a b)) + (set! k (nock-8-1 a c k)) + (nock-eval))) + ; Evaluate c with subject a to get a core, look up address b in the core and use it as a formula with the core + ; as the subject + ([cons (var a) (cons 9 (cons (var b) (var c)))] + (begin + (set! nock (cons a c)) + (set! k (nock-9-1 b k)) + (nock-eval))) + ; Replace the address specified by b in the result of c with subject a with the result of d with subject a + ([cons (var a) (cons 10 (cons (cons (var b) (var c)) (var d)))] + (begin + (set! nock (cons a c)) + (set! k (nock-10-1 a b d k)) + (nock-eval))) + ; Cell hint, compute then discard + ([cons (var a) (cons 11 (cons (cons (var b) (var c)) (var d)))] + (begin + (set! nock (cons a c)) + (set! k (nock-10-1 a d k)) + (nock-eval))) + ; Atom hint, discard + ([cons (var a) (cons 11 (cons _ (var c)))] + (begin + (set! nock (cons a c)) + (set! k k)) + (nock-eval)) + ; Atom, return + ([var a] + (begin + (set! v a) + (set! k^ k) + (apply-k))))) + +; continuation definitions for the cell-formula case +(define (nock-cell-1 a d k) (list 'nock-cell-1 a d k)) + +(define (nock-cell-2 abc k) (list 'nock-cell-2 abc k)) + +; continuation definitions for nock 2 +(define (nock-2-1 a c k) (list 'nock-2-1 a c k)) + +(define (nock-2-2 ab k) (list 'nock-2-2 ab k)) + +; continuation definition for nock 3 +(define (nock-3-1 k) (list 'nock-3-1 k)) + +; continuation definition for nock 4 +(define (nock-4-1 k) (list 'nock-4-1 k)) + +; continuation definitions for nock 5 +(define (nock-5-1 a c k) (list 'nock-5-1 a c k)) + +(define (nock-5-2 ab k) (list 'nock-5-2 ab k)) + +; continuation definitions for nock 6 +(define (nock-6-1 a c d k) (list 'nock-6-1 a c d k)) + +; continuation definitions for nock 7 +(define (nock-7-1 c k) (list 'nock-7-1 c k)) + +; continuation definitions for nock 8 +(define (nock-8-1 a c k) (list 'nock-8-1 a c k)) + +; continuation definitions for nock 9 +(define (nock-9-1 b k) (list 'nock-9-1 b k)) + +(define (nock-9-2 core k) (list 'nock-9-2 core k)) + +; continuation definitions for nock 10 +(define (nock-10-1 a b d k) '(nock-10-1 a b d k)) + +(define (nock-10-2 ac b k) '(nock-11-1 ac b k)) + +; continuation definitions for nock 11 +(define (nock-11-1 a d k) + (lambda (_) (nock-eval (cons a d) k))) + +; / operator in nock spec: tree addressing +; address: the atom address into the tree +; tree: the tree to address +(define (nock-tree-find) + (if (= address 1) + (begin + (set! v tree) + (set! k k) + (apply-k)) + (begin + (if (even? address) + (set! tree (car tree)) + (set! tree (cdr tree))) + (set! address (quotient address 2)) + (set! k k) + (nock-tree-find)))) + +; # operator in nock spec: tree editing +; subtree: tree to insert +; address: address of subtree to replace +; tree: tree to edit +(define (nock-tree-edit subtree address tree k) + (if (= address 1) + (begin + (set! k k) + (set! v subtree) + (apply-k)) + (begin + (set! subtree subtree) + (set! address (quotient address 2)) + (if (even? address) + (begin + (set! k (nock-tree-edit-even tree k)) + (set! tree (car tree))) + (begin + (set! k (nock-tree-edit-odd tree k)) + (set! tree (cdr tree)))) + (nock-tree-edit)))) + +(define (nock-tree-edit-even tree k) (list 'nock-tree-edit-even tree k)) +(define (nock-tree-edit-odd tree k) (list 'nock-tree-edit-odd tree k)) + +(define (apply-k k^ v) + (if (procedure? k^) (k^ v) + (match k^ + ([list 'nock-cell-1 (var a) (var d) (var k)] + (begin + (set! nock (cons a d)) + (set! k (nock-cell-2 v k)) + (nock-eval))) + ([list 'nock-cell-2 (var abc) (var k)] (apply-k k (cons abc v))) + ([list 'nock-2-1 (var a) (var c) (var k)] (nock-eval (cons a c) (nock-2-2 v k))) + ([list 'nock-2-2 (var ab) (var k)] (nock-eval (cons ab v) k)) + ([list 'nock-3-1 (var k)] (if (pair? v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-4-1 (var k)] (apply-k k (+ 1 v))) + ([list 'nock-5-1 (var a) (var c) (var k)] (nock-eval (cons a c) (nock-5-2 v k))) + ([list 'nock-5-2 (var ab) (var k)] (if (= ab v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-6-1 (var a) (var c) (var d) (var k)] (if (= v 0) (nock-eval (cons a c) k) (nock-eval (cons a d) k))) + ([list 'nock-7-1 (var c) (var k)] (nock-eval (cons v c) k)) + ([list 'nock-8-1 (var a) (var c) (var k)] (nock-eval (cons (cons v a) c) k)) + ([list 'nock-9-1 (var b) (var k)] (nock-tree-find v b (nock-9-2 v k))) + ([list 'nock-9-2 (var core) (var k)] (nock-eval (cons core v) k)) + ([list 'nock-10-1 (var a) (var b) (var d) (var k)] (nock-eval (cons a d) (nock-10-2 v b k))) + ([list 'nock-10-2 (var ac) (var b) (var k)] (nock-tree-edit ac b v k)) + ([list 'nock-11-1 (var a) (var d) (var k)] (nock-eval (cons a d) k)) + ([list 'nock-tree-edit-even (var tree) (var k)] (k (cons v (cdr tree)))) + ([list 'nock-tree-edit-odd (var tree) (var k)] (k (cons (car tree) v)))))) + + +;;;;; Examples +(define tree23 (cons 2 3)) +(define (get x) (cons 0 x)) +(define (const x) (cons 1 x)) +(define (call x y) (cons 9 (cons x y))) +(define (declare x y) (cons 8 (cons x y))) + +(nock-eval (cons tree23 (get 1)) identity) +(nock-eval (cons 4 (declare (const tree23) (get 4))) identity) +(nock-eval (cons (declare (const tree23) (get 4)) (call 1 (get 1))) identity) diff --git a/nock-a.rkt b/nock-a.rkt new file mode 100644 index 0000000..6e5e622 --- /dev/null +++ b/nock-a.rkt @@ -0,0 +1,102 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (nock-noun subject (cons b c)) (nock-noun subject d))) + ([cons 0 (var b)] + (nock-tree-find subject b)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) (nock-noun subject c))) + ([cons 3 (var b)] + (if (pair? (nock-noun subject b)) 0 1)) + ([cons 4 (var b)] + (+ 1 (nock-noun subject b))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (nock-noun subject b) (nock-noun subject c)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (if (= 0 (nock-noun subject b)) + (nock-noun subject c) + (nock-noun subject d))) + ([cons 7 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) c)) + ([cons 8 (cons (var b) (var c))] + (nock-noun (cons (nock-noun subject b) subject) c)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (nock-noun subject c)]) + (nock-noun core (nock-tree-find core b)))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (nock-noun subject c) b (nock-noun subject d))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + ([_ (nock-noun subject c)]) + (nock-noun subject d))) + ([cons 11 (cons (var b) (var c))] + (nock-noun subject c)))) + +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (if (even? address) + (car (nock-tree-find tree (quotient address 2))) + (cdr (nock-tree-find tree (quotient address 2))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree) + (if (= address 1) subtree + (if (even? address) + (nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1))) (quotient address 2) tree) + (nock-tree-edit (cons (nock-tree-find tree (- address 1)) subtree) (quotient address 2) tree))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(check-equal? (nock-noun test-tree (get-0 nock-here)) test-tree "tree address 1") +(check-equal? (nock-noun test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-noun test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-noun 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-noun 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-noun 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-noun test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-noun test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-noun 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-noun 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-noun 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-b-scry.rkt b/nock-b-scry.rkt new file mode 100644 index 0000000..b17448c --- /dev/null +++ b/nock-b-scry.rkt @@ -0,0 +1,115 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates) + (let* + [(recur-on-noun (lambda (subject formula) + (nock-noun subject formula gates))) + (recur-on-scry-gate (lambda (ref path) + (let* + [(gate (car gates)) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (nock-noun core (car core) gates))))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (recur-on-noun subject (cons b c)) (recur-on-noun subject d))) + ([cons 0 (var b)] + (nock-tree-find subject b)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (recur-on-noun (recur-on-noun subject b) (recur-on-noun subject c))) + ([cons 3 (var b)] + (if (pair? (recur-on-noun subject b)) 0 1)) + ([cons 4 (var b)] + (+ 1 (recur-on-noun subject b))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (recur-on-noun subject b) (recur-on-noun subject c)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (if (= 0 (recur-on-noun subject b)) + (recur-on-noun subject c) + (recur-on-noun subject d))) + ([cons 7 (cons (var b) (var c))] + (recur-on-noun (recur-on-noun subject b) c)) + ([cons 8 (cons (var b) (var c))] + (recur-on-noun (cons (recur-on-noun subject b) subject) c)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (recur-on-noun subject c)]) + (recur-on-noun core (nock-tree-find core b)))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (recur-on-noun subject c) b (recur-on-noun subject d))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + ([_ (recur-on-noun subject c)]) + (recur-on-noun subject d))) + ([cons 11 (cons (var b) (var c))] + (recur-on-noun subject c)) + ([cons 12 (cons (var ref) (var path))] + (recur-on-scry-gate (recur-on-noun subject ref) (recur-on-noun subject path)))))) + +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (if (even? address) + (car (nock-tree-find tree (quotient address 2))) + (cdr (nock-tree-find tree (quotient address 2))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree) + (if (= address 1) subtree + (if (even? address) + (nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1))) (quotient address 2) tree) + (nock-tree-edit (cons (nock-tree-find tree (- address 1)) subtree) (quotient address 2) tree))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '())) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-c-exceptions.rkt b/nock-c-exceptions.rkt new file mode 100644 index 0000000..133be70 --- /dev/null +++ b/nock-c-exceptions.rkt @@ -0,0 +1,151 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (let* + [(recur-on-noun (lambda (subject formula) + (nock-noun subject formula gates err-k trace))) + (recur-on-noun-with-hint (lambda (subject formula hint) + (nock-noun subject formula gates err-k (cons hint trace)))) + (recur-on-scry-gate (lambda (ref path) + (let* + [(gate (car (car gates))) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (nock-noun core (car core) gates err-k trace))))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (recur-on-noun subject (cons b c)) (recur-on-noun subject d))) + ([cons 0 (var b)] + (nock-tree-find subject b err-k trace)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (recur-on-noun (recur-on-noun subject b) (recur-on-noun subject c))) + ([cons 3 (var b)] + (if (pair? (recur-on-noun subject b)) 0 1)) + ([cons 4 (var b)] + (+ 1 (recur-on-noun subject b))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (recur-on-noun subject b) (recur-on-noun subject c)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (let + [(test (recur-on-noun subject b))] + (if (= 0 test) + (recur-on-noun subject c) + (if (= 1 test) + (recur-on-noun subject d) + (err-k (cons 2 trace)))))) + ([cons 7 (cons (var b) (var c))] + (recur-on-noun (recur-on-noun subject b) c)) + ([cons 8 (cons (var b) (var c))] + (recur-on-noun (cons (recur-on-noun subject b) subject) c)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (recur-on-noun subject c)]) + (recur-on-noun core (nock-tree-find core b err-k trace)))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (recur-on-noun subject c) b (recur-on-noun subject d) err-k trace)) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + [(clue (recur-on-noun subject c))] + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (recur-on-noun-with-hint subject d (cons b clue)) + (recur-on-noun subject d)))) + ([cons 11 (cons (var b) (var c))] + (recur-on-noun subject c)) + ([cons 12 (cons (var ref) (var path))] + (let + [(result (recur-on-scry-gate (recur-on-noun subject ref) (recur-on-noun subject path)))] + (if (equal? 0 result) + ; ~ + (err-k (cons 1 (cdr path))) + (if (equal? 0 (car result)) + (err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) trace))) + (cdr (cdr result))))))))) + +(define nock-tree-find + (lambda (tree address err-k trace) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) tree + (if (even? address) + (car (nock-tree-find tree (quotient address 2) err-k trace)) + (cdr (nock-tree-find tree (quotient address 2) err-k trace))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree err-k trace) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) subtree + (if (even? address) + (nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1) err-k trace)) (quotient address 2) tree err-k trace) + (nock-tree-edit (cons (nock-tree-find tree (- address 1) err-k trace) subtree) (quotient address 2) tree err-k trace)))))) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '())) + +(define (test-err-k err) + (printf "Error: ~v" err) + (error 'nock-err)) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-d-cps.rkt b/nock-d-cps.rkt new file mode 100644 index 0000000..305991c --- /dev/null +++ b/nock-d-cps.rkt @@ -0,0 +1,197 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (nock-noun-cps subject formula gates err-k trace empty-k)) + +(define (nock-noun-cps subject formula gates err-k trace k) + (let* + [(recur-on-noun (lambda (subject formula k) + (nock-noun-cps subject formula gates err-k trace k))) + (recur-on-noun-with-hint (lambda (subject formula hint k) + (nock-noun-cps subject formula gates err-k (cons hint trace) k))) + (recur-on-scry-gate (lambda (ref path k) + (let* + [(gate (car (car gates))) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (nock-noun-cps core (car core) gates err-k trace k))))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (recur-on-noun subject (cons b c) + (lambda (u) + (recur-on-noun subject d + (lambda (v) + (k (cons u v))))))) + ([cons 0 (var b)] + (nock-tree-find-cps subject b err-k trace k)) + ([cons 1 (var b)] + (k b)) + ([cons 2 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun subject c + (lambda (v) + (recur-on-noun u v k)))))) + ([cons 3 (var b)] + (recur-on-noun subject b + (lambda (u) + (if (pair? u) (k 0) (k 1))))) + ([cons 4 (var b)] + (recur-on-noun subject b + (lambda (u) + (k (+ 1 u))))) + ([cons 5 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun subject c + (lambda (v) + (if (eqv? u v) (k 0) (k 1))))))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (recur-on-noun subject b + (lambda (u) + (if (= 0 u) + (recur-on-noun subject c k) + (if (= 1 u) + (recur-on-noun subject d k) + (err-k (cons 2 trace))))))) + ([cons 7 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun u c k)))) + ([cons 8 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun (cons u subject) c k)))) + ([cons 9 (cons (var b) (var c))] + (recur-on-noun subject c + (lambda (u) + (nock-tree-find-cps u b err-k trace + (lambda (v) + (recur-on-noun u v k)))))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (recur-on-noun subject c + (lambda (u) + (recur-on-noun subject d + (lambda (v) + (nock-tree-edit-cps u b v err-k trace k)))))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (recur-on-noun subject c + (lambda (v) + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (recur-on-noun-with-hint subject d (cons b v) k) + (recur-on-noun subject d k))))) + ([cons 11 (cons (var b) (var c))] + (recur-on-noun subject c k)) + ([cons 12 (cons (var ref) (var path))] + (recur-on-noun subject ref + (lambda (u) + (recur-on-noun subject path + (lambda (v) + (recur-on-scry-gate u v + (lambda (w) + (if (equal? 0 w) + ; ~ + (err-k (cons 1 w)) + (if (equal? 0 (cdr v)) + ; [~ ~] + (err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) trace))) + (k (cdr (cdr w))))))))))))))) + +(define nock-tree-find-cps + (lambda (tree address err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) + (k tree) + (if (even? address) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (k (car u)))) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (k (cdr u))))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit-cps + (lambda (subtree address tree err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) + (k subtree) + (if (even? address) + (nock-tree-find-cps tree (+ address 1) err-k trace + (lambda (u) + (nock-tree-edit-cps (cons subtree u) (quotient address 2) tree err-k trace k))) + (nock-tree-find-cps tree (- address 1) err-k trace + (lambda (u) + (nock-tree-edit-cps (cons u subtree) (quotient address 2) tree err-k trace k)))))))) + +(define (empty-k u) u) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '())) + +(define (test-err-k err) + (printf "Error: ~v" err) + (error 'nock-err)) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-e-fast-tree-edit.rkt b/nock-e-fast-tree-edit.rkt new file mode 100644 index 0000000..29a9b74 --- /dev/null +++ b/nock-e-fast-tree-edit.rkt @@ -0,0 +1,232 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (nock-noun-cps subject formula gates err-k trace empty-k)) + +(define (nock-noun-cps subject formula gates err-k trace k) + (let* + [(recur-on-noun (lambda (subject formula k) + (nock-noun-cps subject formula gates err-k trace k))) + (recur-on-noun-with-hint (lambda (subject formula hint k) + (nock-noun-cps subject formula gates err-k (cons hint trace) k))) + (recur-on-scry-gate (lambda (ref path k) + (let* + [(gate (car (car gates))) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (nock-noun-cps core (car core) gates err-k trace k))))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (recur-on-noun subject (cons b c) + (lambda (u) + (recur-on-noun subject d + (lambda (v) + (k (cons u v))))))) + ([cons 0 (var b)] + (nock-tree-find-cps subject b err-k trace k)) + ([cons 1 (var b)] + (k b)) + ([cons 2 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun subject c + (lambda (v) + (recur-on-noun u v k)))))) + ([cons 3 (var b)] + (recur-on-noun subject b + (lambda (u) + (if (pair? u) (k 0) (k 1))))) + ([cons 4 (var b)] + (recur-on-noun subject b + (lambda (u) + (k (+ 1 u))))) + ([cons 5 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun subject c + (lambda (v) + (if (eqv? u v) (k 0) (k 1))))))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (recur-on-noun subject b + (lambda (u) + (if (= 0 u) + (recur-on-noun subject c k) + (if (= 1 u) + (recur-on-noun subject d k) + (err-k (cons 2 trace))))))) + ([cons 7 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun u c k)))) + ([cons 8 (cons (var b) (var c))] + (recur-on-noun subject b + (lambda (u) + (recur-on-noun (cons u subject) c k)))) + ([cons 9 (cons (var b) (var c))] + (recur-on-noun subject c + (lambda (u) + (nock-tree-find-cps u b err-k trace + (lambda (v) + (recur-on-noun u v k)))))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (recur-on-noun subject c + (lambda (u) + (recur-on-noun subject d + (lambda (v) + (nock-tree-edit-cps u b v err-k trace k)))))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (recur-on-noun subject c + (lambda (v) + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (recur-on-noun-with-hint subject d (cons b v) k) + (recur-on-noun subject d k))))) + ([cons 11 (cons (var b) (var c))] + (recur-on-noun subject c k)) + ([cons 12 (cons (var ref) (var path))] + (recur-on-noun subject ref + (lambda (u) + (recur-on-noun subject path + (lambda (v) + (recur-on-scry-gate u v + (lambda (w) + (if (equal? 0 w) + ; ~ + (err-k (cons 1 w)) + (if (equal? 0 (cdr v)) + ; [~ ~] + (err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) trace))) + (k (cdr (cdr w))))))))))))))) + +(define nock-tree-find-cps + (lambda (tree address err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) + (k tree) + (if (even? address) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (k (car u)))) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (k (cdr u))))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit-cps + (lambda (subtree address tree err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (reverse-address-cps address (lambda (u) + (nock-tree-edit-reversed-cps subtree u tree k)))))) + +; Transform a nock address into a bitwise reversed address and a depth +; Note that the MSB of the address is always 1, and is *not* a head/tail bit. +; So we discard that one and do not count it in the depth. +; Editing on our representation is then a matter of +; editing the car or cdr of the tree based on whether the LSB is 1 or 0, +; shifting, decrementing the depth, and going around again *until the depth is 0* +; +; note that with several car bits at the bottom of the path (LSB in address, MSB reversed) +; the reversed address will be 0 for several iteraitons at the end, thus we test the depth +; and not the reversed address +(define (reverse-address-cps address k) + (reverse-address-acc-cps address 0 0 k)) + +(define (reverse-address-acc-cps address reversed depth k) + (if (= address 0) + ; The most-significant bit in the address is a marker for the depth of + ; the address, not a head/tail flag. We are instead storing the depth separately + ; in the reversed representation, so we discard it. + (k (cons (arithmetic-shift reversed -1) (- depth 1))) + (let* + [(top-bit (bitwise-and address 1)) + (reversed (bitwise-ior (arithmetic-shift reversed 1) top-bit)) + (address (arithmetic-shift address -1)) + (depth (+ depth 1))] + (reverse-address-acc-cps address reversed depth k)))) + +(define nock-tree-edit-reversed-cps + (lambda (subtree reversed-depth tree k) + (let* + [(reversed (car reversed-depth)) + (depth (cdr reversed-depth)) + (reversed-depth (cons (arithmetic-shift reversed -1) (- depth 1)))] + (if (= depth 0) + (k subtree) + (if (even? reversed) + (nock-tree-edit-reversed-cps subtree reversed-depth (car tree) + (lambda (u) + (k (cons u (cdr tree))))) + (nock-tree-edit-reversed-cps subtree reversed-depth (cdr tree) + (lambda (u) + (k (cons (car tree) u))))))))) + +(define (empty-k u) u) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '())) + +(define (test-err-k err) + (printf "Error: ~v" err) + (error 'nock-err)) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-f-explicit-apply.rkt b/nock-f-explicit-apply.rkt new file mode 100644 index 0000000..92e3e40 --- /dev/null +++ b/nock-f-explicit-apply.rkt @@ -0,0 +1,236 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (nock-noun-cps subject formula gates err-k trace empty-k)) + +(define (nock-noun-cps subject formula gates err-k trace k) + (let* + [(recur-on-noun (lambda (subject formula k) + (nock-noun-cps subject formula gates err-k trace k))) + (recur-on-noun-with-hint (lambda (subject formula hint k) + (nock-noun-cps subject formula gates err-k (cons hint trace) k))) + (recur-on-scry-gate (lambda (ref path k) + (let* + [(gate (car (car gates))) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (nock-noun-cps core (car core) gates err-k trace k))))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (apply-3 recur-on-noun subject (cons b c) + (lambda (u) + (apply-3 recur-on-noun subject d + (lambda (v) + (apply-k k (cons u v))))))) + ([cons 0 (var b)] + (nock-tree-find-cps subject b err-k trace k)) + ([cons 1 (var b)] + (apply-k k b)) + ([cons 2 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (lambda (u) + (apply-3 recur-on-noun subject c + (lambda (v) + (apply-3 recur-on-noun u v k)))))) + ([cons 3 (var b)] + (apply-3 recur-on-noun subject b + (lambda (u) + (if (pair? u) (apply-k k 0) (apply-k k 1))))) + ([cons 4 (var b)] + (apply-3 recur-on-noun subject b + (lambda (u) + (apply-k k (+ 1 u))))) + ([cons 5 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (lambda (u) + (apply-3 recur-on-noun subject c + (lambda (v) + (if (eqv? u v) (apply-k k 0) (apply-k k 1))))))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (apply-3 recur-on-noun subject b + (lambda (u) + (if (= 0 u) + (apply-3 recur-on-noun subject c k) + (if (= 1 u) + (apply-3 recur-on-noun subject d k) + (err-k (cons 2 trace))))))) + ([cons 7 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (lambda (u) + (apply-3 recur-on-noun u c k)))) + ([cons 8 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (lambda (u) + (apply-3 recur-on-noun (cons u subject) c k)))) + ([cons 9 (cons (var b) (var c))] + (apply-3 recur-on-noun subject c + (lambda (u) + (nock-tree-find-cps u b err-k trace + (lambda (v) + (apply-3 recur-on-noun u v k)))))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (apply-3 recur-on-noun subject c + (lambda (u) + (apply-3 recur-on-noun subject d + (lambda (v) + (nock-tree-edit-cps u b v err-k trace k)))))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (apply-3 recur-on-noun subject c + (lambda (v) + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (apply-4 recur-on-noun-with-hint subject d (cons b v) k) + (apply-3 recur-on-noun subject d k))))) + ([cons 11 (cons (var b) (var c))] + (apply-3 recur-on-noun subject c k)) + ([cons 12 (cons (var ref) (var path))] + (apply-3 recur-on-noun subject ref + (lambda (u) + (apply-3 recur-on-noun subject path + (lambda (v) + (apply-3 recur-on-scry-gate u v + (lambda (w) + (if (equal? 0 w) + ; ~ + (err-k (cons 1 w)) + (if (equal? 0 (cdr v)) + ; [~ ~] + (err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) trace))) + (apply-k k (cdr (cdr w))))))))))))))) + +(define nock-tree-find-cps + (lambda (tree address err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) + (apply-k k tree) + (if (even? address) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (apply-k k (car u)))) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (lambda (u) + (apply-k k (cdr u))))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit-cps + (lambda (subtree address tree err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (reverse-address-cps address (lambda (u) + (nock-tree-edit-reversed-cps subtree u tree k)))))) + +; Transform a nock address into a bitwise reversed address and a depth +; Note that the MSB of the address is always 1, and is *not* a head/tail bit. +; So we discard that one and do not count it in the depth. +; Editing on our representation is then a matter of +; editing the car or cdr of the tree based on whether the LSB is 1 or 0, +; shifting, decrementing the depth, and going around again *until the depth is 0* +; +; note that with several car bits at the bottom of the path (LSB in address, MSB reversed) +; the reversed address will be 0 for several iteraitons at the end, thus we test the depth +; and not the reversed address +(define (reverse-address-cps address k) + (reverse-address-acc-cps address 0 0 k)) + +(define (reverse-address-acc-cps address reversed depth k) + (if (= address 0) + ; The most-significant bit in the address is a marker for the depth of + ; the address, not a head/tail flag. We are instead storing the depth separately + ; in the reversed representation, so we discard it. + (apply-k k (cons (arithmetic-shift reversed -1) (- depth 1))) + (let* + [(top-bit (bitwise-and address 1)) + (reversed (bitwise-ior (arithmetic-shift reversed 1) top-bit)) + (address (arithmetic-shift address -1)) + (depth (+ depth 1))] + (reverse-address-acc-cps address reversed depth k)))) + +(define nock-tree-edit-reversed-cps + (lambda (subtree reversed-depth tree k) + (let* + [(reversed (car reversed-depth)) + (depth (cdr reversed-depth)) + (reversed-depth (cons (arithmetic-shift reversed -1) (- depth 1)))] + (if (= depth 0) + (apply-k k subtree) + (if (even? reversed) + (nock-tree-edit-reversed-cps subtree reversed-depth (car tree) + (lambda (u) + (apply-k k (cons u (cdr tree))))) + (nock-tree-edit-reversed-cps subtree reversed-depth (cdr tree) + (lambda (u) + (apply-k k (cons (car tree) u))))))))) + +(define (empty-k u) u) + +(define (apply-k k^ v) (k^ v)) +(define (apply-3 k^ u v w) (k^ u v w)) +(define (apply-4 k^ u v w x) (k^ u v w x)) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '())) + +(define (test-err-k err) + (printf "Error: ~v" err) + (error 'nock-err)) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/nock-g-closure-convert.rkt b/nock-g-closure-convert.rkt new file mode 100644 index 0000000..86b60e1 --- /dev/null +++ b/nock-g-closure-convert.rkt @@ -0,0 +1,281 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (nock-noun-cps subject formula gates err-k trace empty-k)) + +(define (nock-noun-cps subject formula gates err-k trace k) + (let* + [(recur-on-noun (recur-on-noun-closure gates err-k trace)) + (recur-on-noun-with-hint (recur-on-noun-with-hint-closure gates err-k trace)) + (recur-on-scry-gate (recur-on-scry-gate-closure gates))] + (match formula + ([cons (cons (var b) (var c)) (var d)] + (apply-3 recur-on-noun subject (cons b c) + (nock-cons-k-1 recur-on-noun subject d k))) + ([cons 0 (var b)] + (nock-tree-find-cps subject b err-k trace k)) + ([cons 1 (var b)] + (apply-k k b)) + ([cons 2 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (nock-2-k-1 recur-on-noun subject c k))) + ([cons 3 (var b)] + (apply-3 recur-on-noun subject b + (nock-3-k k))) + ([cons 4 (var b)] + (apply-3 recur-on-noun subject b + (nock-4-k k))) + ([cons 5 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (nock-5-k-1 recur-on-noun subject c k))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (apply-3 recur-on-noun subject b + (nock-6-k recur-on-noun subject c d err-k trace k))) + ([cons 7 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (nock-7-k recur-on-noun c k))) + ([cons 8 (cons (var b) (var c))] + (apply-3 recur-on-noun subject b + (nock-8-k recur-on-noun subject c k))) + ([cons 9 (cons (var b) (var c))] + (apply-3 recur-on-noun subject c + (nock-9-k-1 recur-on-noun b err-k trace k))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (apply-3 recur-on-noun subject c + (nock-10-k-1 recur-on-noun subject d b err-k trace k))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (apply-3 recur-on-noun subject c + (nock-11-k recur-on-noun-with-hint recur-on-noun subject d b k))) + ([cons 11 (cons (var b) (var c))] + (apply-3 recur-on-noun subject c k)) + ([cons 12 (cons (var ref) (var path))] + (apply-3 recur-on-noun subject ref + (nock-12-k-1 recur-on-noun subject path recur-on-scry-gate err-k trace k)))))) + +(define nock-tree-find-cps + (lambda (tree address err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (if (= address 1) + (apply-k k tree) + (if (even? address) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (nock-tree-find-k-car k)) + (nock-tree-find-cps tree (quotient address 2) err-k trace + (nock-tree-find-k-cdr k))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit-cps + (lambda (subtree address tree err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (reverse-address-cps address (nock-tree-edit-k subtree tree k))))) + +; Transform a nock address into a bitwise reversed address and a depth +; Note that the MSB of the address is always 1, and is *not* a head/tail bit. +; So we discard that one and do not count it in the depth. +; Editing on our representation is then a matter of +; editing the car or cdr of the tree based on whether the LSB is 1 or 0, +; shifting, decrementing the depth, and going around again *until the depth is 0* +; +; note that with several car bits at the bottom of the path (LSB in address, MSB reversed) +; the reversed address will be 0 for several iteraitons at the end, thus we test the depth +; and not the reversed address +(define (reverse-address-cps address k) + (reverse-address-acc-cps address 0 0 k)) + +(define (reverse-address-acc-cps address reversed depth k) + (if (= address 0) + ; The most-significant bit in the address is a marker for the depth of + ; the address, not a head/tail flag. We are instead storing the depth separately + ; in the reversed representation, so we discard it. + (apply-k k (cons (arithmetic-shift reversed -1) (- depth 1))) + (let* + [(top-bit (bitwise-and address 1)) + (reversed (bitwise-ior (arithmetic-shift reversed 1) top-bit)) + (address (arithmetic-shift address -1)) + (depth (+ depth 1))] + (reverse-address-acc-cps address reversed depth k)))) + +(define nock-tree-edit-reversed-cps + (lambda (subtree reversed-depth tree k) + (let* + [(reversed (car reversed-depth)) + (depth (cdr reversed-depth)) + (reversed-depth (cons (arithmetic-shift reversed -1) (- depth 1)))] + (if (= depth 0) + (apply-k k subtree) + (if (even? reversed) + (nock-tree-edit-reversed-cps subtree reversed-depth (car tree) + (nock-tree-edit-k-car tree k)) + (nock-tree-edit-reversed-cps subtree reversed-depth (cdr tree) + (nock-tree-edit-k-cdr tree k))))))) + +(define (recur-on-noun-closure gates err-k trace) (list 'recur-on-noun gates err-k trace)) +(define (recur-on-noun-with-hint-closure gates err-k trace) (list 'recur-on-noun-with-hint gates err-k trace)) +(define (recur-on-scry-gate-closure gates) (list 'recur-on-scry-gate gates)) + +(define empty-k (list 'empty-k)) + +(define (nock-cons-k-1 recur-on-noun subject d k) (list 'nock-cons-k-1 recur-on-noun subject d k)) +(define (nock-cons-k-2 u k) (list 'nock-cons-k-2 u k)) +(define (nock-2-k-1 recur-on-noun subject c k) (list 'nock-2-k-1 recur-on-noun subject c k)) +(define (nock-2-k-2 recur-on-noun u k) (list 'nock-2-k-2 recur-on-noun u k)) +(define (nock-3-k k) (list 'nock-3-k k)) +(define (nock-4-k k) (list 'nock-4-k k)) +(define (nock-5-k-1 recur-on-noun subject c k) (list 'nock-5-k-1 recur-on-noun subject c k)) +(define (nock-5-k-2 u k) (list 'nock-5-k-2 u k)) +(define (nock-6-k recur-on-noun subject c d err-k trace k) (list 'nock-6-k recur-on-noun subject c d err-k trace k)) +(define (nock-7-k recur-on-noun c k) (list 'nock-7-k recur-on-noun c k)) +(define (nock-8-k recur-on-noun subject c k) (list 'nock-8-k recur-on-noun subject c k)) +(define (nock-9-k-1 recur-on-noun b err-k trace k) (list 'nock-9-k-1 recur-on-noun b err-k trace k)) +(define (nock-9-k-2 recur-on-noun u k) (list 'nock-9-k-2 recur-on-noun u k)) +(define (nock-10-k-1 recur-on-noun subject d b err-k trace k) (list 'nock-10-k-1 recur-on-noun subject d b err-k trace k)) +(define (nock-10-k-2 u b err-k trace k) (list 'nock-10-k-2 u b err-k trace k)) +(define (nock-11-k recur-on-noun-with-hint recur-on-noun subject d b k) (list 'nock-11-k recur-on-noun-with-hint recur-on-noun subject d b k)) +(define (nock-12-k-1 recur-on-noun subject path recur-on-scry-gate err-k trace k) (list 'nock-12-k-2 recur-on-noun subject path recur-on-scry-gate err-k trace k)) +(define (nock-12-k-2 recur-on-scry-gate u err-k trace k) (list 'nock-12-k-2 recur-on-scry-gate u err-k trace k)) +(define (nock-12-k-3 u v^ err-k trace k) (list 'nock-12-k-3 u v^ err-k trace k)) +(define (nock-tree-edit-k subtree tree k) (list 'nock-tree-edit-k subtree tree k)) +(define (nock-tree-find-k-car k) (list 'nock-tree-find-k-car k)) +(define (nock-tree-find-k-cdr k) (list 'nock-tree-find-k-cdr k)) +(define (nock-tree-edit-k-car tree k) (list 'nock-tree-edit-k-car tree k)) +(define (nock-tree-edit-k-cdr tree k) (list 'nock-tree-edit-k-cdr tree k)) + +(define (apply-k k^ v) + (match k^ + ([list 'empty-k] v) + ([list 'nock-cons-k-1 (var recur-on-noun) (var subject) (var d) (var k)] (apply-3 recur-on-noun subject d (nock-cons-k-2 v k))) + ([list 'nock-cons-k-2 (var u) (var k)] (apply-k k (cons u v))) + ([list 'nock-2-k-1 (var recur-on-noun) (var subject) (var c) (var k)] (apply-3 recur-on-noun subject c (nock-2-k-2 recur-on-noun v k))) + ([list 'nock-2-k-2 (var recur-on-noun) (var u) (var k)] (apply-3 recur-on-noun u v k)) + ([list 'nock-3-k (var k)] (if (pair? v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-4-k (var k)] (apply-k k (+ 1 v))) + ([list 'nock-5-k-1 (var recur-on-noun) (var subject) (var c) (var k)] (apply-3 recur-on-noun subject c (nock-5-k-2 v k))) + ([list 'nock-5-k-2 (var u) (var k)] (if (eqv? u v) (apply-k k 0) (apply-k k 1))) + ([list 'nock-6-k (var recur-on-noun) (var subject) (var c) (var d) (var err-k) (var trace) (var k)] + (if (= 0 v) + (apply-3 recur-on-noun subject c k) + (if (= 1 v) + (apply-3 recur-on-noun subject d k) + (err-k (cons 2 trace))))) + ([list 'nock-7-k (var recur-on-noun) (var c) (var k)] (apply-3 recur-on-noun v c k)) + ([list 'nock-8-k (var recur-on-noun) (var subject) (var c) (var k)] (apply-3 recur-on-noun (cons v subject) c k)) + ([list 'nock-9-k-1 (var recur-on-noun) (var b) (var err-k) (var trace) (var k)] + (nock-tree-find-cps v b err-k trace (nock-9-k-2 recur-on-noun v k))) + ([list 'nock-9-k-2 (var recur-on-noun) (var u) (var k)] (apply-3 recur-on-noun u v k)) + ([list 'nock-10-k-1 (var recur-on-noun) (var subject) (var d) (var b) (var err-k) (var trace) (var k)] + (apply-3 recur-on-noun subject d + (nock-10-k-2 v b err-k trace k))) + ([list 'nock-10-k-2 (var u) (var b) (var err-k) (var trace) (var k)] + (nock-tree-edit-cps u b v err-k trace k)) + ([list 'nock-11-k (var recur-on-noun-with-hint) (var recur-on-noun) (var subject) (var d) (var b) (var k)] + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (apply-4 recur-on-noun-with-hint subject d (cons b v) k) + (apply-3 recur-on-noun subject d k))) + ([list 'nock-12-k-1 (var recur-on-noun) (var subject) (var path) (var recur-on-scry-gate) (var err-k) (var trace) (var k)] + (apply-3 recur-on-noun subject path + (nock-12-k-2 recur-on-scry-gate v err-k trace k))) + ([list 'nock-12-k-2 (var recur-on-scry-gate) (var u) (var err-k) (var trace) (var k)] + (apply-3 recur-on-scry-gate u v (nock-12-k-3 u v err-k trace k))) + ([list 'nock-12-k-3 (var u) (var v^) (var err-k) (var trace) (var k)] + (if (equal? 0 v) + ; ~ + (err-k (cons 1 v)) + (if (equal? 0 (cdr v)) + ; [~ ~] + (err-k (cons 2 (cons (cons (tas "hunk") (cons u v^)) trace))) + (apply-k k (cdr (cdr v)))))) + ([list 'nock-tree-find-k-car (var k)] (apply-k k (car v))) + ([list 'nock-tree-find-k-cdr (var k)] (apply-k k (cdr v))) + ([list 'nock-tree-edit-k (var subtree) (var tree) (var k)] + (nock-tree-edit-reversed-cps subtree v tree k)) + ([list 'nock-tree-edit-k-car (var tree) (var k)] (apply-k k (cons v (cdr tree)))) + ([list 'nock-tree-edit-k-cdr (var tree) (var k)] (apply-k k (cons (car tree) v))) + ([var k^] #:when (procedure? k^) (k^ v)))) + +(define (apply-3 k^ u v w) + (match k^ + ([list 'recur-on-noun (var gates) (var err-k) (var trace)] + (nock-noun-cps u v gates err-k trace w)) + ([list 'recur-on-scry-gate (var gates)] + (let* + [(gate (car (car gates))) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons u v) (cdr (cdr gate)))))] + (nock-noun-cps core (car core) gates err-k trace w))) + ([var k^] #:when (procedure? k^) (k^ u v w)))) + +(define (apply-4 k^ u v w x) + (match k^ + ([list 'recur-on-noun-with-hint (var gates) (var err-k) (var trace)] + (nock-noun-cps u v gates err-k (cons w trace) x)) + ([var k^] #:when (procedure? k^) (k^ u v w x)))) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(define (nock-test subject formula) (nock-noun subject formula '() test-err-k '())) + +(define (test-err-k err) + (printf "Error: ~v" err) + (error 'nock-err)) + +(check-equal? (nock-test test-tree (get-0 nock-here) ) test-tree "tree address 1") +(check-equal? (nock-test test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-test test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-test test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-test test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-test 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-test 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-test test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-test test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-test 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-test test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-test test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-test test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-test 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-test 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-test 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-test 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/notes/nock.txt b/notes/nock.txt new file mode 100644 index 0000000..8c53d1f --- /dev/null +++ b/notes/nock.txt @@ -0,0 +1,37 @@ +## sample eval + +### nock 6 +``` +*[a 6 b c d] +*[a *[[c d] 0 *[[2 3] 0 *[a 4 4 b]]]] +*[a *[[c d] 0 *[[2 3] 0 +*[a 4 b]]]] +*[a *[[c d] 0 *[[2 3] 0 ++*[a b]]]] +``` +#### if *[a b] is 0 +``` +*[a *[[c d] 0 *[[2 3] 0 ++0]]] +*[a *[[c d] 0 *[[2 3] 0 +1]]] +*[a *[[c d] 0 *[[2 3] 0 2]]] +*[a *[[c d] 0 2]] +*[a c] +``` +#### if *[a b] is 1 +``` +*[a *[[c d] 0 *[[2 3] 0 ++1]]] +*[a *[[c d] 0 *[[2 3] 0 +2]]] +*[a *[[c d] 0 *[[2 3] 0 3]]] +*[a *[[c d] 0 3]] +*[a d] +``` + +### nock 9 +*[a 9 b c] +*[*[a c] 2 [0 1] 0 b] +(d=*[a c]) +*[*[d 0 1] *[d 0 b]] +*[d *[d 0 b]] + + + +## impl notes + diff --git a/second-pass/nock-b-optimize-edit.rkt b/second-pass/nock-b-optimize-edit.rkt new file mode 100644 index 0000000..4f2a7e0 --- /dev/null +++ b/second-pass/nock-b-optimize-edit.rkt @@ -0,0 +1,122 @@ +#lang racket + +(require rackunit) + +(define (nock noun) + (if (pair? noun) + (nock-noun (car noun) (cdr noun)) + noun)) + +(define (nock-noun subject formula) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (nock-noun subject (cons b c)) (nock-noun subject d))) + ([cons 0 (var b)] + (nock-tree-find subject b)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) (nock-noun subject c))) + ([cons 3 (var b)] + (if (pair? (nock-noun subject b)) 0 1)) + ([cons 4 (var b)] + (+ 1 (nock-noun subject b))) + ([cons 5 (cons (var b) (var c))] + (if (equal? (nock-noun subject b) (nock-noun subject c)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (if (= 0 (nock-noun subject b)) + (nock-noun subject c) + (nock-noun subject d))) + ([cons 7 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) c)) + ([cons 8 (cons (var b) (var c))] + (nock-noun (cons (nock-noun subject b) subject) c)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (nock-noun subject c)]) + (nock-noun core (nock-tree-find core b)))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (nock-noun subject c) b (nock-noun subject d))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + ([_ (nock-noun subject c)]) + (nock-noun subject d))) + ([cons 11 (cons (var b) (var c))] + (nock-noun subject c)) + ([var a] #:when (exact-nonnegative-integer? a) a))) + +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (if (even? address) + (car (nock-tree-find tree (quotient address 2))) + (cdr (nock-tree-find tree (quotient address 2))))))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree) + ((nock-tree-patch-address-acc (nock-tree-patch-here subtree) address) tree)) + +(define (nock-tree-patch-address-acc patch address) + (if (= address 1) + patch + (if (even? address) + (nock-tree-patch-address-acc (nock-tree-patch-left patch) (quotient address 2)) + (nock-tree-patch-address-acc (nock-tree-patch-right patch) (quotient address 2))))) + +(define (nock-tree-patch-here x) + (lambda (_) x)) + +(define (nock-tree-patch-left patch) + (lambda (tree) + (cons (patch (car tree)) (cdr tree)))) + +(define (nock-tree-patch-right patch) + (lambda (tree) + (cons (car tree) (patch (cdr tree))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(check-equal? (nock-noun test-tree (get-0 nock-here)) test-tree "tree address 1") +(check-equal? (nock-noun test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-noun test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-noun 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-noun 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-noun 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-noun test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-noun test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-noun 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-noun 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-noun 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic diff --git a/second-pass/nock.rkt b/second-pass/nock.rkt new file mode 100644 index 0000000..51f9e5d --- /dev/null +++ b/second-pass/nock.rkt @@ -0,0 +1,109 @@ +#lang racket + +(require rackunit) + +(define (nock noun) + (if (pair? noun) + (nock-noun (car noun) (cdr noun)) + noun)) + +(define (nock-noun subject formula) + +(match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (nock-noun subject (cons b c)) (nock-noun subject d))) + ([cons 0 (var b)] + (nock-tree-find subject b)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) (nock-noun subject c))) + ([cons 3 (var b)] + (if (pair? (nock-noun subject b)) 0 1)) + ([cons 4 (var b)] + (+ 1 (nock-noun subject b))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (nock-noun subject b) (nock-noun subject c)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (if (= 0 (nock-noun subject b)) + (nock-noun subject c) + (nock-noun subject d))) + ([cons 7 (cons (var b) (var c))] + (nock-noun (nock-noun subject b) c)) + ([cons 8 (cons (var b) (var c))] + (nock-noun (cons (nock-noun subject b) subject) c)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (nock-noun subject c)]) + (nock-noun core (nock-tree-find core b)))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (nock-noun subject c) b (nock-noun subject d))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + ([_ (nock-noun subject c)]) + (nock-noun subject d))) + ([cons 11 (cons (var b) (var c))] + (nock-noun subject c)) + ([var a] #:when (exact-nonnegative-integer? a) a))) + +(define nock-tree-find + (lambda (tree address) + (if (= address 1) tree + (if (even? address) + (car (nock-tree-find tree (quotient address 2))) + (cdr (nock-tree-find tree (quotient address 2))))))) + +; # operator in nock spec: tree editing +(define nock-tree-edit + (lambda (subtree address tree) + (if (= address 1) subtree + (if (even? address) + (nock-tree-edit (cons subtree (nock-tree-find tree (+ address 1))) (quotient address 2) tree) + (nock-tree-edit (cons (nock-tree-find tree (- address 1)) subtree) (quotient address 2) tree))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(check-equal? (nock-noun test-tree (get-0 nock-here)) test-tree "tree address 1") +(check-equal? (nock-noun test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-noun test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-noun 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-noun 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-noun 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-noun test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-noun test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-noun 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-noun 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-noun 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic \ No newline at end of file diff --git a/third-pass/nock-a.rkt b/third-pass/nock-a.rkt new file mode 100644 index 0000000..e266dca --- /dev/null +++ b/third-pass/nock-a.rkt @@ -0,0 +1,265 @@ +#lang racket + +(require rackunit) + +(define (nock cell) + (cdr (mink-cell (car cell) (cdr cell) '() '()))) + +(define (nock-noun subject formula) + (cdr (mink-cell subject formula '() '()))) + +(define (mink-cell subject formula trace gates) + (let + [(recur-on-noun (lambda (subject formula) (mink-cell subject formula trace gates))) + (recur-on-noun-with-hint (lambda (subject formula hint) (mink-cell subject formula (cons hint trace) gates))) + (recur-on-top-gate (lambda (ref path) + (let* + [(gate (car gates)) + (gates (cdr gates)) + (cor (cons (car gate) (cons (cons ref path) (cdr (cdr gate)))))] + (mink-cell cor (car gate) trace gates))))] + (match formula + ;; A cell of two formulae computes both against the same subject + ;; and returns their result as a cell + ([cons (cons (var b) (var c)) (var d)] + (let + [(head (recur-on-noun subject (cons b c)))] + (if (not (= 0 (car head))) + head + (let + [(tail (recur-on-noun subject d))] + (if (not (= 0 (car tail))) + tail + (cons 0 (car head) (car tail))))))) + ;; Get an axis from the subject + ([cons 0 (var axis)] + (let + [(part (frag axis subject))] + (if (equal? 0 part) + (cons 2 trace) + (cons 0 (cdr part))))) + ;; Return a constant noun + ([cons 1 (var constant)] + (cons 0 constant)) + ;; Compute both arguments as formulae against the subject, + ;; then treat the first result as the subject and the second + ;; as the formula and compute again + ([cons 2 (cons (var subject^) (var formula))] + (let + [(subject^ (recur-on-noun subject subject^))] + (if (not (= 0 (car subject^))) + subject^ + (let + [(formula (recur-on-noun subject formula))] + (if (not (= 0 (car formula))) + formula + (recur-on-noun subject^ formula)))))) + ;; 0 result if argument computes to cell, 1 if atom + ([cons 3 (var argument)] + (let + [(argument (recur-on-noun subject argument))] + (if (not (= 0 (car argument))) + argument + (if (pair? (cdr argument)) 0 1)))) + ;; Compute argument which must compute to atom, then increment that atom + ([cons 4 (var argument)] + (let + [(argument (recur-on-noun subject argument))] + (if (not (= 0 (car argument))) + argument + (+ 1 (cdr argument))))) + ;; Test equality of two nouns, 0 if equal, 1 if not + ([cons 5 (cons (var a) (var b))] + (let + [(a (recur-on-noun subject a))] + (if (not (= 0 (car a))) + a + (let + [(b (recur-on-noun subject b))] + (if (not = 0 (car b)) + b + (if (equal? (cdr a) (cdr b)) 0 1)))))) + ;; If then else: evaluate test argument, which must return 0 or 1. + ;; If 0 then evaluate 'yes' argument + ;; If 1 then evaluate 'no' argument + ([cons 6 (cons (var test) (cons (var yes) (var no)))] + (let + [(result (recur-on-noun subject test))] + (if (not (= 0 (car result))) + result + (match (cdr result) + (0 (recur-on-noun subject yes)) + (1 (recur-on-noun subject no)) + (_ (cons 2 trace)))))) + ;; Compute a subject, then evaluate next against the subject + ;; cf => in Hoon + ([cons 7 (cons (var subject^) (var next))] + (let + [(subject (recur-on-noun subject subject^))] + (if (not (= 0 (car subject))) + subject + (recur-on-noun subject next)))) + ;; Compute a value, then cons it onto the subject + ;; cf =+ in Hoon + ([cons 8 (cons (var head) (var next))] + (let + [(head (recur-on-noun subject head))] + (if (not (= 0 (car head))) + head + (recur-on-noun (cons head subject) next)))) + ;; Compute a core, then call an arm of the core with the core as the subject + ([cons 9 (cons (var axis) (var core))] + (let + [(core (recur-on-noun subject core))] + (if (not (= 0 (car core))) + core + (let + [(arm (frag axis (cdr core)))] + (if (equal? 0 arm) + (cons 2 trace) + (recur-on-noun (cdr core) (cdr arm))))))) + ;; Evaluate a noun 'target', then replace the subnoun at the given axis + ;; with the noun 'value' + ([cons 10 (cons (cons (var axis) (var value)) (var target))] + (if (= 0 axis) + (cons 2 trace) + (let + [(target (recur-on-noun subject target))] + (if (not (= 0 (car target))) + target + (let + [(value (recur-on-noun subject value))] + (if (not (= 0 (car value))) + value + (let + [(mutant (edit axis (cdr target) (cdr value)))] + (if (= 0 mutant) + (cons 2 trace) + (cons 0 (cdr mutant)))))))))) + ;; Dynamic hint: compute and a hint, fail if hint computation fails + ;; If hint succeeds discard result and compute 'next' + ([cons 11 (cons (cons (var tag) (var clue)) (var next))] + (let + [(clue (recur-on-noun subject clue gates))] + (if (not (= 0 (car clue))) + clue + (if (member tag (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (recur-on-noun-with-hint subject next (cons tag (cdr clue))) + (recur-on-noun subject next))))) + ;; Static hint, discard hint and compute 'next' + ([cons 11 (cons (var tag) (var next))] + (recur-on-noun subject next)) + ;; Call a gate in the sky + ;; + ;; Compute 'ref' and 'path', + ;; then pop the top gate from the scry gate stack and + ;; slam it with [ref path] + ([cons 12 (cons (var ref) (var path))] + (let + [(ref (recur-on-noun subject ref))] + (if (not (= 0 (car ref))) + ref + (let + [(path (recur-on-noun subject path))] + (if (not (= 0 (car path))) + path + (let + [(result (recur-on-top-gate (cdr ref) (cdr path)))] + (if (not (= 0 (car result))) + result + (if (equal? 0 (cdr result)) + (cons 1 (cdr path)) + (if (equal? 0 (cdr (cdr result))) + (cons 2 (cons (cons (tas "hunk") (cons (cdr ref) (cdr path))) trace)) + (cdr (cdr (cdr result))))))))))))))) + +(define (frag axis noun) + (if (= 0 axis) + 0 + (cons 0 (if (= 1 axis) + noun + (if (even? axis) + (car (cdr (frag axis (quotient axis 2)))) + (cdr (cdr (frag axis (quotient axis 2))))))))) + +(define (mas axis) + (quotient axis 2)) + +(define (cap axis) + (if (= axis 2) + 2 + (if (= axis 3) + 3 + (cap (mas axis))))) + +(define (edit axis target value) + (if (= 1 axis) + (cons 0 value) + (if (not (pair? target)) + 0 + (let* + [(pick (cap axis)) + (mutant (edit (mas axis) (if (= 2 pick) (car target) (cdr target)) value))] + (if (= mutant 0) + 0 + (if (= 2 pick) + (cons 0 (cons (cdr mutant) (cdr target))) + (cons 0 (cons (car target) (cdr mutant))))))))) + +;; macro for %tas literals: +;; converts input string into a numeric literal of that string represented as a %tas, i.e. an +;; atom with the ascii bytes of the string in sequence (first->LSB, last->MSB) +(define-syntax (tas str) + (quasisyntax + (unsyntax + (foldr + (lambda (char atom) (bitwise-ior (bitwise-and #xFF (char->integer char)) (arithmetic-shift atom 8))) + 0 + (string->list (car (cdr (syntax->datum str)))))))) + +(define nock-here 1) +(define (nock-car address) (* address 2)) +(define (nock-cdr address) (+ 1 (* address 2))) +(define (get-0 x) (cons 0 x)) +(define (literal-1 x) (cons 1 x)) +(define (eval-2 x y) (cons 2 (cons x y))) +(define (cell?-3 x) (cons 3 x)) +(define (inc-4 x) (cons 4 x)) +(define (=-5 x y) (cons 5 (cons x y))) +(define (if-6 x y z) (cons 6 (cons x (cons y z)))) +(define (compose-7 x y) (cons 7 (cons x y))) +(define (declare-8 x y) (cons 8 (cons x y))) +(define (call-9 x y) (cons 9 (cons x y))) +(define (update-10 x y z) (cons 10 (cons (cons x y) z))) +(define (hint-11 x y) (cons 11 (cons x y))) +(define lootru 0) +(define loofal 1) + +(define test-tree (cons (cons 4 5) 3)) +(define decrement-4-core + (cons + (if-6 (=-5 (get-0 (nock-car (nock-cdr nock-here))) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here))))) + (get-0 (nock-cdr (nock-cdr nock-here))) + (call-9 (nock-car nock-here) (update-10 (nock-cdr (nock-cdr nock-here)) (inc-4 (get-0 (nock-cdr (nock-cdr nock-here)))) (get-0 nock-here)))) + (cons 4 0))) + +(check-equal? (nock-noun test-tree (get-0 nock-here)) test-tree "tree address 1") +(check-equal? (nock-noun test-tree (get-0 (nock-car nock-here))) (car test-tree) "tree address 2") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr nock-here))) (cdr test-tree) "tree address 3") +(check-equal? (nock-noun test-tree (get-0 (nock-car (nock-car nock-here)))) (car (car test-tree)) "tree address 4") +(check-equal? (nock-noun test-tree (get-0 (nock-cdr (nock-car nock-here)))) (cdr (car test-tree)) "tree address 5") +(check-equal? (nock-noun 0 (literal-1 test-tree)) test-tree "literal") +(check-equal? (nock-noun 0 (eval-2 (literal-1 test-tree) (literal-1 (get-0 2)))) (car test-tree) "eval") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 1))) lootru "test cell true") +(check-equal? (nock-noun test-tree (cell?-3 (get-0 3))) loofal "test cell false") +(check-equal? (nock-noun 0 (inc-4 (literal-1 0))) 1 "increment") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 1))) lootru "test equals true") +(check-equal? (nock-noun test-tree (=-5 (literal-1 test-tree) (get-0 2))) loofal "test equals false") +(check-equal? (nock-noun test-tree (if-6 (literal-1 lootru) (literal-1 5) (get-0 100))) 5 "test if tru") +(check-equal? (nock-noun test-tree (if-6 (literal-1 loofal) (get-0 100) (literal-1 5))) 5 "test if false") +(check-equal? (nock-noun 0 (compose-7 (literal-1 test-tree) (get-0 2))) (car test-tree) "test compose") +(check-equal? (nock-noun 0 (declare-8 (literal-1 test-tree) (get-0 2))) test-tree "test declare") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (literal-1 decrement-4-core))) 3 "test call") +(check-equal? (nock-noun 0 (update-10 (nock-cdr nock-here) (literal-1 (cons 6 7)) (literal-1 test-tree))) (cons (cons 4 5) (cons 6 7)) "test update") +(check-equal? (nock-noun 0 (call-9 (nock-car nock-here) (update-10 (nock-car (nock-cdr nock-here)) (literal-1 8) (literal-1 decrement-4-core)))) 7 "test slam i.e. update sample and call") +; test 11 static and dynamic