1:":"; exec mzscheme -r $0 "$@"
2:
3:;;; ----------------------------------------------------
4:;;; Filename: Charty3.scm
5:;;; Author: Damir Cavar <dcavar@me.com>
6:;;;
7:;;; (C) 2006 by Damir Cavar
8:;;;
9:;;; This code is published under the restrictive GPL!
10:;;; Please find the text of the GPL here:
11:;;; http://www.gnu.org/licenses/gpl.txt
12:;;;
13:;;; It is free for use, change, etc. as long as the copyright
14:;;; note above is included in any modified version of the code.
15:;;;
16:;;; Usage:
17:;;; mzscheme -r Charty3.scm John kissed Mary
18:;;; ----------------------------------------------------
19:
20:(load "list-extra.ss")
21:(load "grammar2.scm")
22:
23:
24:;;; global variable for the chart
25:(define chart '())
26:
27:
28:;;; inactive-edge (edge)
29:;;; true is edge inactive, else false
30:(define inactive-edge
31: (lambda (edge)
32: (if (>= (caddr edge) (length (list-ref edge 4)))
33: #t
34: #f)))
35:
36:
37:;;; active-edge (edge)
38:;;; negation of inactive-edge
39:(define active-edge
40: (lambda (edge)
41: (not (inactive-edge edge))))
42:
43:
44:;;; rule-invocation
45:;;; find complete edges and add rules that have the LHS symbol
46:;;; as the first RHS symbol
47:(define rule-invocation!
48: (lambda (start)
49: (printf "Start: ~a\n" start)
50: (for-each ; edge on chart starting from start
51: (lambda (edge)
52: (if (inactive-edge edge) ; if edge not active
53: (let ([rhss (hash-table-get rhsl (list-ref edge 3) '())])
54: (for-each ; for each RHS with LHS as initial symbol
55: (lambda (x)
56: (for-each ; for each LHS with this RHS
57: (lambda (y) ; create new edge
58: (let ([newedge (list (car edge) (cadr edge) 1 y x
59: (append (list (list-index
60: (lambda (el)
61: (eq? el edge))
62: chart))))])
63: (unless (member chart newedge) ; if not on chart, append to chart
64: (printf "RI Newedge: ~a\n" newedge)
65: (set! chart (append chart (list newedge))))))
66: (hash-table-get rhs x '())))
67: rhss))))
68: (drop chart start))))
69:
70:
71:;;; fundamental-rule
72:;;; find active edges and axpand them with inactive, i.e.
73:;;; the first symbol after the dot as their LHS symbol
74:(define fundamental-rule!
75: (lambda ()
76: (for-each ; edge on chart
77: (lambda (edge)
78: (if (active-edge edge)
79: (let ([expectation (list-ref (list-ref edge 4) (caddr edge))])
80: (for-each ; edge on chart
81: (lambda (oe)
82: (if (inactive-edge oe)
83: (if (and (eq? expectation (list-ref oe 3))
84: (= (cadr edge) (car oe)))
85: (begin
86: (let ([newedge (list (car edge)
87: (cadr oe)
88: (+ (caddr edge) 1)
89: (list-ref edge 3)
90: (list-ref edge 4)
91: (append (list-ref edge 5)
92: (list (list-index
93: (lambda (el)
94: (eq? el oe))
95: chart))))])
96: (unless (member newedge chart)
97: (printf "FR Newedge: ~a\n" newedge)
98: (set! chart (append chart (list newedge)))))))))
99: chart))))
100: chart)))
101:
102:
103:(define parse
104: (lambda (tokens)
105: (let window ([w (length tokens)])
106: (let iloop ([i 0])
107: (let ([x (sublist tokens i (+ i w))])
108: (let ([vals (hash-table-get rhs x '())]
109: [parse '()])
110: (for-each (lambda (y)
111: ; create edge with span
112: (let ([edge (list i (+ i w) w y x '())])
113: (unless (member edge chart)
114: (set! chart (append chart (list edge))))))
115: vals)))
116: (unless (>= (+ i w) (length tokens))
117: (iloop (+ i 1))))
118: (unless (<= w 1)
119: (window (- w 1))))
120: ; apply rule invocation, fundamental rule, until nothing more possible
121: (let ([start 0]
122: [oldlen (length chart)])
123: (let loop ()
124: (rule-invocation! start)
125: (fundamental-rule!)
126: (printf "Chart-length: ~a\n" (length chart))
127: ; something changed on the chart
128: (if (> (length chart) oldlen)
129: (begin
130: (set! start oldlen)
131: (set! oldlen (length chart))
132: (loop)))))))
133:
134:
135:
136:;;; serialize-chart
137:;;; create lists of complete overspanning edges
138:(define serialize-chart
139: (lambda (chart input)
140: (let ([res '()])
141: (for-each
142: (lambda (edge)
143: (let ([end (length input)])
144: (if (and (inactive-edge edge) ; inactive edge
145: (= (car edge) 0) ; from beginning
146: (= (cadr edge) end)) ; till end
147: (begin
148: (unless (member (list (edge->list edge)) res)
149: (set! res (append res (list (edge->list edge)))))))))
150: (reverse chart))
151: res)))
152:
153:
154:;;; edge->list
155:;;; converts embedded edges into an embedded list
156:(define edge->list
157: (lambda (edge)
158: (let ([str (list (list-ref edge 3))])
159: (if (> (length (list-ref edge 5)) 0)
160: (for-each
161: (lambda (i)
162: (set! str (append str (list (edge->list (list-ref chart i))))))
163: (list-ref edge 5))
164: (set! str (append str (list-ref edge 4))))
165: str)))
166:
167:
168:
169:;;; -----------------------------
170:(load-grammar "grammar.txt")
171:(if (< 0 (vector-length argv))
172: (let ([input (map-in-order (lambda (x)
173: (string->symbol x))
174: (vector->list argv))])
175: (parse input)
176: (printf "Final chart:\n")
177: (let ([counter -1])
178: (for-each (lambda (z)
179: (set! counter (+ counter 1))
180: (if (inactive-edge z)
181: (printf "~a: ~a\n" counter z)))
182: chart))
183: (printf "Parses:\n")
184: (let ([counter 0])
185: (for-each (lambda (x)
186: (set! counter (+ counter 1))
187: (printf "~a: ~a\n" counter x))
188: (serialize-chart chart input)))))
189: