correcting hash-keys hash-values namespace issue
This commit is contained in:
Danny Yoo
parent
86e584b983
commit
005fa3f762
4
Makefile
4
Makefile
|
|
@ -44,8 +44,8 @@ cs019-doc:
|
|||
|
||||
|
||||
setup:
|
||||
raco setup --no-docs -P dyoo whalesong.plt 1 6
|
||||
raco setup --no-docs -P dyoo whalesong.plt 1 7
|
||||
|
||||
|
||||
planet-link:
|
||||
raco planet link dyoo whalesong.plt 1 6 .
|
||||
raco planet link dyoo whalesong.plt 1 7 .
|
||||
|
|
@ -170,8 +170,6 @@
|
|||
hash-remove
|
||||
equal-hash-code
|
||||
hash-count
|
||||
hash-keys
|
||||
hash-values
|
||||
|
||||
|
||||
;; Kernel inlinable
|
||||
|
|
@ -511,6 +509,8 @@ symbol->string
|
|||
|
||||
|
||||
hash-has-key?
|
||||
hash-keys
|
||||
hash-values
|
||||
)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(if (null? keys)
|
||||
'()
|
||||
(cons (f (car keys) (hash-ref a-hash (car keys)))
|
||||
(loop (rest keys))))))
|
||||
(loop (cdr keys))))))
|
||||
|
||||
|
||||
(define (hash-for-each a-hash f)
|
||||
|
|
@ -24,6 +24,6 @@
|
|||
(void)
|
||||
(begin
|
||||
(f (car keys) (hash-ref a-hash (car keys)))
|
||||
(loop (rest keys))))))
|
||||
(loop (cdr keys))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#!/bin/bash
|
||||
MAJOR=1
|
||||
MINOR=6
|
||||
MINOR=7
|
||||
PROJNAME=whalesong
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +0,0 @@
|
|||
6 -> 26 -> 16
|
||||
16 -> 132 -> 30
|
||||
30 -> 374 -> 31
|
||||
31 -> 119
|
||||
ok.
|
||||
|
|
@ -1,516 +0,0 @@
|
|||
(let ()
|
||||
|
||||
;; (define (caar l)
|
||||
;; (car (car l)))
|
||||
|
||||
;; (define (map f l)
|
||||
;; (if (null? l)
|
||||
;; null
|
||||
;; (cons (f (car l))
|
||||
;; (map f (cdr l)))))
|
||||
|
||||
;; (define (for-each f l)
|
||||
;; (if (null? l)
|
||||
;; null
|
||||
;; (begin (f (car l))
|
||||
;; (for-each f (cdr l)))))
|
||||
|
||||
;; (define (memq x l)
|
||||
;; (if (null? l)
|
||||
;; #f
|
||||
;; (if (eq? x (car l))
|
||||
;; l
|
||||
;; (memq x (cdr l)))))
|
||||
|
||||
|
||||
;; (define (assq x l)
|
||||
;; (if (null? l)
|
||||
;; #f
|
||||
;; (if (eq? x (caar l))
|
||||
;; (car l)
|
||||
;; (assq x (cdr l)))))
|
||||
|
||||
|
||||
;; (define (length l)
|
||||
;; (if (null? l)
|
||||
;; 0
|
||||
;; (add1 (length (cdr l)))))
|
||||
|
||||
|
||||
;; (define (append l1 l2)
|
||||
;; (if (nullb? l1)
|
||||
;; l2
|
||||
;; (cons (car l1) (append (cdr l1) l2))))
|
||||
|
||||
|
||||
(define vector-copy
|
||||
(lambda (v)
|
||||
(let ((length (vector-length v)))
|
||||
(let ((result (make-vector length)))
|
||||
((letrec ((loop
|
||||
(lambda (n) (vector-set! result n (vector-ref v n)) (if (= n length) v (loop (+ n '1))))))
|
||||
loop)
|
||||
'0)))))
|
||||
(define sort
|
||||
(lambda (obj pred)
|
||||
(letrec ((loop (lambda (l) (if (if (pair? l) (pair? (cdr l)) '#f) (split l '() '()) l)))
|
||||
(split
|
||||
(lambda (l one two)
|
||||
(if (pair? l) (split (cdr l) two (cons (car l) one)) (merge (loop one) (loop two)))))
|
||||
(merge
|
||||
(lambda (one two)
|
||||
(if (null? one)
|
||||
(begin two)
|
||||
(if (pred (car two) (car one))
|
||||
(begin (cons (car two) (merge (cdr two) one)))
|
||||
(begin (cons (car one) (merge (cdr one) two))))))))
|
||||
(if (let ((or-part (pair? obj))) (if or-part or-part (null? obj)))
|
||||
(begin (loop obj))
|
||||
(if (vector? obj)
|
||||
(begin (sort! (vector-copy obj) pred))
|
||||
(begin (error '"sort: argument should be a list or vector" obj)))))))
|
||||
(define sort!
|
||||
(lambda (v pred)
|
||||
(letrec ((sort-internal!
|
||||
(lambda (vec temp low high)
|
||||
(if (< low high)
|
||||
(let ((middle (quotient (+ low high) '2)))
|
||||
(let ((next (+ middle '1)))
|
||||
(sort-internal! temp vec low middle)
|
||||
(sort-internal! temp vec next high)
|
||||
((letrec ((loop
|
||||
(lambda (p p1 p2)
|
||||
(if (not (> p high))
|
||||
(if (> p1 middle)
|
||||
(begin
|
||||
(vector-set! vec p (vector-ref temp p2))
|
||||
(loop (+ p '1) p1 (+ p2 '1)))
|
||||
(if (let ((or-part (> p2 high)))
|
||||
(if or-part
|
||||
or-part
|
||||
(pred (vector-ref temp p1) (vector-ref temp p2))))
|
||||
(begin
|
||||
(vector-set! vec p (vector-ref temp p1))
|
||||
(loop (+ p '1) (+ p1 '1) p2))
|
||||
(begin
|
||||
(vector-set! vec p (vector-ref temp p2))
|
||||
(loop (+ p '1) p1 (+ p2 '1)))))
|
||||
(void)))))
|
||||
loop)
|
||||
low
|
||||
low
|
||||
next)))
|
||||
(void)))))
|
||||
(if (not (vector? v)) (error '"sort!: argument not a vector" v) (void))
|
||||
(sort-internal! v (vector-copy v) '0 (- (vector-length v) '1))
|
||||
v)))
|
||||
(define adjoin (lambda (element set) (if (memq element set) set (cons element set))))
|
||||
(define eliminate
|
||||
(lambda (element set)
|
||||
(if (null? set)
|
||||
(begin set)
|
||||
(if (eq? element (car set)) (begin (cdr set)) (begin (cons (car set) (eliminate element (cdr set))))))))
|
||||
(define intersect
|
||||
(lambda (list1 list2)
|
||||
((letrec ((loop
|
||||
(lambda (l)
|
||||
(if (null? l)
|
||||
(begin '())
|
||||
(if (memq (car l) list2) (begin (cons (car l) (loop (cdr l)))) (begin (loop (cdr l))))))))
|
||||
loop)
|
||||
list1)))
|
||||
(define union (lambda (list1 list2) (if (null? list1) list2 (union (cdr list1) (adjoin (car list1) list2)))))
|
||||
(define make-internal-node vector)
|
||||
(define internal-node-name (lambda (node) (vector-ref node '0)))
|
||||
(define internal-node-green-edges (lambda (node) (vector-ref node '1)))
|
||||
(define internal-node-red-edges (lambda (node) (vector-ref node '2)))
|
||||
(define internal-node-blue-edges (lambda (node) (vector-ref node '3)))
|
||||
(define set-internal-node-name! (lambda (node name) (vector-set! node '0 name)))
|
||||
(define set-internal-node-green-edges! (lambda (node edges) (vector-set! node '1 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 make-node
|
||||
(lambda (name blue-edges)
|
||||
(let ((name (if (symbol? name) (symbol->string name) name))
|
||||
(blue-edges (if (null? blue-edges) 'NOT-A-NODE-YET (car blue-edges))))
|
||||
(make-internal-node name '() '() blue-edges))))
|
||||
(define copy-node (lambda (node) (make-internal-node (name node) '() '() (blue-edges node))))
|
||||
(define name internal-node-name)
|
||||
(define make-edge-getter
|
||||
(lambda (selector)
|
||||
(lambda (node)
|
||||
(if (let ((or-part (none-node? node))) (if or-part or-part (any-node? node)))
|
||||
(error '"Can't get edges from the ANY or NONE nodes")
|
||||
(selector node)))))
|
||||
(define red-edges (make-edge-getter internal-node-red-edges))
|
||||
(define green-edges (make-edge-getter internal-node-green-edges))
|
||||
(define blue-edges (make-edge-getter internal-node-blue-edges))
|
||||
(define make-edge-setter
|
||||
(lambda (mutator!)
|
||||
(lambda (node value)
|
||||
(if (any-node? node)
|
||||
(begin (error '"Can't set edges from the ANY node"))
|
||||
(if (none-node? node) (begin 'OK) (begin (mutator! node value)))))))
|
||||
(define set-red-edges! (make-edge-setter set-internal-node-red-edges!))
|
||||
(define set-green-edges! (make-edge-setter set-internal-node-green-edges!))
|
||||
(define set-blue-edges! (make-edge-setter set-internal-node-blue-edges!))
|
||||
(define make-blue-edge vector)
|
||||
(define blue-edge-operation (lambda (edge) (vector-ref edge '0)))
|
||||
(define blue-edge-arg-node (lambda (edge) (vector-ref edge '1)))
|
||||
(define blue-edge-res-node (lambda (edge) (vector-ref edge '2)))
|
||||
(define set-blue-edge-operation! (lambda (edge value) (vector-set! edge '0 value)))
|
||||
(define set-blue-edge-arg-node! (lambda (edge value) (vector-set! edge '1 value)))
|
||||
(define set-blue-edge-res-node! (lambda (edge value) (vector-set! edge '2 value)))
|
||||
(define operation blue-edge-operation)
|
||||
(define arg-node blue-edge-arg-node)
|
||||
(define res-node blue-edge-res-node)
|
||||
(define set-arg-node! set-blue-edge-arg-node!)
|
||||
(define set-res-node! set-blue-edge-res-node!)
|
||||
(define lookup-op
|
||||
(lambda (op node)
|
||||
((letrec ((loop
|
||||
(lambda (edges)
|
||||
(if (null? edges)
|
||||
(begin '())
|
||||
(if (eq? op (operation (car edges))) (begin (car edges)) (begin (loop (cdr edges))))))))
|
||||
loop)
|
||||
(blue-edges node))))
|
||||
(define has-op? (lambda (op node) (not (null? (lookup-op op node)))))
|
||||
(define make-internal-graph vector)
|
||||
(define internal-graph-nodes (lambda (graph) (vector-ref graph '0)))
|
||||
(define internal-graph-already-met (lambda (graph) (vector-ref graph '1)))
|
||||
(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 make-graph (lambda (nodes) (make-internal-graph nodes (make-empty-table) (make-empty-table))))
|
||||
(define graph-nodes internal-graph-nodes)
|
||||
(define already-met internal-graph-already-met)
|
||||
(define already-joined internal-graph-already-joined)
|
||||
(define add-graph-nodes!
|
||||
(lambda (graph nodes) (set-internal-graph-nodes! graph (cons nodes (graph-nodes graph)))))
|
||||
(define copy-graph
|
||||
(lambda (g)
|
||||
(letrec ((copy-list (lambda (l) (vector->list (list->vector l)))))
|
||||
(make-internal-graph (copy-list (graph-nodes g)) (already-met g) (already-joined g)))))
|
||||
(define clean-graph
|
||||
(lambda (g)
|
||||
(letrec ((clean-node
|
||||
(lambda (node)
|
||||
(if (not (let ((or-part (any-node? node))) (if or-part or-part (none-node? node))))
|
||||
(begin (set-green-edges! node '()) (set-red-edges! node '()))
|
||||
(void)))))
|
||||
(for-each clean-node (graph-nodes g))
|
||||
g)))
|
||||
(define canonicalize-graph
|
||||
(lambda (graph classes)
|
||||
(letrec ((fix
|
||||
(lambda (node)
|
||||
(letrec ((fix-set
|
||||
(lambda (object selector mutator)
|
||||
(mutator
|
||||
object
|
||||
(map
|
||||
(lambda (node) (find-canonical-representative node classes))
|
||||
(selector object))))))
|
||||
(if (not (let ((or-part (none-node? node))) (if or-part or-part (any-node? node))))
|
||||
(begin
|
||||
(fix-set node green-edges set-green-edges!)
|
||||
(fix-set node red-edges set-red-edges!)
|
||||
(for-each
|
||||
(lambda (blue-edge)
|
||||
(set-arg-node! blue-edge (find-canonical-representative (arg-node blue-edge) classes))
|
||||
(set-res-node! blue-edge (find-canonical-representative (res-node blue-edge) classes)))
|
||||
(blue-edges node)))
|
||||
(void))
|
||||
node)))
|
||||
(fix-table
|
||||
(lambda (table)
|
||||
(letrec ((canonical? (lambda (node) (eq? node (find-canonical-representative node classes))))
|
||||
(filter-and-fix
|
||||
(lambda (predicate-fn update-fn list)
|
||||
((letrec ((loop
|
||||
(lambda (list)
|
||||
(if (null? list)
|
||||
(begin '())
|
||||
(if (predicate-fn (car list))
|
||||
(begin (cons (update-fn (car list)) (loop (cdr list))))
|
||||
(begin (loop (cdr list))))))))
|
||||
loop)
|
||||
list)))
|
||||
(fix-line
|
||||
(lambda (line)
|
||||
(filter-and-fix
|
||||
(lambda (entry) (canonical? (car entry)))
|
||||
(lambda (entry)
|
||||
(cons (car entry) (find-canonical-representative (cdr entry) classes)))
|
||||
line))))
|
||||
(if (null? table)
|
||||
'()
|
||||
(cons
|
||||
(car table)
|
||||
(filter-and-fix
|
||||
(lambda (entry) (canonical? (car entry)))
|
||||
(lambda (entry) (cons (car entry) (fix-line (cdr entry))))
|
||||
(cdr table))))))))
|
||||
(make-internal-graph
|
||||
(map (lambda (class) (fix (car class))) classes)
|
||||
(fix-table (already-met graph))
|
||||
(fix-table (already-joined graph))))))
|
||||
|
||||
|
||||
|
||||
(define none-node (make-node 'none '(#t)))
|
||||
(define none-node? (lambda (node) (eq? node none-node)))
|
||||
(define any-node (make-node 'any '(())))
|
||||
(define any-node? (lambda (node) (eq? node any-node)))
|
||||
(define green-edge?
|
||||
(lambda (from-node to-node)
|
||||
(if (any-node? from-node)
|
||||
(begin '#f)
|
||||
(if (none-node? from-node)
|
||||
(begin '#t)
|
||||
(if (memq to-node (green-edges from-node)) (begin '#t) (begin '#f))))))
|
||||
(define red-edge?
|
||||
(lambda (from-node to-node)
|
||||
(if (any-node? from-node)
|
||||
(begin '#f)
|
||||
(if (none-node? from-node)
|
||||
(begin '#t)
|
||||
(if (memq to-node (red-edges from-node)) (begin '#t) (begin '#f))))))
|
||||
(define sig
|
||||
(let ((none-comma-any (cons none-node any-node)))
|
||||
(lambda (op node)
|
||||
(let ((the-edge (lookup-op op node)))
|
||||
(if (not (null? the-edge)) (cons (arg-node the-edge) (res-node the-edge)) none-comma-any)))))
|
||||
(define arg (lambda (pair) (car pair)))
|
||||
(define res (lambda (pair) (cdr pair)))
|
||||
(define conforms?
|
||||
(lambda (t1 t2)
|
||||
(letrec ((nodes-with-red-edges-out '())
|
||||
(add-red-edge!
|
||||
(lambda (from-node to-node)
|
||||
(set-red-edges! from-node (adjoin to-node (red-edges from-node)))
|
||||
(set! nodes-with-red-edges-out (adjoin from-node nodes-with-red-edges-out))))
|
||||
(greenify-red-edges!
|
||||
(lambda (from-node)
|
||||
(set-green-edges! from-node (append (red-edges from-node) (green-edges from-node)))
|
||||
(set-red-edges! from-node '())))
|
||||
(delete-red-edges! (lambda (from-node) (set-red-edges! from-node '())))
|
||||
(does-conform
|
||||
(lambda (t1 t2)
|
||||
(if (let ((or-part (none-node? t1))) (if or-part or-part (any-node? t2)))
|
||||
(begin '#t)
|
||||
(if (let ((or-part (any-node? t1))) (if or-part or-part (none-node? t2)))
|
||||
(begin '#f)
|
||||
(if (green-edge? t1 t2)
|
||||
(begin '#t)
|
||||
(if (red-edge? t1 t2)
|
||||
(begin '#t)
|
||||
(begin
|
||||
(add-red-edge! t1 t2)
|
||||
((letrec ((loop
|
||||
(lambda (blues)
|
||||
(if (null? blues)
|
||||
'#t
|
||||
(let ((current-edge (car blues)))
|
||||
(let ((phi (operation current-edge)))
|
||||
(if (has-op? phi t1)
|
||||
(if (does-conform (res (sig phi t1)) (res (sig phi t2)))
|
||||
(if (does-conform (arg (sig phi t2)) (arg (sig phi t1)))
|
||||
(loop (cdr blues))
|
||||
'#f)
|
||||
'#f)
|
||||
'#f)))))))
|
||||
loop)
|
||||
(blue-edges t2))))))))))
|
||||
(let ((result (does-conform t1 t2)))
|
||||
(for-each (if result greenify-red-edges! delete-red-edges!) nodes-with-red-edges-out)
|
||||
result))))
|
||||
(define equivalent? (lambda (a b) (if (conforms? a b) (conforms? b a) '#f)))
|
||||
(define classify
|
||||
(lambda (nodes)
|
||||
((letrec ((node-loop
|
||||
(lambda (classes nodes)
|
||||
(if (null? nodes)
|
||||
(map
|
||||
(lambda (class)
|
||||
(sort
|
||||
class
|
||||
(lambda (node1 node2) (< (string-length (name node1)) (string-length (name node2))))))
|
||||
classes)
|
||||
(let ((this-node (car nodes)))
|
||||
(letrec ((add-node
|
||||
(lambda (classes)
|
||||
(if (null? classes)
|
||||
(begin (list (list this-node)))
|
||||
(if (equivalent? this-node (caar classes))
|
||||
(begin (cons (cons this-node (car classes)) (cdr classes)))
|
||||
(begin (cons (car classes) (add-node (cdr classes)))))))))
|
||||
(node-loop (add-node classes) (cdr nodes))))))))
|
||||
node-loop)
|
||||
'()
|
||||
nodes)))
|
||||
(define find-canonical-representative
|
||||
(lambda (element classification)
|
||||
((letrec ((loop
|
||||
(lambda (classes)
|
||||
(if (null? classes)
|
||||
(begin (error '"Can't classify" element))
|
||||
(if (memq element (car classes)) (begin (car (car classes))) (begin (loop (cdr classes))))))))
|
||||
loop)
|
||||
classification)))
|
||||
(define reduce
|
||||
(lambda (graph) (let ((classes (classify (graph-nodes graph)))) (canonicalize-graph graph classes))))
|
||||
(define make-empty-table (lambda () (list 'TABLE)))
|
||||
(define lookup
|
||||
(lambda (table x y)
|
||||
(let ((one (assq x (cdr table)))) (if one (let ((two (assq y (cdr one)))) (if two (cdr two) '#f)) '#f))))
|
||||
(define insert!
|
||||
(lambda (table x y value)
|
||||
(letrec ((make-singleton-table (lambda (x y) (list (cons x y)))))
|
||||
(let ((one (assq x (cdr table))))
|
||||
(if one
|
||||
(set-cdr! one (cons (cons y value) (cdr one)))
|
||||
(set-cdr! table (cons (cons x (make-singleton-table y value)) (cdr table))))))))
|
||||
(define blue-edge-operate
|
||||
(lambda (arg-fn res-fn graph op sig1 sig2)
|
||||
(make-blue-edge op (arg-fn graph (arg sig1) (arg sig2)) (res-fn graph (res sig1) (res sig2)))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define meet
|
||||
(lambda (graph node1 node2)
|
||||
(if (eq? node1 node2)
|
||||
(begin node1)
|
||||
(if (let ((or-part (any-node? node1))) (if or-part or-part (any-node? node2)))
|
||||
(begin any-node)
|
||||
(if (none-node? node1)
|
||||
(begin node2)
|
||||
(if (none-node? node2)
|
||||
(begin node1)
|
||||
(let ((c17352 (lookup (already-met graph) node1 node2)))
|
||||
(if c17352
|
||||
c17352
|
||||
(if (conforms? node1 node2)
|
||||
(begin node2)
|
||||
(if (conforms? node2 node1)
|
||||
(begin node1)
|
||||
(begin
|
||||
(let ((result (make-node (string-append '"(" (name node1) '" ^ " (name node2) '")") '())))
|
||||
(add-graph-nodes! graph result)
|
||||
(insert! (already-met graph) node1 node2 result)
|
||||
(set-blue-edges!
|
||||
result
|
||||
(map
|
||||
(lambda (op) (blue-edge-operate join meet graph op (sig op node1) (sig op node2)))
|
||||
(intersect (map operation (blue-edges node1)) (map operation (blue-edges node2)))))
|
||||
result))))))))))))
|
||||
(define join
|
||||
(lambda (graph node1 node2)
|
||||
(if (eq? node1 node2)
|
||||
(begin node1)
|
||||
(if (any-node? node1)
|
||||
(begin node2)
|
||||
(if (any-node? node2)
|
||||
(begin node1)
|
||||
(if (let ((or-part (none-node? node1))) (if or-part or-part (none-node? node2)))
|
||||
(begin none-node)
|
||||
(let ((c17353 (lookup (already-joined graph) node1 node2)))
|
||||
(if c17353
|
||||
c17353
|
||||
(if (conforms? node1 node2)
|
||||
(begin node1)
|
||||
(if (conforms? node2 node1)
|
||||
(begin node2)
|
||||
(begin
|
||||
(let ((result (make-node (string-append '"(" (name node1) '" v " (name node2) '")") '())))
|
||||
(add-graph-nodes! graph result)
|
||||
(insert! (already-joined graph) node1 node2 result)
|
||||
(set-blue-edges!
|
||||
result
|
||||
(map
|
||||
(lambda (op) (blue-edge-operate meet join graph op (sig op node1) (sig op node2)))
|
||||
(union (map operation (blue-edges node1)) (map operation (blue-edges node2)))))
|
||||
result))))))))))))
|
||||
(define make-lattice
|
||||
(lambda (g print?)
|
||||
(letrec ((step
|
||||
(lambda (g)
|
||||
(let ((copy (copy-graph g)))
|
||||
(let ((nodes (graph-nodes copy)))
|
||||
(for-each
|
||||
(lambda (first)
|
||||
(for-each (lambda (second) (meet copy first second) (join copy first second)) nodes))
|
||||
nodes)
|
||||
copy))))
|
||||
(loop
|
||||
(lambda (g count)
|
||||
(if print? (display count) (void))
|
||||
(let ((lattice (step g)))
|
||||
(if print? (begin (display '" -> ") (display (length (graph-nodes lattice)))) (void))
|
||||
(let ((new-g (reduce lattice)))
|
||||
(let ((new-count (length (graph-nodes new-g))))
|
||||
(if (= new-count count)
|
||||
(begin (if print? (newline) (void)) new-g)
|
||||
(begin
|
||||
(if print? (begin (display '" -> ") (display new-count) (newline)) (void))
|
||||
(loop new-g new-count)))))))))
|
||||
(let ((graph (make-graph (adjoin any-node (adjoin none-node (graph-nodes (clean-graph g)))))))
|
||||
(loop graph (length (graph-nodes graph)))))))
|
||||
(define a '())
|
||||
(define b '())
|
||||
(define c '())
|
||||
(define d '())
|
||||
(define reset
|
||||
(lambda ()
|
||||
(set! a (make-node 'a '()))
|
||||
(set! b (make-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! c (make-node '"c" '()))
|
||||
(set! d (make-node '"d" '()))
|
||||
(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)))
|
||||
'(made a b c d)))
|
||||
(define test
|
||||
(lambda () (reset) (map name (graph-nodes (make-lattice (make-graph (list a b c d any-node none-node)) '#t)))))
|
||||
(define go
|
||||
(lambda ()
|
||||
(reset)
|
||||
(let ((result
|
||||
'("(((b v d) ^ a) v c)"
|
||||
"(c ^ d)"
|
||||
"(b v (a ^ d))"
|
||||
"((a v d) ^ b)"
|
||||
"(b v d)"
|
||||
"(b ^ (a v c))"
|
||||
"(a v (c ^ d))"
|
||||
"((b v d) ^ a)"
|
||||
"(c v (a v d))"
|
||||
"(a v c)"
|
||||
"(d v (b ^ (a v c)))"
|
||||
"(d ^ (a v c))"
|
||||
"((a ^ d) v c)"
|
||||
"((a ^ b) v d)"
|
||||
"(((a v d) ^ b) v (a ^ d))"
|
||||
"(b ^ d)"
|
||||
"(b v (a v d))"
|
||||
"(a ^ c)"
|
||||
"(b ^ (c v d))"
|
||||
"(a ^ b)"
|
||||
"(a v b)"
|
||||
"((a ^ d) ^ b)"
|
||||
"(a ^ d)"
|
||||
"(a v d)"
|
||||
"d"
|
||||
"(c v d)"
|
||||
"a"
|
||||
"b"
|
||||
"c"
|
||||
"any"
|
||||
"none")))
|
||||
(if (equal? (test) result) (display '" ok.") (display '" um."))
|
||||
(newline))))
|
||||
|
||||
|
||||
(void ((letrec ((loop (lambda (n) (if (zero? n) 'done (begin (go) (loop (- n '1))))))) loop) 1)))
|
||||
|
|
@ -1,826 +0,0 @@
|
|||
#lang planet dyoo/whalesong
|
||||
(begin
|
||||
(define make-parser
|
||||
(lambda (grammar lexer)
|
||||
(letrec ((non-terminals
|
||||
(lambda (grammar)
|
||||
(letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts)))))
|
||||
((letrec ((def-loop
|
||||
(lambda (defs nts)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
(let ((head (car def)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules nts)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
((letrec ((loop
|
||||
(lambda (l nts)
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(loop (cdr l) (add-nt nt nts)))
|
||||
(rule-loop (cdr rules) nts)))))
|
||||
loop)
|
||||
rule
|
||||
nts))
|
||||
(def-loop (cdr defs) nts)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
(add-nt head nts))))
|
||||
(list->vector (reverse nts))))))
|
||||
def-loop)
|
||||
grammar
|
||||
'()))))
|
||||
(ind
|
||||
(lambda (nt nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f))))
|
||||
loop)
|
||||
(- (vector-length nts) '1))))
|
||||
(nb-configurations
|
||||
(lambda (grammar)
|
||||
((letrec ((def-loop
|
||||
(lambda (defs nb-confs)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules nb-confs)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
((letrec ((loop
|
||||
(lambda (l nb-confs)
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (+ nb-confs '1))
|
||||
(rule-loop (cdr rules) (+ nb-confs '1))))))
|
||||
loop)
|
||||
rule
|
||||
nb-confs))
|
||||
(def-loop (cdr defs) nb-confs)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
nb-confs))
|
||||
nb-confs))))
|
||||
def-loop)
|
||||
grammar
|
||||
'0))))
|
||||
(let ((nts (non-terminals grammar)))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let ((nb-confs (+ (nb-configurations grammar) nb-nts)))
|
||||
(let ((starters (make-vector nb-nts '())))
|
||||
(let ((enders (make-vector nb-nts '())))
|
||||
(let ((predictors (make-vector nb-nts '())))
|
||||
(let ((steps (make-vector nb-confs '#f)))
|
||||
(let ((names (make-vector nb-confs '#f)))
|
||||
(letrec ((setup-tables
|
||||
(lambda (grammar nts starters enders predictors steps names)
|
||||
(letrec ((add-conf
|
||||
(lambda (conf nt nts class)
|
||||
(let ((i (ind nt nts)))
|
||||
(vector-set! class i (cons conf (vector-ref class i)))))))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((nt-loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(vector-set! steps i (- i nb-nts))
|
||||
(vector-set! names i (list (vector-ref nts i) '0))
|
||||
(vector-set! enders i (list i))
|
||||
(nt-loop (- i '1)))
|
||||
'#f))))
|
||||
nt-loop)
|
||||
(- nb-nts '1))
|
||||
((letrec ((def-loop
|
||||
(lambda (defs conf)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
(let ((head (car def)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules conf rule-num)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
(vector-set!
|
||||
names
|
||||
conf
|
||||
(list head rule-num))
|
||||
(add-conf conf head nts starters)
|
||||
((letrec ((loop
|
||||
(lambda (l conf)
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(vector-set!
|
||||
steps
|
||||
conf
|
||||
(ind nt nts))
|
||||
(add-conf
|
||||
conf
|
||||
nt
|
||||
nts
|
||||
predictors)
|
||||
(loop
|
||||
(cdr l)
|
||||
(+ conf '1)))
|
||||
(begin
|
||||
(vector-set!
|
||||
steps
|
||||
conf
|
||||
(-
|
||||
(ind head nts)
|
||||
nb-nts))
|
||||
(add-conf
|
||||
conf
|
||||
head
|
||||
nts
|
||||
enders)
|
||||
(rule-loop
|
||||
(cdr rules)
|
||||
(+ conf '1)
|
||||
(+ rule-num '1)))))))
|
||||
loop)
|
||||
rule
|
||||
conf))
|
||||
(def-loop (cdr defs) conf)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
conf
|
||||
'1)))
|
||||
'#f))))
|
||||
def-loop)
|
||||
grammar
|
||||
(vector-length nts)))))))
|
||||
(setup-tables grammar nts starters enders predictors steps names)
|
||||
(let ((parser-descr (vector lexer nts starters enders predictors steps names)))
|
||||
(lambda (input)
|
||||
(letrec ((ind
|
||||
(lambda (nt nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(if (equal? (vector-ref nts i) nt) i (loop (- i '1)))
|
||||
'#f))))
|
||||
loop)
|
||||
(- (vector-length nts) '1))))
|
||||
(comp-tok
|
||||
(lambda (tok nts)
|
||||
((letrec ((loop
|
||||
(lambda (l1 l2)
|
||||
(if (pair? l1)
|
||||
(let ((i (ind (car l1) nts)))
|
||||
(if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2)))
|
||||
(cons (car tok) (reverse l2))))))
|
||||
loop)
|
||||
(cdr tok)
|
||||
'())))
|
||||
(input->tokens
|
||||
(lambda (input lexer nts)
|
||||
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input)))))
|
||||
(make-states
|
||||
(lambda (nb-toks nb-confs)
|
||||
(let ((states (make-vector (+ nb-toks '1) '#f)))
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(let ((v (make-vector (+ nb-confs '1) '#f)))
|
||||
(vector-set! v '0 '-1)
|
||||
(vector-set! states i v)
|
||||
(loop (- i '1)))
|
||||
states))))
|
||||
loop)
|
||||
nb-toks))))
|
||||
(conf-set-get (lambda (state conf) (vector-ref state (+ conf '1))))
|
||||
(conf-set-get*
|
||||
(lambda (state state-num conf)
|
||||
(let ((conf-set (conf-set-get state conf)))
|
||||
(if conf-set
|
||||
conf-set
|
||||
(let ((conf-set (make-vector (+ state-num '6) '#f)))
|
||||
(vector-set! conf-set '1 '-3)
|
||||
(vector-set! conf-set '2 '-1)
|
||||
(vector-set! conf-set '3 '-1)
|
||||
(vector-set! conf-set '4 '-1)
|
||||
(vector-set! state (+ conf '1) conf-set)
|
||||
conf-set)))))
|
||||
(conf-set-merge-new!
|
||||
(lambda (conf-set)
|
||||
(vector-set!
|
||||
conf-set
|
||||
(+ (vector-ref conf-set '1) '5)
|
||||
(vector-ref conf-set '4))
|
||||
(vector-set! conf-set '1 (vector-ref conf-set '3))
|
||||
(vector-set! conf-set '3 '-1)
|
||||
(vector-set! conf-set '4 '-1)))
|
||||
(conf-set-head (lambda (conf-set) (vector-ref conf-set '2)))
|
||||
(conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5))))
|
||||
(conf-set-member?
|
||||
(lambda (state conf i)
|
||||
(let ((conf-set (vector-ref state (+ conf '1))))
|
||||
(if conf-set (conf-set-next conf-set i) '#f))))
|
||||
(conf-set-adjoin
|
||||
(lambda (state conf-set conf i)
|
||||
(let ((tail (vector-ref conf-set '3)))
|
||||
(vector-set! conf-set (+ i '5) '-1)
|
||||
(vector-set! conf-set (+ tail '5) i)
|
||||
(vector-set! conf-set '3 i)
|
||||
(if (< tail '0)
|
||||
(begin
|
||||
(vector-set! conf-set '0 (vector-ref state '0))
|
||||
(vector-set! state '0 conf))
|
||||
'#f))))
|
||||
(conf-set-adjoin*
|
||||
(lambda (states state-num l i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
((letrec ((loop
|
||||
(lambda (l1)
|
||||
(if (pair? l1)
|
||||
(let ((conf (car l1)))
|
||||
(let ((conf-set (conf-set-get* state state-num conf)))
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (cdr l1)))
|
||||
(loop (cdr l1)))))
|
||||
'#f))))
|
||||
loop)
|
||||
l))))
|
||||
(conf-set-adjoin**
|
||||
(lambda (states states* state-num conf i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
(if (conf-set-member? state conf i)
|
||||
(let ((state* (vector-ref states* state-num)))
|
||||
(let ((conf-set* (conf-set-get* state* state-num conf)))
|
||||
(if (not (conf-set-next conf-set* i))
|
||||
(conf-set-adjoin state* conf-set* conf i)
|
||||
'#f)
|
||||
'#t))
|
||||
'#f))))
|
||||
(conf-set-union
|
||||
(lambda (state conf-set conf other-set)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (conf-set-next other-set i)))
|
||||
(loop (conf-set-next other-set i)))
|
||||
'#f))))
|
||||
loop)
|
||||
(conf-set-head other-set))))
|
||||
(forw
|
||||
(lambda (states state-num starters enders predictors steps nts)
|
||||
(letrec ((predict
|
||||
(lambda (state state-num conf-set conf nt starters enders)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((starter (car l)))
|
||||
(let ((starter-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
starter)))
|
||||
(if (not
|
||||
(conf-set-next
|
||||
starter-set
|
||||
state-num))
|
||||
(begin
|
||||
(conf-set-adjoin
|
||||
state
|
||||
starter-set
|
||||
starter
|
||||
state-num)
|
||||
(loop1 (cdr l)))
|
||||
(loop1 (cdr l)))))
|
||||
'#f))))
|
||||
loop1)
|
||||
(vector-ref starters nt))
|
||||
((letrec ((loop2
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(if (conf-set-member? state ender state-num)
|
||||
(let ((next (+ conf '1)))
|
||||
(let ((next-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
next)))
|
||||
(conf-set-union
|
||||
state
|
||||
next-set
|
||||
next
|
||||
conf-set)
|
||||
(loop2 (cdr l))))
|
||||
(loop2 (cdr l))))
|
||||
'#f))))
|
||||
loop2)
|
||||
(vector-ref enders nt))))
|
||||
(reduce
|
||||
(lambda (states state state-num conf-set head preds)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((pred (car l)))
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(let ((pred-set
|
||||
(conf-set-get
|
||||
(vector-ref states i)
|
||||
pred)))
|
||||
(if pred-set
|
||||
(let ((next (+ pred '1)))
|
||||
(let ((next-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
next)))
|
||||
(conf-set-union
|
||||
state
|
||||
next-set
|
||||
next
|
||||
pred-set)))
|
||||
'#f)
|
||||
(loop2
|
||||
(conf-set-next
|
||||
conf-set
|
||||
i)))
|
||||
(loop1 (cdr l))))))
|
||||
loop2)
|
||||
head))
|
||||
'#f))))
|
||||
loop1)
|
||||
preds))))
|
||||
(let ((state (vector-ref states state-num))
|
||||
(nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda ()
|
||||
(let ((conf (vector-ref state '0)))
|
||||
(if (>= conf '0)
|
||||
(let ((step (vector-ref steps conf)))
|
||||
(let ((conf-set (vector-ref state (+ conf '1))))
|
||||
(let ((head (vector-ref conf-set '4)))
|
||||
(vector-set!
|
||||
state
|
||||
'0
|
||||
(vector-ref conf-set '0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
(if (>= step '0)
|
||||
(predict
|
||||
state
|
||||
state-num
|
||||
conf-set
|
||||
conf
|
||||
step
|
||||
starters
|
||||
enders)
|
||||
(let ((preds
|
||||
(vector-ref
|
||||
predictors
|
||||
(+ step nb-nts))))
|
||||
(reduce
|
||||
states
|
||||
state
|
||||
state-num
|
||||
conf-set
|
||||
head
|
||||
preds)))
|
||||
(loop))))
|
||||
'#f)))))
|
||||
loop))))))
|
||||
(forward
|
||||
(lambda (starters enders predictors steps nts toks)
|
||||
(let ((nb-toks (vector-length toks)))
|
||||
(let ((nb-confs (vector-length steps)))
|
||||
(let ((states (make-states nb-toks nb-confs)))
|
||||
(let ((goal-starters (vector-ref starters '0)))
|
||||
(conf-set-adjoin* states '0 goal-starters '0)
|
||||
(forw states '0 starters enders predictors steps nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (< i nb-toks)
|
||||
(let ((tok-nts (cdr (vector-ref toks i))))
|
||||
(conf-set-adjoin* states (+ i '1) tok-nts i)
|
||||
(forw
|
||||
states
|
||||
(+ i '1)
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
nts)
|
||||
(loop (+ i '1)))
|
||||
'#f))))
|
||||
loop)
|
||||
'0)
|
||||
states))))))
|
||||
(produce
|
||||
(lambda (conf i j enders steps toks states states* nb-nts)
|
||||
(let ((prev (- conf '1)))
|
||||
(if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(let ((ender-set
|
||||
(conf-set-get (vector-ref states j) ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k)
|
||||
(if (>= k '0)
|
||||
(begin
|
||||
(if (>= k i)
|
||||
(if (conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
k
|
||||
prev
|
||||
i)
|
||||
(conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
j
|
||||
ender
|
||||
k)
|
||||
'#f)
|
||||
'#f)
|
||||
(loop2
|
||||
(conf-set-next ender-set k)))
|
||||
(loop1 (cdr l))))))
|
||||
loop2)
|
||||
(conf-set-head ender-set))
|
||||
(loop1 (cdr l)))))
|
||||
'#f))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev)))
|
||||
'#f))))
|
||||
(back
|
||||
(lambda (states states* state-num enders steps nb-nts toks)
|
||||
(let ((state* (vector-ref states* state-num)))
|
||||
((letrec ((loop1
|
||||
(lambda ()
|
||||
(let ((conf (vector-ref state* '0)))
|
||||
(if (>= conf '0)
|
||||
(let ((conf-set (vector-ref state* (+ conf '1))))
|
||||
(let ((head (vector-ref conf-set '4)))
|
||||
(vector-set! state* '0 (vector-ref conf-set '0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(produce
|
||||
conf
|
||||
i
|
||||
state-num
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
states*
|
||||
nb-nts)
|
||||
(loop2
|
||||
(conf-set-next conf-set i)))
|
||||
(loop1)))))
|
||||
loop2)
|
||||
head)))
|
||||
'#f)))))
|
||||
loop1)))))
|
||||
(backward
|
||||
(lambda (states enders steps nts toks)
|
||||
(let ((nb-toks (vector-length toks)))
|
||||
(let ((nb-confs (vector-length steps)))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let ((states* (make-states nb-toks nb-confs)))
|
||||
(let ((goal-enders (vector-ref enders '0)))
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
nb-toks
|
||||
conf
|
||||
'0)
|
||||
(loop1 (cdr l)))
|
||||
'#f))))
|
||||
loop1)
|
||||
goal-enders)
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(back
|
||||
states
|
||||
states*
|
||||
i
|
||||
enders
|
||||
steps
|
||||
nb-nts
|
||||
toks)
|
||||
(loop2 (- i '1)))
|
||||
'#f))))
|
||||
loop2)
|
||||
nb-toks)
|
||||
states*)))))))
|
||||
(parsed?
|
||||
(lambda (nt i j nts enders states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
'#t
|
||||
(loop (cdr l))))
|
||||
'#f))))
|
||||
loop)
|
||||
(vector-ref enders nt*)))
|
||||
'#f))))
|
||||
(deriv-trees
|
||||
(lambda (conf i j enders steps names toks states nb-nts)
|
||||
(let ((name (vector-ref names conf)))
|
||||
(if name
|
||||
(if (< conf nb-nts)
|
||||
(list (list name (car (vector-ref toks i))))
|
||||
(list (list name)))
|
||||
(let ((prev (- conf '1)))
|
||||
((letrec ((loop1
|
||||
(lambda (l1 l2)
|
||||
(if (pair? l1)
|
||||
(let ((ender (car l1)))
|
||||
(let ((ender-set
|
||||
(conf-set-get
|
||||
(vector-ref states j)
|
||||
ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k l2)
|
||||
(if (>= k '0)
|
||||
(if (if (>= k i)
|
||||
(conf-set-member?
|
||||
(vector-ref states k)
|
||||
prev
|
||||
i)
|
||||
'#f)
|
||||
(let ((prev-trees
|
||||
(deriv-trees
|
||||
prev
|
||||
i
|
||||
k
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts))
|
||||
(ender-trees
|
||||
(deriv-trees
|
||||
ender
|
||||
k
|
||||
j
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts)))
|
||||
((letrec ((loop3
|
||||
(lambda (l3 l2)
|
||||
(if (pair? l3)
|
||||
(let ((ender-tree
|
||||
(list
|
||||
(car
|
||||
l3))))
|
||||
((letrec ((loop4
|
||||
(lambda (l4
|
||||
l2)
|
||||
(if (pair?
|
||||
l4)
|
||||
(loop4
|
||||
(cdr
|
||||
l4)
|
||||
(cons
|
||||
(append
|
||||
(car
|
||||
l4)
|
||||
ender-tree)
|
||||
l2))
|
||||
(loop3
|
||||
(cdr
|
||||
l3)
|
||||
l2)))))
|
||||
loop4)
|
||||
prev-trees
|
||||
l2))
|
||||
(loop2
|
||||
(conf-set-next
|
||||
ender-set
|
||||
k)
|
||||
l2)))))
|
||||
loop3)
|
||||
ender-trees
|
||||
l2))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
l2))
|
||||
(loop1 (cdr l1) l2)))))
|
||||
loop2)
|
||||
(conf-set-head ender-set)
|
||||
l2)
|
||||
(loop1 (cdr l1) l2))))
|
||||
l2))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev))
|
||||
'()))))))
|
||||
(deriv-trees*
|
||||
(lambda (nt i j nts enders steps names toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l trees)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
(loop
|
||||
(cdr l)
|
||||
(append
|
||||
(deriv-trees
|
||||
conf
|
||||
i
|
||||
j
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts)
|
||||
trees))
|
||||
(loop (cdr l) trees)))
|
||||
trees))))
|
||||
loop)
|
||||
(vector-ref enders nt*)
|
||||
'()))
|
||||
'#f))))
|
||||
(nb-deriv-trees
|
||||
(lambda (conf i j enders steps toks states nb-nts)
|
||||
(let ((prev (- conf '1)))
|
||||
(if (let ((or-part (< conf nb-nts)))
|
||||
(if or-part or-part (< (vector-ref steps prev) '0)))
|
||||
'1
|
||||
((letrec ((loop1
|
||||
(lambda (l n)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(let ((ender-set
|
||||
(conf-set-get (vector-ref states j) ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k n)
|
||||
(if (>= k '0)
|
||||
(if (if (>= k i)
|
||||
(conf-set-member?
|
||||
(vector-ref states k)
|
||||
prev
|
||||
i)
|
||||
'#f)
|
||||
(let ((nb-prev-trees
|
||||
(nb-deriv-trees
|
||||
prev
|
||||
i
|
||||
k
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts))
|
||||
(nb-ender-trees
|
||||
(nb-deriv-trees
|
||||
ender
|
||||
k
|
||||
j
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts)))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
(+
|
||||
n
|
||||
(*
|
||||
nb-prev-trees
|
||||
nb-ender-trees))))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
n))
|
||||
(loop1 (cdr l) n)))))
|
||||
loop2)
|
||||
(conf-set-head ender-set)
|
||||
n)
|
||||
(loop1 (cdr l) n))))
|
||||
n))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev))
|
||||
'0)))))
|
||||
(nb-deriv-trees*
|
||||
(lambda (nt i j nts enders steps toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l nb-trees)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
(loop
|
||||
(cdr l)
|
||||
(+
|
||||
(nb-deriv-trees
|
||||
conf
|
||||
i
|
||||
j
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts)
|
||||
nb-trees))
|
||||
(loop (cdr l) nb-trees)))
|
||||
nb-trees))))
|
||||
loop)
|
||||
(vector-ref enders nt*)
|
||||
'0))
|
||||
'#f)))))
|
||||
(let ((lexer (vector-ref parser-descr '0)))
|
||||
(let ((nts (vector-ref parser-descr '1)))
|
||||
(let ((starters (vector-ref parser-descr '2)))
|
||||
(let ((enders (vector-ref parser-descr '3)))
|
||||
(let ((predictors (vector-ref parser-descr '4)))
|
||||
(let ((steps (vector-ref parser-descr '5)))
|
||||
(let ((names (vector-ref parser-descr '6)))
|
||||
(let ((toks (input->tokens input lexer nts)))
|
||||
(vector
|
||||
nts
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
names
|
||||
toks
|
||||
(backward
|
||||
(forward starters enders predictors steps nts toks)
|
||||
enders
|
||||
steps
|
||||
nts
|
||||
toks)
|
||||
parsed?
|
||||
deriv-trees*
|
||||
nb-deriv-trees*))))))))))))))))))))))))
|
||||
(define parse->parsed?
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states)))))))
|
||||
(define parse->trees
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((steps (vector-ref parse '4)))
|
||||
(let ((names (vector-ref parse '5)))
|
||||
(let ((toks (vector-ref parse '6)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((deriv-trees* (vector-ref parse '9)))
|
||||
(deriv-trees* nt i j nts enders steps names toks states))))))))))
|
||||
(define parse->nb-trees
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((steps (vector-ref parse '4)))
|
||||
(let ((toks (vector-ref parse '6)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((nb-deriv-trees* (vector-ref parse '10)))
|
||||
(nb-deriv-trees* nt i j nts enders steps toks states)))))))))
|
||||
(define test
|
||||
(lambda (k)
|
||||
(let ((p (make-parser '((s (a) (s s)))
|
||||
(lambda (l)
|
||||
(map (lambda (x) (list x x)) l)))))
|
||||
(let ((x (p (vector->list (make-vector k 'a)))))
|
||||
(display (length (parse->trees x 's '0 k)))
|
||||
(newline)))))
|
||||
(test '12))
|
||||
|
|
@ -1,825 +0,0 @@
|
|||
(begin
|
||||
(define make-parser
|
||||
(lambda (grammar lexer)
|
||||
(letrec ((non-terminals
|
||||
(lambda (grammar)
|
||||
(letrec ((add-nt (lambda (nt nts) (if (member nt nts) nts (cons nt nts)))))
|
||||
((letrec ((def-loop
|
||||
(lambda (defs nts)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
(let ((head (car def)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules nts)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
((letrec ((loop
|
||||
(lambda (l nts)
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(loop (cdr l) (add-nt nt nts)))
|
||||
(rule-loop (cdr rules) nts)))))
|
||||
loop)
|
||||
rule
|
||||
nts))
|
||||
(def-loop (cdr defs) nts)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
(add-nt head nts))))
|
||||
(list->vector (reverse nts))))))
|
||||
def-loop)
|
||||
grammar
|
||||
'()))))
|
||||
(ind
|
||||
(lambda (nt nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0) (if (equal? (vector-ref nts i) nt) i (loop (- i '1))) '#f))))
|
||||
loop)
|
||||
(- (vector-length nts) '1))))
|
||||
(nb-configurations
|
||||
(lambda (grammar)
|
||||
((letrec ((def-loop
|
||||
(lambda (defs nb-confs)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules nb-confs)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
((letrec ((loop
|
||||
(lambda (l nb-confs)
|
||||
(if (pair? l)
|
||||
(loop (cdr l) (+ nb-confs '1))
|
||||
(rule-loop (cdr rules) (+ nb-confs '1))))))
|
||||
loop)
|
||||
rule
|
||||
nb-confs))
|
||||
(def-loop (cdr defs) nb-confs)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
nb-confs))
|
||||
nb-confs))))
|
||||
def-loop)
|
||||
grammar
|
||||
'0))))
|
||||
(let ((nts (non-terminals grammar)))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let ((nb-confs (+ (nb-configurations grammar) nb-nts)))
|
||||
(let ((starters (make-vector nb-nts '())))
|
||||
(let ((enders (make-vector nb-nts '())))
|
||||
(let ((predictors (make-vector nb-nts '())))
|
||||
(let ((steps (make-vector nb-confs '#f)))
|
||||
(let ((names (make-vector nb-confs '#f)))
|
||||
(letrec ((setup-tables
|
||||
(lambda (grammar nts starters enders predictors steps names)
|
||||
(letrec ((add-conf
|
||||
(lambda (conf nt nts class)
|
||||
(let ((i (ind nt nts)))
|
||||
(vector-set! class i (cons conf (vector-ref class i)))))))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((nt-loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(vector-set! steps i (- i nb-nts))
|
||||
(vector-set! names i (list (vector-ref nts i) '0))
|
||||
(vector-set! enders i (list i))
|
||||
(nt-loop (- i '1)))
|
||||
'#f))))
|
||||
nt-loop)
|
||||
(- nb-nts '1))
|
||||
((letrec ((def-loop
|
||||
(lambda (defs conf)
|
||||
(if (pair? defs)
|
||||
(let ((def (car defs)))
|
||||
(let ((head (car def)))
|
||||
((letrec ((rule-loop
|
||||
(lambda (rules conf rule-num)
|
||||
(if (pair? rules)
|
||||
(let ((rule (car rules)))
|
||||
(vector-set!
|
||||
names
|
||||
conf
|
||||
(list head rule-num))
|
||||
(add-conf conf head nts starters)
|
||||
((letrec ((loop
|
||||
(lambda (l conf)
|
||||
(if (pair? l)
|
||||
(let ((nt (car l)))
|
||||
(vector-set!
|
||||
steps
|
||||
conf
|
||||
(ind nt nts))
|
||||
(add-conf
|
||||
conf
|
||||
nt
|
||||
nts
|
||||
predictors)
|
||||
(loop
|
||||
(cdr l)
|
||||
(+ conf '1)))
|
||||
(begin
|
||||
(vector-set!
|
||||
steps
|
||||
conf
|
||||
(-
|
||||
(ind head nts)
|
||||
nb-nts))
|
||||
(add-conf
|
||||
conf
|
||||
head
|
||||
nts
|
||||
enders)
|
||||
(rule-loop
|
||||
(cdr rules)
|
||||
(+ conf '1)
|
||||
(+ rule-num '1)))))))
|
||||
loop)
|
||||
rule
|
||||
conf))
|
||||
(def-loop (cdr defs) conf)))))
|
||||
rule-loop)
|
||||
(cdr def)
|
||||
conf
|
||||
'1)))
|
||||
'#f))))
|
||||
def-loop)
|
||||
grammar
|
||||
(vector-length nts)))))))
|
||||
(setup-tables grammar nts starters enders predictors steps names)
|
||||
(let ((parser-descr (vector lexer nts starters enders predictors steps names)))
|
||||
(lambda (input)
|
||||
(letrec ((ind
|
||||
(lambda (nt nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(if (equal? (vector-ref nts i) nt) i (loop (- i '1)))
|
||||
'#f))))
|
||||
loop)
|
||||
(- (vector-length nts) '1))))
|
||||
(comp-tok
|
||||
(lambda (tok nts)
|
||||
((letrec ((loop
|
||||
(lambda (l1 l2)
|
||||
(if (pair? l1)
|
||||
(let ((i (ind (car l1) nts)))
|
||||
(if i (loop (cdr l1) (cons i l2)) (loop (cdr l1) l2)))
|
||||
(cons (car tok) (reverse l2))))))
|
||||
loop)
|
||||
(cdr tok)
|
||||
'())))
|
||||
(input->tokens
|
||||
(lambda (input lexer nts)
|
||||
(list->vector (map (lambda (tok) (comp-tok tok nts)) (lexer input)))))
|
||||
(make-states
|
||||
(lambda (nb-toks nb-confs)
|
||||
(let ((states (make-vector (+ nb-toks '1) '#f)))
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(let ((v (make-vector (+ nb-confs '1) '#f)))
|
||||
(vector-set! v '0 '-1)
|
||||
(vector-set! states i v)
|
||||
(loop (- i '1)))
|
||||
states))))
|
||||
loop)
|
||||
nb-toks))))
|
||||
(conf-set-get (lambda (state conf) (vector-ref state (+ conf '1))))
|
||||
(conf-set-get*
|
||||
(lambda (state state-num conf)
|
||||
(let ((conf-set (conf-set-get state conf)))
|
||||
(if conf-set
|
||||
conf-set
|
||||
(let ((conf-set (make-vector (+ state-num '6) '#f)))
|
||||
(vector-set! conf-set '1 '-3)
|
||||
(vector-set! conf-set '2 '-1)
|
||||
(vector-set! conf-set '3 '-1)
|
||||
(vector-set! conf-set '4 '-1)
|
||||
(vector-set! state (+ conf '1) conf-set)
|
||||
conf-set)))))
|
||||
(conf-set-merge-new!
|
||||
(lambda (conf-set)
|
||||
(vector-set!
|
||||
conf-set
|
||||
(+ (vector-ref conf-set '1) '5)
|
||||
(vector-ref conf-set '4))
|
||||
(vector-set! conf-set '1 (vector-ref conf-set '3))
|
||||
(vector-set! conf-set '3 '-1)
|
||||
(vector-set! conf-set '4 '-1)))
|
||||
(conf-set-head (lambda (conf-set) (vector-ref conf-set '2)))
|
||||
(conf-set-next (lambda (conf-set i) (vector-ref conf-set (+ i '5))))
|
||||
(conf-set-member?
|
||||
(lambda (state conf i)
|
||||
(let ((conf-set (vector-ref state (+ conf '1))))
|
||||
(if conf-set (conf-set-next conf-set i) '#f))))
|
||||
(conf-set-adjoin
|
||||
(lambda (state conf-set conf i)
|
||||
(let ((tail (vector-ref conf-set '3)))
|
||||
(vector-set! conf-set (+ i '5) '-1)
|
||||
(vector-set! conf-set (+ tail '5) i)
|
||||
(vector-set! conf-set '3 i)
|
||||
(if (< tail '0)
|
||||
(begin
|
||||
(vector-set! conf-set '0 (vector-ref state '0))
|
||||
(vector-set! state '0 conf))
|
||||
'#f))))
|
||||
(conf-set-adjoin*
|
||||
(lambda (states state-num l i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
((letrec ((loop
|
||||
(lambda (l1)
|
||||
(if (pair? l1)
|
||||
(let ((conf (car l1)))
|
||||
(let ((conf-set (conf-set-get* state state-num conf)))
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (cdr l1)))
|
||||
(loop (cdr l1)))))
|
||||
'#f))))
|
||||
loop)
|
||||
l))))
|
||||
(conf-set-adjoin**
|
||||
(lambda (states states* state-num conf i)
|
||||
(let ((state (vector-ref states state-num)))
|
||||
(if (conf-set-member? state conf i)
|
||||
(let ((state* (vector-ref states* state-num)))
|
||||
(let ((conf-set* (conf-set-get* state* state-num conf)))
|
||||
(if (not (conf-set-next conf-set* i))
|
||||
(conf-set-adjoin state* conf-set* conf i)
|
||||
'#f)
|
||||
'#t))
|
||||
'#f))))
|
||||
(conf-set-union
|
||||
(lambda (state conf-set conf other-set)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(if (not (conf-set-next conf-set i))
|
||||
(begin
|
||||
(conf-set-adjoin state conf-set conf i)
|
||||
(loop (conf-set-next other-set i)))
|
||||
(loop (conf-set-next other-set i)))
|
||||
'#f))))
|
||||
loop)
|
||||
(conf-set-head other-set))))
|
||||
(forw
|
||||
(lambda (states state-num starters enders predictors steps nts)
|
||||
(letrec ((predict
|
||||
(lambda (state state-num conf-set conf nt starters enders)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((starter (car l)))
|
||||
(let ((starter-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
starter)))
|
||||
(if (not
|
||||
(conf-set-next
|
||||
starter-set
|
||||
state-num))
|
||||
(begin
|
||||
(conf-set-adjoin
|
||||
state
|
||||
starter-set
|
||||
starter
|
||||
state-num)
|
||||
(loop1 (cdr l)))
|
||||
(loop1 (cdr l)))))
|
||||
'#f))))
|
||||
loop1)
|
||||
(vector-ref starters nt))
|
||||
((letrec ((loop2
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(if (conf-set-member? state ender state-num)
|
||||
(let ((next (+ conf '1)))
|
||||
(let ((next-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
next)))
|
||||
(conf-set-union
|
||||
state
|
||||
next-set
|
||||
next
|
||||
conf-set)
|
||||
(loop2 (cdr l))))
|
||||
(loop2 (cdr l))))
|
||||
'#f))))
|
||||
loop2)
|
||||
(vector-ref enders nt))))
|
||||
(reduce
|
||||
(lambda (states state state-num conf-set head preds)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((pred (car l)))
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(let ((pred-set
|
||||
(conf-set-get
|
||||
(vector-ref states i)
|
||||
pred)))
|
||||
(if pred-set
|
||||
(let ((next (+ pred '1)))
|
||||
(let ((next-set
|
||||
(conf-set-get*
|
||||
state
|
||||
state-num
|
||||
next)))
|
||||
(conf-set-union
|
||||
state
|
||||
next-set
|
||||
next
|
||||
pred-set)))
|
||||
'#f)
|
||||
(loop2
|
||||
(conf-set-next
|
||||
conf-set
|
||||
i)))
|
||||
(loop1 (cdr l))))))
|
||||
loop2)
|
||||
head))
|
||||
'#f))))
|
||||
loop1)
|
||||
preds))))
|
||||
(let ((state (vector-ref states state-num))
|
||||
(nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda ()
|
||||
(let ((conf (vector-ref state '0)))
|
||||
(if (>= conf '0)
|
||||
(let ((step (vector-ref steps conf)))
|
||||
(let ((conf-set (vector-ref state (+ conf '1))))
|
||||
(let ((head (vector-ref conf-set '4)))
|
||||
(vector-set!
|
||||
state
|
||||
'0
|
||||
(vector-ref conf-set '0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
(if (>= step '0)
|
||||
(predict
|
||||
state
|
||||
state-num
|
||||
conf-set
|
||||
conf
|
||||
step
|
||||
starters
|
||||
enders)
|
||||
(let ((preds
|
||||
(vector-ref
|
||||
predictors
|
||||
(+ step nb-nts))))
|
||||
(reduce
|
||||
states
|
||||
state
|
||||
state-num
|
||||
conf-set
|
||||
head
|
||||
preds)))
|
||||
(loop))))
|
||||
'#f)))))
|
||||
loop))))))
|
||||
(forward
|
||||
(lambda (starters enders predictors steps nts toks)
|
||||
(let ((nb-toks (vector-length toks)))
|
||||
(let ((nb-confs (vector-length steps)))
|
||||
(let ((states (make-states nb-toks nb-confs)))
|
||||
(let ((goal-starters (vector-ref starters '0)))
|
||||
(conf-set-adjoin* states '0 goal-starters '0)
|
||||
(forw states '0 starters enders predictors steps nts)
|
||||
((letrec ((loop
|
||||
(lambda (i)
|
||||
(if (< i nb-toks)
|
||||
(let ((tok-nts (cdr (vector-ref toks i))))
|
||||
(conf-set-adjoin* states (+ i '1) tok-nts i)
|
||||
(forw
|
||||
states
|
||||
(+ i '1)
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
nts)
|
||||
(loop (+ i '1)))
|
||||
'#f))))
|
||||
loop)
|
||||
'0)
|
||||
states))))))
|
||||
(produce
|
||||
(lambda (conf i j enders steps toks states states* nb-nts)
|
||||
(let ((prev (- conf '1)))
|
||||
(if (if (>= conf nb-nts) (>= (vector-ref steps prev) '0) '#f)
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(let ((ender-set
|
||||
(conf-set-get (vector-ref states j) ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k)
|
||||
(if (>= k '0)
|
||||
(begin
|
||||
(if (>= k i)
|
||||
(if (conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
k
|
||||
prev
|
||||
i)
|
||||
(conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
j
|
||||
ender
|
||||
k)
|
||||
'#f)
|
||||
'#f)
|
||||
(loop2
|
||||
(conf-set-next ender-set k)))
|
||||
(loop1 (cdr l))))))
|
||||
loop2)
|
||||
(conf-set-head ender-set))
|
||||
(loop1 (cdr l)))))
|
||||
'#f))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev)))
|
||||
'#f))))
|
||||
(back
|
||||
(lambda (states states* state-num enders steps nb-nts toks)
|
||||
(let ((state* (vector-ref states* state-num)))
|
||||
((letrec ((loop1
|
||||
(lambda ()
|
||||
(let ((conf (vector-ref state* '0)))
|
||||
(if (>= conf '0)
|
||||
(let ((conf-set (vector-ref state* (+ conf '1))))
|
||||
(let ((head (vector-ref conf-set '4)))
|
||||
(vector-set! state* '0 (vector-ref conf-set '0))
|
||||
(conf-set-merge-new! conf-set)
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(produce
|
||||
conf
|
||||
i
|
||||
state-num
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
states*
|
||||
nb-nts)
|
||||
(loop2
|
||||
(conf-set-next conf-set i)))
|
||||
(loop1)))))
|
||||
loop2)
|
||||
head)))
|
||||
'#f)))))
|
||||
loop1)))))
|
||||
(backward
|
||||
(lambda (states enders steps nts toks)
|
||||
(let ((nb-toks (vector-length toks)))
|
||||
(let ((nb-confs (vector-length steps)))
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
(let ((states* (make-states nb-toks nb-confs)))
|
||||
(let ((goal-enders (vector-ref enders '0)))
|
||||
((letrec ((loop1
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(conf-set-adjoin**
|
||||
states
|
||||
states*
|
||||
nb-toks
|
||||
conf
|
||||
'0)
|
||||
(loop1 (cdr l)))
|
||||
'#f))))
|
||||
loop1)
|
||||
goal-enders)
|
||||
((letrec ((loop2
|
||||
(lambda (i)
|
||||
(if (>= i '0)
|
||||
(begin
|
||||
(back
|
||||
states
|
||||
states*
|
||||
i
|
||||
enders
|
||||
steps
|
||||
nb-nts
|
||||
toks)
|
||||
(loop2 (- i '1)))
|
||||
'#f))))
|
||||
loop2)
|
||||
nb-toks)
|
||||
states*)))))))
|
||||
(parsed?
|
||||
(lambda (nt i j nts enders states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
'#t
|
||||
(loop (cdr l))))
|
||||
'#f))))
|
||||
loop)
|
||||
(vector-ref enders nt*)))
|
||||
'#f))))
|
||||
(deriv-trees
|
||||
(lambda (conf i j enders steps names toks states nb-nts)
|
||||
(let ((name (vector-ref names conf)))
|
||||
(if name
|
||||
(if (< conf nb-nts)
|
||||
(list (list name (car (vector-ref toks i))))
|
||||
(list (list name)))
|
||||
(let ((prev (- conf '1)))
|
||||
((letrec ((loop1
|
||||
(lambda (l1 l2)
|
||||
(if (pair? l1)
|
||||
(let ((ender (car l1)))
|
||||
(let ((ender-set
|
||||
(conf-set-get
|
||||
(vector-ref states j)
|
||||
ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k l2)
|
||||
(if (>= k '0)
|
||||
(if (if (>= k i)
|
||||
(conf-set-member?
|
||||
(vector-ref states k)
|
||||
prev
|
||||
i)
|
||||
'#f)
|
||||
(let ((prev-trees
|
||||
(deriv-trees
|
||||
prev
|
||||
i
|
||||
k
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts))
|
||||
(ender-trees
|
||||
(deriv-trees
|
||||
ender
|
||||
k
|
||||
j
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts)))
|
||||
((letrec ((loop3
|
||||
(lambda (l3 l2)
|
||||
(if (pair? l3)
|
||||
(let ((ender-tree
|
||||
(list
|
||||
(car
|
||||
l3))))
|
||||
((letrec ((loop4
|
||||
(lambda (l4
|
||||
l2)
|
||||
(if (pair?
|
||||
l4)
|
||||
(loop4
|
||||
(cdr
|
||||
l4)
|
||||
(cons
|
||||
(append
|
||||
(car
|
||||
l4)
|
||||
ender-tree)
|
||||
l2))
|
||||
(loop3
|
||||
(cdr
|
||||
l3)
|
||||
l2)))))
|
||||
loop4)
|
||||
prev-trees
|
||||
l2))
|
||||
(loop2
|
||||
(conf-set-next
|
||||
ender-set
|
||||
k)
|
||||
l2)))))
|
||||
loop3)
|
||||
ender-trees
|
||||
l2))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
l2))
|
||||
(loop1 (cdr l1) l2)))))
|
||||
loop2)
|
||||
(conf-set-head ender-set)
|
||||
l2)
|
||||
(loop1 (cdr l1) l2))))
|
||||
l2))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev))
|
||||
'()))))))
|
||||
(deriv-trees*
|
||||
(lambda (nt i j nts enders steps names toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l trees)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
(loop
|
||||
(cdr l)
|
||||
(append
|
||||
(deriv-trees
|
||||
conf
|
||||
i
|
||||
j
|
||||
enders
|
||||
steps
|
||||
names
|
||||
toks
|
||||
states
|
||||
nb-nts)
|
||||
trees))
|
||||
(loop (cdr l) trees)))
|
||||
trees))))
|
||||
loop)
|
||||
(vector-ref enders nt*)
|
||||
'()))
|
||||
'#f))))
|
||||
(nb-deriv-trees
|
||||
(lambda (conf i j enders steps toks states nb-nts)
|
||||
(let ((prev (- conf '1)))
|
||||
(if (let ((or-part (< conf nb-nts)))
|
||||
(if or-part or-part (< (vector-ref steps prev) '0)))
|
||||
'1
|
||||
((letrec ((loop1
|
||||
(lambda (l n)
|
||||
(if (pair? l)
|
||||
(let ((ender (car l)))
|
||||
(let ((ender-set
|
||||
(conf-set-get (vector-ref states j) ender)))
|
||||
(if ender-set
|
||||
((letrec ((loop2
|
||||
(lambda (k n)
|
||||
(if (>= k '0)
|
||||
(if (if (>= k i)
|
||||
(conf-set-member?
|
||||
(vector-ref states k)
|
||||
prev
|
||||
i)
|
||||
'#f)
|
||||
(let ((nb-prev-trees
|
||||
(nb-deriv-trees
|
||||
prev
|
||||
i
|
||||
k
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts))
|
||||
(nb-ender-trees
|
||||
(nb-deriv-trees
|
||||
ender
|
||||
k
|
||||
j
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts)))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
(+
|
||||
n
|
||||
(*
|
||||
nb-prev-trees
|
||||
nb-ender-trees))))
|
||||
(loop2
|
||||
(conf-set-next ender-set k)
|
||||
n))
|
||||
(loop1 (cdr l) n)))))
|
||||
loop2)
|
||||
(conf-set-head ender-set)
|
||||
n)
|
||||
(loop1 (cdr l) n))))
|
||||
n))))
|
||||
loop1)
|
||||
(vector-ref enders (vector-ref steps prev))
|
||||
'0)))))
|
||||
(nb-deriv-trees*
|
||||
(lambda (nt i j nts enders steps toks states)
|
||||
(let ((nt* (ind nt nts)))
|
||||
(if nt*
|
||||
(let ((nb-nts (vector-length nts)))
|
||||
((letrec ((loop
|
||||
(lambda (l nb-trees)
|
||||
(if (pair? l)
|
||||
(let ((conf (car l)))
|
||||
(if (conf-set-member?
|
||||
(vector-ref states j)
|
||||
conf
|
||||
i)
|
||||
(loop
|
||||
(cdr l)
|
||||
(+
|
||||
(nb-deriv-trees
|
||||
conf
|
||||
i
|
||||
j
|
||||
enders
|
||||
steps
|
||||
toks
|
||||
states
|
||||
nb-nts)
|
||||
nb-trees))
|
||||
(loop (cdr l) nb-trees)))
|
||||
nb-trees))))
|
||||
loop)
|
||||
(vector-ref enders nt*)
|
||||
'0))
|
||||
'#f)))))
|
||||
(let ((lexer (vector-ref parser-descr '0)))
|
||||
(let ((nts (vector-ref parser-descr '1)))
|
||||
(let ((starters (vector-ref parser-descr '2)))
|
||||
(let ((enders (vector-ref parser-descr '3)))
|
||||
(let ((predictors (vector-ref parser-descr '4)))
|
||||
(let ((steps (vector-ref parser-descr '5)))
|
||||
(let ((names (vector-ref parser-descr '6)))
|
||||
(let ((toks (input->tokens input lexer nts)))
|
||||
(vector
|
||||
nts
|
||||
starters
|
||||
enders
|
||||
predictors
|
||||
steps
|
||||
names
|
||||
toks
|
||||
(backward
|
||||
(forward starters enders predictors steps nts toks)
|
||||
enders
|
||||
steps
|
||||
nts
|
||||
toks)
|
||||
parsed?
|
||||
deriv-trees*
|
||||
nb-deriv-trees*))))))))))))))))))))))))
|
||||
(define parse->parsed?
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((parsed? (vector-ref parse '8))) (parsed? nt i j nts enders states)))))))
|
||||
(define parse->trees
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((steps (vector-ref parse '4)))
|
||||
(let ((names (vector-ref parse '5)))
|
||||
(let ((toks (vector-ref parse '6)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((deriv-trees* (vector-ref parse '9)))
|
||||
(deriv-trees* nt i j nts enders steps names toks states))))))))))
|
||||
(define parse->nb-trees
|
||||
(lambda (parse nt i j)
|
||||
(let ((nts (vector-ref parse '0)))
|
||||
(let ((enders (vector-ref parse '2)))
|
||||
(let ((steps (vector-ref parse '4)))
|
||||
(let ((toks (vector-ref parse '6)))
|
||||
(let ((states (vector-ref parse '7)))
|
||||
(let ((nb-deriv-trees* (vector-ref parse '10)))
|
||||
(nb-deriv-trees* nt i j nts enders steps toks states)))))))))
|
||||
(define test
|
||||
(lambda (k)
|
||||
(let ((p (make-parser '((s (a) (s s)))
|
||||
(lambda (l)
|
||||
(map (lambda (x) (list x x)) l)))))
|
||||
(let ((x (p (vector->list (make-vector k 'a)))))
|
||||
(display (length (parse->trees x 's '0 k)))
|
||||
(newline)))))
|
||||
(test '12))
|
||||
|
|
@ -1 +0,0 @@
|
|||
58786
|
||||
Loading…
Reference in New Issue
Block a user