1:":"; exec mzscheme -r $0 "$@"
2:
3:;;; ----------------------------------------------------
4:;;; Filename: Charty.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 Charty.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)])
55: (printf "Based on edge: ~a\n" edge)
56: (printf "Adding edge: ~a\n" newedge)
57: (unless (member chart newedge) ; if not on chart, append to chart
58: (set! chart (append chart (list newedge))))))
59: (hash-table-get rhs x '())))
60: rhss))))
61: (drop chart start))))
62:
63:
64:;;; fundamental-rule
65:;;; find active edges and axpand them with inactive, i.e.
66:;;; the first symbol after the dot as their LHS symbol
67:(define fundamental-rule!
68: (lambda ()
69: (printf "Fundamental rule:\n")
70: (for-each ; edge on chart
71: (lambda (edge)
72: (if (active-edge edge)
73: (let ([expectation (list-ref (list-ref edge 4) (caddr edge))])
74: (for-each ; edge on chart
75: (lambda (oe)
76: (if (inactive-edge oe)
77: (if (and (eq? expectation (list-ref oe 3))
78: (= (cadr edge) (car oe)))
79: (begin
80: (let ([newedge (list (car edge)
81: (cadr oe)
82: (+ (caddr edge) 1)
83: (list-ref edge 3)
84: (list-ref edge 4))])
85: (unless (member newedge chart)
86: (printf "These edges fit:\n~a\n~a\n" edge oe)
87: (printf "Adding edge: ~a\n" newedge)
88: (set! chart (append chart (list newedge)))))))))
89: chart))))
90: chart)))
91:
92:
93:(define parse
94: (lambda (tokens)
95: (printf "Initialize the chart from tokens: ~a\n" tokens)
96:
97: (let window ([w (length tokens)])
98: (let iloop ([i 0])
99: (let ([x (sublist tokens i (+ i w))])
100: (let ([vals (hash-table-get rhs x '())]
101: [parse '()])
102: (for-each (lambda (y)
103: ; create edge with span
104: (let ([edge (list i (+ i w) w y x)])
105: (unless (member edge chart)
106: (set! chart (append chart (list edge))))))
107: vals)))
108: (unless (>= (+ i w) (length tokens))
109: (iloop (+ i 1))))
110: (unless (<= w 1)
111: (window (- w 1))))
112: ; apply rule invocation, fundamental rule, until nothing more possible
113: (let ([start 0]
114: [oldlen (length chart)])
115: (let loop ()
116: (rule-invocation! start)
117: (fundamental-rule!)
118: ; something changed on the chart
119: (if (> (length chart) oldlen)
120: (begin
121: (set! start oldlen)
122: (set! oldlen (length chart))
123: (loop)))))))
124:
125:
126:
127:;;; -----------------------------
128:(load-grammar "grammar.txt")
129:(if (< 0 (vector-length argv))
130: (begin
131: (parse (map-in-order (lambda (x)
132: (string->symbol x))
133: (vector->list argv)))
134: (printf "Final chart:\n")
135: (for-each (lambda (z)
136: (printf "~a\n" z))
137: chart)))
138:
139:
140: