bu-parser.scm

;;; bottom-up-parser.scm

;;; PAIP 19.1

(define 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")
    ))

(define grammar2
  `((s (np vp))
    (np (art noun))
    (vp (verb np))
    (art "the" "a")
    (noun "man" "ball" "woman" "table" "noun" "verb")
    (verb "hit" "took" "saw" "liked")
    ))

(define (expand-grammar grammar)
  ;; expand grammar shorthand: ((head body1 body2 ...) ...)
  ;; to ((head body1) (head body2) ...)
  (define (process rule)
    (let ((head   (car rule))
	  (bodies (cdr rule)))
      (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 grammar1)
         => '((s np vp) (s aux np vp) (s vp)
              (np proper-noun) (np det nom)
              (nom noun) (nom noun nom) (nom nom pp)
              (vp verb) (vp verb np) (pp prep np)
              (det "that") (det "this") (det "a")
              (noun "book") (noun "flight") (noun "meal") (noun "money")
              (verb "book") (verb "include") (verb "prefer")
              (aux "does") (prep "from") (prep "to") (prep "on")
              (proper-noun "Houston") (proper-noun "TWA")))
  (check (expand-grammar grammar2)
         => '((s np vp) (np art noun) (vp verb np)
              (art "the") (art "a")
              (noun "man") (noun "ball") (noun "woman") (noun "table")
              (noun "noun") (noun "verb")
              (verb "hit") (verb "took") (verb "saw") (verb "liked"))))


;; rule = (head cat1 ...) or (head "word")
(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 (create-lexicon grammar)
  ;; expanded grammar
  ;; lexicon is (("word" (cat1 ...)) ...)
  (partition lexical? grammar
    (lambda (rules _)
      (let ((f (lambda (rule lexicon)
		 (alist-add-value (word rule) (head rule) lexicon))))
	(reverse (fold f '() rules))))))


(define-unit-test 'create-lexicon
  (check (create-lexicon (expand-grammar grammar1))
         => '(("that" det) ("this" det) ("a" det)
              ("book" verb noun) ("flight" noun) ("meal" noun) ("money" noun)
              ("include" verb) ("prefer" verb) ("does" aux)
              ("from" prep) ("to" prep) ("on" prep)
              ("Houston" proper-noun) ("TWA" proper-noun))))

(define grammar (expand-grammar grammar2))
(define lexicon (create-lexicon grammar))

;; '("the" "man" "took" "the" "ball")
;; "the" '("man" "took" "the" "ball")
;; "the" '(art) '("man" "took" "the" "ball")
;;   "the" 'art '("man" "took" "the" "ball")
;;   '(art "the") '(np art noun) '("man" "took" "the" "ball")
;;     "man" '("took" "the" "ball") noun?
;;     "man" '(noun) '("took" "the" "ball") noun?
;;       '((art "the") (noun "man")) '((s np vp)) '("took" "the" "ball")
;;         '((art "the") (noun "man")) '(s np vp) '("took" "the" "ball")
;;         "took" vp? '((art "the") (noun "man")) '(s np vp) '("the" "ball")

(define (parse words)
  (define (parsem nt)
    (parse/main 's (list nt (car words)) (cdr words)))
  (let* ((possible-nts (alist-lookup (car words) lexicon))
	 (parses (map parsem possible-nts)))
    (list-remove '() parses))
  )

(define (parse/main looking-for tree words) #f)
  



(define (bottom-up-parse words)
  (map parse-tree (complete-parses (parse words))))

(define (complete-parses parses)
  #f)

(define (parse words)
  (if (null? words)
      '()
      (let ((nts (alist-lookup (car words) lexicon)))
	(map (lambda (nt)
	       (extend-parse nt (list (car words)) (cdr words) '()))
	     nts))))

(define (parse-tree l) #f)

(define (extend-parse h b rem needed)
  (if (null? needed)
      (parse-up h b rem)
      (parse-right h b rem needed)))

(define (parse-up h b rem)
  (let ((tree (list h b))
	(rules (find-rules/left-body h)))
    (cons 1;tree+rem
	  (map (lambda (rule)
		 (extend-parse (head rule) (list tree) rem (cddr rule)))
	       rules))))

(define (parse-right h b rem needed)
  (map (lambda (t)
	 (if (eq? (car t) (car needed))
	     (extend-parse h (append b t) rem (cdr needed))
	     '()))
       (parse rem)))

(define (find-rules/left-body h grammar)
  (filter (lambda (rule) (eq? h (body1 rule))) grammar))


(define (sr-parse words)
  (let loop ((stack '()) (words words))
    (cond ((null? words)
	   #f))))

;;; the dog saw a man in the park
;;; the | dog saw a man in the park
;;; (det the) | dog saw a man in the park
;;; (det the) dog | saw a man in the park
;;; (det the) (n dog) | saw a man in the park
;;; (np (det the) (n dog)) | saw a man in the park
;;; (np (det the) (n dog)) saw | a man in the park
;;; (np (det the) (n dog)) (v saw) | a man in the park
;;; (np (det the) (n dog)) (v saw) a | man in the park
;;; (np (det the) (n dog)) (v saw) (det a) | man in the park
;;; (np (det the) (n dog)) (v saw) (det a) man | in the park
;;; (np (det the) (n dog)) (v saw) (det a) (n man) | in the park
;;; (np (det the) (n dog)) (v saw) (np (det a) (n man)) | in the park
;;; (np (det the) (n dog)) (vp (v saw) (np (det a) (n man))) | in the park


(unit-tests 'expand-grammar 'create-lexicon)