suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

changing conform to work with the prototype

Browse Source
This commit is contained in:
Danny Yoo 2011-03-14 15:52:26 -04:00
parent 3d01f0d788
commit b5f7845a0e
2 changed files with 11 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
expanding.rkt → racket-expander.rkt
View File

22
tests/conform/program0.sch
View File

@ -86,7 +86,7 @@
(define set-internal-node-red-edges! (lambda (node edges) (vector-set! node '2 edges))) (define set-internal-node-red-edges! (lambda (node edges) (vector-set! node '2 edges)))
(define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges))) (define set-internal-node-blue-edges! (lambda (node edges) (vector-set! node '3 edges)))
(define make-node (define make-node
(lambda (name . blue-edges) (lambda (name blue-edges)
(let ((name (if (symbol? name) (symbol->string name) name)) (let ((name (if (symbol? name) (symbol->string name) name))
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges)))) (blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
(make-internal-node name '() '() blue-edges)))) (make-internal-node name '() '() blue-edges))))
@ -137,7 +137,7 @@
(define internal-graph-already-met (lambda (graph) (vector-ref graph '1))) (define internal-graph-already-met (lambda (graph) (vector-ref graph '1)))
(define internal-graph-already-joined (lambda (graph) (vector-ref graph '2))) (define internal-graph-already-joined (lambda (graph) (vector-ref graph '2)))
(define set-internal-graph-nodes! (lambda (graph nodes) (vector-set! graph '0 nodes))) (define set-internal-graph-nodes! (lambda (graph nodes) (vector-set! graph '0 nodes)))
(define make-graph (lambda nodes (make-internal-graph nodes (make-empty-table) (make-empty-table)))) (define make-graph (lambda (nodes) (make-internal-graph nodes (make-empty-table) (make-empty-table))))
(define graph-nodes internal-graph-nodes) (define graph-nodes internal-graph-nodes)
(define already-met internal-graph-already-met) (define already-met internal-graph-already-met)
(define already-joined internal-graph-already-joined) (define already-joined internal-graph-already-joined)
@ -211,9 +211,9 @@
(map (lambda (class) (fix (car class))) classes) (map (lambda (class) (fix (car class))) classes)
(fix-table (already-met graph)) (fix-table (already-met graph))
(fix-table (already-joined graph)))))) (fix-table (already-joined graph))))))
(define none-node (make-node 'none '#t)) (define none-node (make-node 'none '(#t)))
(define none-node? (lambda (node) (eq? node none-node))) (define none-node? (lambda (node) (eq? node none-node)))
(define any-node (make-node 'any '())) (define any-node (make-node 'any ('())))
(define any-node? (lambda (node) (eq? node any-node))) (define any-node? (lambda (node) (eq? node any-node)))
(define green-edge? (define green-edge?
(lambda (from-node to-node) (lambda (from-node to-node)
@ -345,7 +345,7 @@
(if (conforms? node2 node1) (if (conforms? node2 node1)
(begin node1) (begin node1)
(begin (begin
(let ((result (make-node (string-append '"(" (name node1) '" ^ " (name node2) '")")))) (let ((result (make-node (string-append '"(" (name node1) '" ^ " (name node2) '")") '())))
(add-graph-nodes! graph result) (add-graph-nodes! graph result)
(insert! (already-met graph) node1 node2 result) (insert! (already-met graph) node1 node2 result)
(set-blue-edges! (set-blue-edges!
@ -404,7 +404,7 @@
(begin (begin
(if print? (begin (display '" -> ") (display new-count) (newline)) (void)) (if print? (begin (display '" -> ") (display new-count) (newline)) (void))
(loop new-g new-count))))))))) (loop new-g new-count)))))))))
(let ((graph (apply make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))) (let ((graph (apply make-graph (list (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g))))))))
(loop graph (length (graph-nodes graph))))))) (loop graph (length (graph-nodes graph)))))))
(define a '()) (define a '())
(define b '()) (define b '())
@ -412,17 +412,17 @@
(define d '()) (define d '())
(define reset (define reset
(lambda () (lambda ()
(set! a (make-node 'a)) (set! a (make-node 'a '()))
(set! b (make-node 'b)) (set! b (make-node 'b '()))
(set-blue-edges! a (list (make-blue-edge 'phi any-node b))) (set-blue-edges! a (list (make-blue-edge 'phi any-node b)))
(set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b))) (set-blue-edges! b (list (make-blue-edge 'phi any-node a) (make-blue-edge 'theta any-node b)))
(set! c (make-node '"c")) (set! c (make-node '"c" '()))
(set! d (make-node '"d")) (set! d (make-node '"d" '()))
(set-blue-edges! c (list (make-blue-edge 'theta any-node b))) (set-blue-edges! c (list (make-blue-edge 'theta any-node b)))
(set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d))) (set-blue-edges! d (list (make-blue-edge 'phi any-node c) (make-blue-edge 'theta any-node d)))
'(made a b c d))) '(made a b c d)))
(define test (define test
(lambda () (reset) (map name (graph-nodes (make-lattice (make-graph a b c d any-node none-node) '#t))))) (lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t)))))
(define go (define go
(lambda () (lambda ()
(reset) (reset)