mirror of
https://github.com/urbit/ares.git
synced 2024-11-26 09:57:56 +03:00
initial commit
This commit is contained in:
Edward Amsden
commit
e8e3383947
64
first-pass/nock-a.rkt
Normal file
64
first-pass/nock-a.rkt
Normal file
@ -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)))
|
||||
64
first-pass/nock-b-cps.rkt
Normal file
64
first-pass/nock-b-cps.rkt
Normal file
@ -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)))
|
||||
139
first-pass/nock-c-lambda-lift.rkt
Normal file
139
first-pass/nock-c-lambda-lift.rkt
Normal file
@ -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)
|
||||
146
first-pass/nock-d-first-order-ks.rkt
Normal file
146
first-pass/nock-d-first-order-ks.rkt
Normal file
@ -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)
|
||||
233
first-pass/nock-e-registerise.rkt
Normal file
233
first-pass/nock-e-registerise.rkt
Normal file
@ -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)
|
||||
102
nock-a.rkt
Normal file
102
nock-a.rkt
Normal file
@ -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
|
||||
115
nock-b-scry.rkt
Normal file
115
nock-b-scry.rkt
Normal file
@ -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
|
||||
151
nock-c-exceptions.rkt
Normal file
151
nock-c-exceptions.rkt
Normal file
@ -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
|
||||
197
nock-d-cps.rkt
Normal file
197
nock-d-cps.rkt
Normal file
@ -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
|
||||
232
nock-e-fast-tree-edit.rkt
Normal file
232
nock-e-fast-tree-edit.rkt
Normal file
@ -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
|
||||
236
nock-f-explicit-apply.rkt
Normal file
236
nock-f-explicit-apply.rkt
Normal file
@ -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
|
||||
281
nock-g-closure-convert.rkt
Normal file
281
nock-g-closure-convert.rkt
Normal file
@ -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
|
||||
37
notes/nock.txt
Normal file
37
notes/nock.txt
Normal file
@ -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
|
||||
|
||||
122
second-pass/nock-b-optimize-edit.rkt
Normal file
122
second-pass/nock-b-optimize-edit.rkt
Normal file
@ -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
|
||||
109
second-pass/nock.rkt
Normal file
109
second-pass/nock.rkt
Normal file
@ -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
|
||||
265
third-pass/nock-a.rkt
Normal file
265
third-pass/nock-a.rkt
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user