1:":"; exec mzscheme -r $0 "$@"
   2:
   3:;;; ----------------------------------------------------
   4:;;; Filename: Charty3.scm
   5:;;; Author:   Damir Cavar <dcavar@unizd.hr>
   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: