1:":"; exec mzscheme -r $0 "$@"
   2:
   3:;;; ----------------------------------------------------
   4:;;; Filename: BUP1.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:;;; This script assumes that the text is raw and encoded in UTF8.
  17:;;;
  18:;;; Functions:
  19:;;; 1. Reads in a grammar from files named grammar*.txt.
  20:;;; 2. Parses the words given as command line arguments.
  21:;;; 3. Returns true or false (parsed or not parsed).
  22:;;;
  23:;;; Usage:
  24:;;; mzscheme -r BUP1.scm John kissed Mary
  25:;;; ----------------------------------------------------
  26:
  27:(require (lib "list.ss"))
  28:(require (lib "list.ss"   "srfi" "1" ))
  29:(require (lib "string.ss" "srfi" "13"))
  30:(require (lib "hash.ss"   "srfi" "69"))
  31:
  32:(load "grammar.scm")
  33:
  34:
  35:(define sublist
  36:  (lambda (mlist from to)
  37:    (let ([res     '()]
  38:          [counter 0])
  39:      (for-each (lambda (x)
  40:                  (if (and (<= from counter) (< counter to))
  41:                      (if (> (length res) 0)
  42:                          (set! res (append res (list x)))
  43:                          (set! res (list x))))
  44:                  (set! counter (+ counter 1)))
  45:                mlist)
  46:      res)))
  47:
  48:
  49:
  50:(define buparse
  51:  (lambda (tokens goal agenda)
  52:    (printf "Looking at: ~a\n" tokens)
  53:    (let window ([w (length tokens)])
  54:      (let loop ([i 0])
  55:        ;(printf "~a  pos: ~a  window: ~a\n" (sublist tokens i (+ i w)) i w)
  56:        ;(printf "Rest: ~a - ~a\n" (take tokens i) (take-right tokens (- (length tokens) (+ i w))))
  57:        (let ([x (sublist tokens i (+ i w))])
  58:          (let ([vals  (hash-table-get rhs x '())]
  59:                [parse '()])
  60:            (for-each (lambda (y)
  61:                        (set! parse (concatenate (list (take tokens i)
  62:                                                       (list y)
  63:                                                       (take-right tokens (- (length tokens) (+ i w))))))
  64:                        (unless (member parse agenda)
  65:                          (set! agenda (append agenda (list parse)))))
  66:                      vals)))
  67:        (unless (>= (+ i w) (length tokens))
  68:          (loop (+ i 1))))
  69:      (unless (<= w 1)
  70:        (window (- w 1))))
  71:    ;    (printf "Agenda:\n")
  72:    ;    (for-each (lambda (x)
  73:    ;                (printf "~a\n" x))
  74:    ;              agenda)
  75:    
  76:    (if (member goal agenda)
  77:        #t ; if goal in agenda, success
  78:        (if (> (length agenda) 0) ; else
  79:            (buparse (car agenda) goal (cdr agenda)) ; if some path on agenda
  80:            #f)))) ; else fail
  81:
  82:
  83:
  84:
  85:(load-grammar "grammar.txt")
  86:; (hash-table-for-each rhs (lambda (key value) (printf "~a\t~a\n" key value)))
  87:(if (< 0 (vector-length argv))
  88:    (if (buparse (map-in-order (lambda (x)
  89:                                 (string->symbol x))
  90:                               (vector->list argv))
  91:                 (list 'S)
  92:                 '())
  93:        (printf "Success!\n")
  94:        (printf "Fail!\n")))
  95:; (buparse (list 'John 'loves 'Mary) (list 'S) '())
  96:
  97:
  98: