diff --git a/nock-d-inline.rkt b/nock-d-inline.rkt new file mode 100644 index 0000000..01838f8 --- /dev/null +++ b/nock-d-inline.rkt @@ -0,0 +1,147 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (nock-noun subject (cons b c) gates err-k trace) (nock-noun subject d gates err-k trace))) + ([cons 0 (var b)] + (nock-tree-find subject b err-k trace)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (nock-noun (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace) gates err-k trace)) + ([cons 3 (var b)] + (if (pair? (nock-noun subject b gates err-k trace)) 0 1)) + ([cons 4 (var b)] + (+ 1 (nock-noun subject b gates err-k trace))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (let + [(test (nock-noun subject b gates err-k trace))] + (if (= 0 test) + (nock-noun subject c gates err-k trace) + (if (= 1 test) + (nock-noun subject d gates err-k trace) + (err-k (cons 2 trace)))))) + ([cons 7 (cons (var b) (var c))] + (nock-noun (nock-noun subject b gates err-k trace) c gates err-k trace)) + ([cons 8 (cons (var b) (var c))] + (nock-noun (cons (nock-noun subject b gates err-k trace) subject) c gates err-k trace)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (nock-noun subject c gates err-k trace)]) + (nock-noun core (nock-tree-find core b err-k trace) gates err-k trace))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (nock-noun subject c gates err-k trace) b (nock-noun subject d gates err-k trace) err-k trace)) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + [(clue (nock-noun subject c))] + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (nock-noun subject d gates err-k (cons (cons b clue) trace)) + (nock-noun subject d gates err-k trace)))) + ([cons 11 (cons (var b) (var c))] + (nock-noun subject c gates err-k trace)) + ([cons 12 (cons (var ref) (var path))] + (let* + [(ref (nock-noun subject ref gates err-k trace)) + (path (nock-noun subject path gates err-k trace)) + (gate (car (car gates))) + (outer-err-k err-k) + (err-k (car (cdr (car gates)))) + (trace (cdr (cdr (car gates)))) + (outer-trace trace) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate))))) + (result (nock-noun core (car core) gates err-k trace))] + (if (equal? 0 result) + ; ~ + (outer-err-k (cons 1 (cdr path))) + (if (equal? 0 (car result)) + (outer-err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) outer-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-e-optimize-edit.rkt b/nock-e-optimize-edit.rkt new file mode 100644 index 0000000..0c6a89f --- /dev/null +++ b/nock-e-optimize-edit.rkt @@ -0,0 +1,160 @@ +#lang racket + +(require rackunit) + +(define (nock-noun subject formula gates err-k trace) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (cons (nock-noun subject (cons b c) gates err-k trace) (nock-noun subject d gates err-k trace))) + ([cons 0 (var b)] + (nock-tree-find subject b err-k trace)) + ([cons 1 (var b)] + b) + ([cons 2 (cons (var b) (var c))] + (nock-noun (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace) gates err-k trace)) + ([cons 3 (var b)] + (if (pair? (nock-noun subject b gates err-k trace)) 0 1)) + ([cons 4 (var b)] + (+ 1 (nock-noun subject b gates err-k trace))) + ([cons 5 (cons (var b) (var c))] + (if (eqv? (nock-noun subject b gates err-k trace) (nock-noun subject c gates err-k trace)) 0 1)) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (let + [(test (nock-noun subject b gates err-k trace))] + (if (= 0 test) + (nock-noun subject c gates err-k trace) + (if (= 1 test) + (nock-noun subject d gates err-k trace) + (err-k (cons 2 trace)))))) + ([cons 7 (cons (var b) (var c))] + (nock-noun (nock-noun subject b gates err-k trace) c gates err-k trace)) + ([cons 8 (cons (var b) (var c))] + (nock-noun (cons (nock-noun subject b gates err-k trace) subject) c gates err-k trace)) + ([cons 9 (cons (var b) (var c))] + (let + ([core (nock-noun subject c gates err-k trace)]) + (nock-noun core (nock-tree-find core b err-k trace) gates err-k trace))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-tree-edit (nock-noun subject c gates err-k trace) b (nock-noun subject d gates err-k trace) err-k trace)) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (let + [(clue (nock-noun subject c))] + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (nock-noun subject d gates err-k (cons (cons b clue) trace)) + (nock-noun subject d gates err-k trace)))) + ([cons 11 (cons (var b) (var c))] + (nock-noun subject c gates err-k trace)) + ([cons 12 (cons (var ref) (var path))] + (let* + [(ref (nock-noun subject ref gates err-k trace)) + (path (nock-noun subject path gates err-k trace)) + (gate (car (car gates))) + (outer-err-k err-k) + (err-k (car (cdr (car gates)))) + (outer-trace trace) + (trace (cdr (cdr (car gates)))) + (gates (cdr gates)) + (core (cons (car gate) (cons (cons ref path) (cdr (cdr gate))))) + (result (nock-noun core (car core) gates err-k trace))] + (if (equal? 0 result) + ; ~ + (outer-err-k (cons 1 (cdr path))) + (if (equal? 0 (car result)) + (outer-err-k (cons 2 (cons (cons (tas "hunk") (cons ref path)) outer-trace))) + (cdr (cdr result)))))))) + +(define (reverse-address address) (reverse-address-acc address 1)) + +(define (reverse-address-acc address reversed) + (if (= address 1) + reversed + (reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1))))) + +(define (nock-tree-find-reversed tree reversed) + (if (= reversed 1) + tree + (if (even? reversed) + (nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1)) + (nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1))))) + +(define (nock-tree-find tree address err-k trace) + (if (= address 0) + (err-k (cons 2 trace)) + (nock-tree-find-reversed tree (reverse-address address)))) + +(define (nock-tree-edit-reversed subtree reversed tree) + (if (= reversed 1) + subtree + (if (even? reversed) + (cons (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree)) (cdr tree)) + (cons (car tree) (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree)))))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree err-k trace) + (if (= address 0) + (err-k (cons 2 trace)) + (nock-tree-edit-reversed subtree (reverse-address address) tree))) + +;; 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-cps.rkt b/nock-f-cps.rkt new file mode 100644 index 0000000..f1e9d69 --- /dev/null +++ b/nock-f-cps.rkt @@ -0,0 +1,203 @@ +#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) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (nock-noun-cps subject (cons b c) gates err-k trace + (lambda (u) + (nock-noun-cps subject d gates err-k trace + (lambda (v) + (k (cons u v))))))) + ([cons 0 (var b)] + (nock-tree-find subject b err-k trace k)) + ([cons 1 (var b)] + (k b)) + ([cons 2 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps subject c gates err-k trace + (lambda (v) + (nock-noun-cps u v gates err-k trace k)))))) + ([cons 3 (var b)] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (if (pair? u) + (k 0) + (k 1))))) + ([cons 4 (var b)] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (k (+ 1 u))))) + ([cons 5 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps subject c gates err-k trace + (lambda (v) + (if (eqv? u v) + (k 0) + (k 1))))))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (if (= 0 u) + (nock-noun-cps subject c gates err-k trace k) + (if (= 1 u) + (nock-noun-cps subject d gates err-k trace k) + (err-k (cons 2 trace))))))) + ([cons 7 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps u c gates err-k trace k)))) + ([cons 8 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps (cons u subject) c gates err-k trace k)))) + ([cons 9 (cons (var b) (var c))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (nock-tree-find u b err-k trace + (lambda (v) + (nock-noun-cps u v gates err-k trace k)))))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (nock-noun-cps subject d gates err-k trace + (lambda (v) + (nock-tree-edit u b v err-k trace k)))))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (nock-noun-cps subject d gates err-k (cons (cons b u) trace) k) + (nock-noun-cps subject d gates err-k trace k))))) + ([cons 11 (cons (var b) (var c))] + (nock-noun-cps subject c gates err-k trace k)) + ([cons 12 (cons (var ref) (var path))] + (nock-noun-cps subject ref gates err-k trace + (lambda (u) + (nock-noun-cps subject path gates err-k trace + (lambda (v) + (let* + [(gate (car (car gates))) + (outer-err-k err-k) + (err-k (car (cdr (car gates)))) + (outer-trace trace) + (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 + (lambda (w) + (if (equal? 0 w) + ; ~ + (outer-err-k (cons 1 (cdr v))) + (if (equal? 0 (car w)) + (outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) (outer-trace trace)))) + (k (cdr (cdr w))))))))))))))) + +(define (reverse-address address k) (reverse-address-acc address 1 k)) + +(define (reverse-address-acc address reversed k) + (if (= address 1) + (k reversed) + (reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)) k))) + +(define (nock-tree-find-reversed tree reversed k) + (if (= reversed 1) + (k tree) + (if (even? reversed) + (nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1) k) + (nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1) k)))) + +(define (nock-tree-find tree address err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (reverse-address address (lambda (u) + (nock-tree-find-reversed tree u k))))) + +(define (nock-tree-edit-reversed subtree reversed tree k) + (if (= reversed 1) + (k subtree) + (if (even? reversed) + (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree) (lambda (u) + (k (cons u (cdr tree))))) + (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree) (lambda (u) + (k (cons (car tree) u))))))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree err-k trace k) + (if (= address 0) + (err-k (cons 2 trace)) + (reverse-address address + (lambda (u) + (nock-tree-edit-reversed subtree u tree k))))) + +(define (empty-k v) v) + +;; 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-explicit-apply.rkt b/nock-g-explicit-apply.rkt new file mode 100644 index 0000000..7dda9f9 --- /dev/null +++ b/nock-g-explicit-apply.rkt @@ -0,0 +1,206 @@ +#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) + (match formula + ([cons (cons (var b) (var c)) (var d)] + (nock-noun-cps subject (cons b c) gates err-k trace + (lambda (u) + (nock-noun-cps subject d gates err-k trace + (lambda (v) + (apply-k k (cons u v))))))) + ([cons 0 (var b)] + (nock-tree-find subject b err-k trace k)) + ([cons 1 (var b)] + (apply-k k b)) + ([cons 2 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps subject c gates err-k trace + (lambda (v) + (nock-noun-cps u v gates err-k trace k)))))) + ([cons 3 (var b)] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (if (pair? u) + (apply-k k 0) + (apply-k k 1))))) + ([cons 4 (var b)] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (apply-k k (+ 1 u))))) + ([cons 5 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps subject c gates err-k trace + (lambda (v) + (if (eqv? u v) + (apply-k k 0) + (apply-k k 1))))))) + ([cons 6 (cons (var b) (cons (var c) (var d)))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (if (= 0 u) + (nock-noun-cps subject c gates err-k trace k) + (if (= 1 u) + (nock-noun-cps subject d gates err-k trace k) + (apply-err-k err-k (cons 2 trace))))))) + ([cons 7 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps u c gates err-k trace k)))) + ([cons 8 (cons (var b) (var c))] + (nock-noun-cps subject b gates err-k trace + (lambda (u) + (nock-noun-cps (cons u subject) c gates err-k trace k)))) + ([cons 9 (cons (var b) (var c))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (nock-tree-find u b err-k trace + (lambda (v) + (nock-noun-cps u v gates err-k trace k)))))) + ([cons 10 (cons (cons (var b) (var c)) (var d))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (nock-noun-cps subject d gates err-k trace + (lambda (v) + (nock-tree-edit u b v err-k trace k)))))) + ([cons 11 (cons (cons (var b) (var c)) (var d))] + (nock-noun-cps subject c gates err-k trace + (lambda (u) + (if (member b (list (tas "hunk") (tas "hand") (tas "lose") (tas "mean") (tas "spot"))) + (nock-noun-cps subject d gates err-k (cons (cons b u) trace) k) + (nock-noun-cps subject d gates err-k trace k))))) + ([cons 11 (cons (var b) (var c))] + (nock-noun-cps subject c gates err-k trace k)) + ([cons 12 (cons (var ref) (var path))] + (nock-noun-cps subject ref gates err-k trace + (lambda (u) + (nock-noun-cps subject path gates err-k trace + (lambda (v) + (let* + [(gate (car (car gates))) + (outer-err-k err-k) + (err-k (car (cdr (car gates)))) + (outer-trace trace) + (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 + (lambda (w) + (if (equal? 0 w) + ; ~ + (outer-err-k (cons 1 (cdr v))) + (if (equal? 0 (car w)) + (outer-err-k (cons 2 (cons (cons (tas "hunk") (cons u v)) outer-trace))) + (apply-k k (cdr (cdr w))))))))))))))) + +(define (reverse-address address k) (reverse-address-acc address 1 k)) + +(define (reverse-address-acc address reversed k) + (if (= address 1) + (apply-k k reversed) + (reverse-address-acc (arithmetic-shift address -1) (bitwise-ior (arithmetic-shift reversed 1) (bitwise-and address 1)) k))) + +(define (nock-tree-find-reversed tree reversed k) + (if (= reversed 1) + (apply-k k tree) + (if (even? reversed) + (nock-tree-find-reversed (car tree) (arithmetic-shift reversed -1) k) + (nock-tree-find-reversed (cdr tree) (arithmetic-shift reversed -1) k)))) + +(define (nock-tree-find tree address err-k trace k) + (if (= address 0) + (apply-err-k err-k (cons 2 trace)) + (reverse-address address (lambda (u) + (nock-tree-find-reversed tree u k))))) + +(define (nock-tree-edit-reversed subtree reversed tree k) + (if (= reversed 1) + (apply-k k subtree) + (if (even? reversed) + (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (car tree) (lambda (u) + (apply-k k (cons u (cdr tree))))) + (nock-tree-edit-reversed subtree (arithmetic-shift reversed -1) (cdr tree) (lambda (u) + (apply-k k (cons (car tree) u))))))) + +; # operator in nock spec: tree editing +(define (nock-tree-edit subtree address tree err-k trace k) + (if (= address 0) + (apply-err-k err-k (cons 2 trace)) + (reverse-address address + (lambda (u) + (nock-tree-edit-reversed subtree u tree k))))) + +(define (empty-k v) v) + +(define (apply-k k x) (k x)) +(define (apply-err-k err-k err) (err-k err)) + +;; 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