lc-parser.scm

;;; lc-parser.scm

;;; Top-down parser with left corner check
;;; TODO
;;; - only returns one parse tree

;;; words grammar
;;; nt words grammar lexicon table
;;; symbols steps words grammar lexicon table

(define (lc-parse words grammar)
  ;;(write-line 'lc-parse `(words ,words) 'grammar)
  (let* ((g (expand-grammar grammar))
	 (l (create-lexicon g))
	 (t (left-corner-table g))
	 (symbols   '(s))
	 (steps     '())
	 (solutions '())
	 (next      identity))
    (lcp symbols words steps solutions g l t next)))

(define (lcp symbols words steps solutions g l t next)
  ;;(write-line 'lcp `(symbols ,symbols) `(words ,words) `(steps ,steps) `(solutions ,solutions))
  (cond ((and (null? symbols) (null? words))
	 (let ((solutions+ (cons (reverse steps) solutions)))
	   (next solutions+)))
	((or (null? symbols) (null? words)) (next solutions))
	((equal? (car symbols) (car words))
	 (lcp (cdr symbols) (cdr words) steps solutions g l t next))
	(else
	 (let ((rules (viable-lc-rules (car symbols) (car words) g l t)))
	   (lcp-rules rules symbols words steps solutions g l t next)))))

(define (lcp-rules rules symbols words steps solutions g l t next)
  ;;(write-line 'lcp-rules `(rules ,rules) `(symbols ,symbols) `(words ,words) `(steps ,steps) `(solutions ,solutions))
  (if (null? rules)
      (next solutions)
      (lcp-rule (car rules) symbols words steps solutions g l t
	(lambda (solutions+)
	  (lcp-rules (cdr rules) symbols words steps solutions+ g l t next)))))

(define (lcp-rule rule symbols words steps solutions g l t next)
  ;;(write-line 'lcp-rule `(rule ,rule) `(symbols ,symbols) `(words ,words) `(steps ,steps) `(solutions ,solutions))
  (let ((symbols+ (append (body rule) (cdr symbols)))
	(steps+   (cons rule steps)))
    (lcp symbols+ words steps+ solutions g l t next)))


;;; VIABLE-LC-RULES nt word grammar lexicon left-corner-table

(define (viable-lc-rules nt word g l t)
  (let ((word-cats  (alist-lookup word l))
	(rules      (find-rules/head nt g)))
    (define (viable-lc? rule)
      (let* ((left    (body1 rule))
	     (corners (alist-lookup left t '())))
	(or (and (string? left) (string=? left word))
	    (not (null? (listset-intersection
			 word-cats (cons left corners)))))))
    (filter viable-lc? rules)))

(define-unit-test 'viable-lc-rules
  (let* ((grammar1 '((s (np vp) (aux np vp) (vp))
                     (np (proper-noun) (det nom))
                     (nom (noun) (noun nom) (nom pp))
                     (vp (verb) (verb np))
                     (pp (prep np))
                     (det "that" "this" "a")
                     (noun "book" "flight" "meal" "money")
                     (verb "book" "include" "prefer")
                     (aux "does")
                     (prep "from" "to" "on")
                     (proper-noun "Houston" "TWA")
                     ))
         (g (expand-grammar grammar1))
         (l (create-lexicon g))
         (t (left-corner-table g)))
    (check (viable-lc-rules 's  "a" g l t) => '((s np vp)))
    (check (viable-lc-rules 'np "a" g l t) => '((np det nom)))
    (check (viable-lc-rules 'vp "a" g l t) => '())
    (check (viable-lc-rules 'det "a" g l t) => '((det "a")))
    ))


;;; EXPAND-GRAMMAR grammar
;;; expand rules like (nt rule-body ...) to (nt rule-body0) (nt rule-body1) ...
;;; (expand-grammar '((a (i j)) (b (k l) (m n)))) => '((a i j) (b k l) (b m n))

(define (expand-grammar grammar)
  (define (process rule)
    (let ((head (car rule))
	  (bodies (cdr rule)))
      (cond ((not (pair? bodies))
	     (raise `("Expected list in grammar body" ,bodies ,grammar)))
	    ((not (symbol? head))
	     (raise `("Expected symbol for non terminal" ,head ,grammar)))
	    (else
	     (map (lambda (body)
		    (if (string? body)
			(list head body)
			(cons head body)))
		  bodies)))))
  (append-map process grammar))

(define-unit-test 'expand-grammar
  (check (expand-grammar '()) => '())
  (check (expand-grammar '((a (b)))) => '((a b)))
  (check (expand-grammar '((a (b c)) (d (e f)))) => '((a b c) (d e f)))
  (check (expand-grammar '((a (b c) (d e)))) => '((a b c) (a d e)))
  (check (expand-grammar '((a "foo" "bar"))) => '((a "foo") (a "bar"))))


;;; CREATE-LEXICON grammar
;;; create a table containing: (word nt*)
;;; output rules are (nt (word ...))
;;; (create-lexicon '((a "x") (a "y") (b "x"))) => '(("x" (a b)) ("y" a))

(define (create-lexicon grammar)	; expanded grammar
  (define (build rule lexicon)
    (define (f propl)
      (list (word rule) (cons (head rule) (cadr propl))))
    (alist-replace (word rule) f lexicon `(add? #t) `(effect transform)))
  (foldr build '() (filter lexical? grammar)))

(define-unit-test 'create-lexicon
  (check (create-lexicon '()) => '())
  (check (create-lexicon '((a "foo") (a "bar"))) => '(("foo" (a)) ("bar" (a))))
  (check (create-lexicon '((a "x") (b "x") (b "y")))
         => '(("x" (a b)) ("y" (b))))
  (let ((grammar1
         `((s (np vp))
           (np (art noun))
           (vp (verb np))
           (art "the" "a")
           (noun "man" "ball" "woman" "saw" "table" "noun" "verb" "book")
           (verb "hit" "took" "saw" "liked" "book")
           ))
        (table1 '(("the" (art)) ("a" (art))
                  ("man" (noun)) ("ball" (noun)) ("woman" (noun))
                  ("table" (noun)) ("noun" (noun)) ("verb" (noun))
                  ("hit" (verb)) ("took" (verb))
                  ("saw" (noun verb)) ("liked" (verb)) ("book" (noun verb)))))
    (check (create-lexicon (expand-grammar grammar1)) => table1)
    ))


;;; LEFT-CORNER-TABLE grammar
;;; body is (nt (corners ...))
;;; (left-corner-table '((a b c) (a d e) (d f)))
;;;  => '((a (b d f)) (b ()) (c ()) (d (f)) (f ()))

(define (left-corner-table grammar)	; expanded grammar
  (let ((rules (filter (! lexical?) grammar)))
    (let ((nts (all-non-terminals rules)))
      (define (lct nt) (list nt (left-corners (list nt) '() '() rules)))
      (map lct nts))))

(define (left-corners not-searched searched corners rules)
  (if (null? not-searched)
      corners
      (let* ((nt (car not-searched))
	     (nt-corners (map body1 (find-rules/head nt rules)))
	     (searched+ (cons nt searched))
	     (not-searched+ (listset-union
			     (cdr not-searched)
			     (listset-difference nt-corners searched+)))
	     (corners+ (listset-union corners nt-corners)))
	(left-corners not-searched+ searched+ corners+ rules))))


(define-unit-test 'left-corner-table
  (define grammar1 '((a b c) (a d e) (d f)))
  (define table1   '((a (b d f)) (b ()) (c ()) (d (f)) (e ()) (f ())))
  (define grammar2 '((a b c) (a d e) (b f g) (d h i) (h k)))
  (define table2   '((a (b d f h k)) (b (f)) (c ()) (d (h k))
                     (e ()) (f ()) (g ()) (h (k)) (i ()) (k ())))
  (check (left-corner-table grammar1) => table1)
  (check (left-corner-table grammar2) => table2))


;;; PARSE-TREE steps => tree

(define (parse-tree steps)
  (if (null? steps)
      '()
      (pt-step (car steps) (cdr steps)
	(lambda (tree steps+)
	  (if (not (null? steps+))
	      #f
	      tree)))))

(define (pt-step step steps cont)
  (pt-nts (body step) steps
    (lambda (subtrees steps+)
      (cont `(,(head step) ,@subtrees) steps+))))

(define (pt-nts nts steps cont)
  (if (null? nts)
      (cont '() steps)
      (pt-nt (car nts) steps
        (lambda (subtree steps+)
	  (pt-nts (cdr nts) steps+ cont)))))

(define (pt-nt nt steps cont)
  (cont (car steps) (cdr steps)))


(define-unit-test 'parse-tree
  (let ((steps1 '((s np vp) (np art noun) (art "the") (noun "man")
                  (vp verb np) (verb "took")
                  (np art noun) (art "the") (noun "book")))
        (tree1  '(s (np (art "the") (noun "man"))
                    (vp (verb "took") (np (art "the") (noun "book"))))))
    (check (parse-tree '()) => '())
    (check (parse-tree '((noun "it"))) => '((noun "it")))
    (check (parse-tree '((s vp) (vp verb np) (verb "do")
                         (np pronoun) (pronoun "it")))
           => '(s (vp (verb "do") (np (pronoun "it")))))
    (check (parse-tree steps1) => tree1)
    ))


(define (all-non-terminals rules)
  (unique (apply append rules)))

(define (lexical? rule) (string? (cadr rule)))
(define (head rule)  (car rule))
(define (body rule)  (cdr rule))
(define (body1 rule) (cadr rule))
(define (body2 rule) (caddr rule))
(define (word rule)  (cadr rule))
(define true? identity)
(define (constant x) (lambda args x))

(define (find-rules/head h rules)
  (filter (pair-type? h) rules))

(define-unit-test 'lc-parse
  (let ((grammar1
         '((s (np vp) (aux np vp) (vp))
           (np (proper-noun) (det nom))
           (nom (noun) (noun nom) (nom pp))
           (vp (verb) (verb np))
           (pp (prep np))
           (det "that" "this" "a")
           (noun "book" "flight" "meal" "money")
           (verb "book" "include" "prefer")
           (aux "does")
           (prep "from" "to" "on")
           (proper-noun "Houston" "TWA")
           ))
        (grammar2
         `((s (np vp) (vp))
           (np (art noun))
           (vp (verb np))
           (art "the" "a")
           (noun "man" "ball" "saw" "woman" "table" "noun" "verb" "book")
           (verb "hit" "took" "saw" "liked")
           )))
    (check (lc-parse '("the" "man" "took" "the" "book") grammar2)
           => '(((s np vp) (np art noun) (art "the") (noun "man")
                 (vp verb np) (verb "took")
                 (np art noun) (art "the") (noun "book"))))
    ;; (check (lc-parse '("book" "this" "flight") grammar1)
    ;;	    => '(((s vp) (vp verb np) (verb "book")
    ;;		  (np det nom) (det "this") (nom noun) (noun "flight"))))
    ))


(unit-tests/clear 'viable-lc-rules 'expand-grammar 'create-lexicon
                  'left-corner-table 'parse-tree 'lc-parse)