first commit

Author: cmikewilson

LICENSE

@@ -0,0 +1,15 @@
+BSD Zero Clause License
+
+Copyright (c) 2025 Mike Wilson
+
+Permission to use, copy, modify, and/or distribute this software for any
+purpose with or without fee is hereby granted.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
+PERFORMANCE OF THIS SOFTWARE.
+

README

@@ -0,0 +1,9 @@
+A library of parsing routines
+
+These were written using Scheme48 and uses its package system.
+I was mostly interested in the Earley parser.
+I barely remember writing the others.
+I can't say for sure what is finished and what isn't.
+
+Mike
+

bu-parser.scm

@@ -0,0 +1,175 @@
+;;; 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)