1:":"; exec mzscheme -r $0 "$@"
2:
3:;;; ----------------------------------------------------
4:;;; Filename: Charty2.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 Charty2.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:(define inactive-edge
29: (lambda (edge)
30: (if (>= (caddr edge) (length (list-ref edge 4)))
31: #t
32: #f)))
33:
34:
35:(define active-edge
36: (lambda (edge)
37: (not (inactive-edge edge))))
38:
39:
40:;;; rule-invocation
41:;;; find complete edges and add rules that have the LHS symbol
42:;;; as the first RHS symbol
43:(define rule-invocation!
44: (lambda (start)
45: (printf "Rule invocation:\n")
46: (for-each ; edge on chart starting from start
47: (lambda (edge)
48: (if (inactive-edge edge) ; if edge not active
49: (let ([rhss (hash-table-get rhsl (list-ref edge 3) '())])
50: (for-each ; for each RHS with LHS as initial symbol
51: (lambda (x)
52: (for-each ; for each LHS with this RHS
53: (lambda (y) ; create new edge
54: (let ([newedge (list (car edge) (cadr edge) 1 y x (append (list (list-index
55: (lambda (el)
56: (eq? el edge))
57: chart))))])
58: (printf "Based on edge: ~a\n" edge)
59: (printf "Adding edge: ~a\n" newedge)
60: (unless (member chart newedge) ; if not on chart, append to chart
61: (set! chart (append chart (list newedge))))))
62: (hash-table-get rhs x '())))
63: rhss))))
64: (drop chart start))))
65:
66:
67:;;; fundamental-rule
68:;;; find active edges and axpand them with inactive, i.e.
69:;;; the first symbol after the dot as their LHS symbol
70:(define fundamental-rule!
71: (lambda ()
72: (printf "Fundamental rule:\n")
73: (for-each ; edge on chart
74: (lambda (edge)
75: (if (active-edge edge)
76: (let ([expectation (list-ref (list-ref edge 4) (caddr edge))])
77: (for-each ; edge on chart
78: (lambda (oe)
79: (if (inactive-edge oe)
80: (if (and (eq? expectation (list-ref oe 3))
81: (= (cadr edge) (car oe)))
82: (begin
83: (let ([newedge (list (car edge)
84: (cadr oe)
85: (+ (caddr edge) 1)
86: (list-ref edge 3)
87: (list-ref edge 4)
88: (append (list-ref edge 5)
89: (list (list-index
90: (lambda (el)
91: (eq? el oe))
92: chart))))])
93: (unless (member newedge chart)
94: (printf "These edges fit:\n~a\n~a\n" edge oe)
95: (printf "Adding edge: ~a\n" newedge)
96: (set! chart (append chart (list newedge)))))))))
97: chart))))
98: chart)))
99:
100:
101:(define parse
102: (lambda (tokens)
103: (printf "Initialize the chart from tokens: ~a\n" tokens)
104: (let window ([w (length tokens)])
105: (let iloop ([i 0])
106: (let ([x (sublist tokens i (+ i w))])
107: (let ([vals (hash-table-get rhs x '())]
108: [parse '()])
109: (for-each (lambda (y)
110: ; create edge with span
111: (let ([edge (list i (+ i w) w y x '())])
112: (unless (member edge chart)
113: (set! chart (append chart (list edge))))))
114: vals)))
115: (unless (>= (+ i w) (length tokens))
116: (iloop (+ i 1))))
117: (unless (<= w 1)
118: (window (- w 1))))
119: ; apply rule invocation, fundamental rule, until nothing more possible
120: (let ([start 0]
121: [oldlen (length chart)])
122: (let loop ()
123: (rule-invocation! start)
124: (fundamental-rule!)
125: ; something changed on the chart
126: (if (> (length chart) oldlen)
127: (begin
128: (set! start oldlen)
129: (set! oldlen (length chart))
130: (loop)))))))
131:
132:
133:
134:;;; -----------------------------
135:(load-grammar "grammar.txt")
136:(if (< 0 (vector-length argv))
137: (begin
138: (parse (map-in-order (lambda (x)
139: (string->symbol x))
140: (vector->list argv)))
141: (printf "Final chart:\n")
142: (let ([counter -1])
143: (for-each (lambda (z)
144: (set! counter (+ counter 1))
145: (if (inactive-edge z)
146: (printf "~a: ~a\n" counter z)))
147: chart))))
148:
149:
150: