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: