guile-derivative-parsers/derivative/language/context-free.scm

;;; Copyright © 2016 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This program is free software.  You may run, copy, modify, and
;;; redistribute it under the terms of the GNU General Purpose License
;;; (GPL) version 3, or any later version.

;;; Derived (pun intended) from Matt Might, Dacid Darais, and Daniel
;;; Spiewak's paper "Parsing with Derivatives, A Functional Pearl" ACM
;;; 978-1-4503-086-6/11/09

(define-module (derivative language context-free)
  #:use-module (ice-9 match)
  #:use-module (derivative language)
  #:use-module (derivative utils fix)
  #:use-module (derivative utils memoize)
  #:re-export (<alt> alt?
	       <cat> cat?
	       <rep> rep?)
  #:export (alt cat rep

	    δ nullable?
	    D derivative
	    recognize?
	    
	    ;; test/example languages
	    d-lang
	    S-lang
	    N-lang
	    xyz-lang
	    rep-lang
	    parens-lang
	    ab-lang
	    aab-lang
	    palindrome-lang
	    double-lang))

(define-syntax alt
  (syntax-rules ()
    ((_) 'empty)
    ((_ L) L)
    ((_ L L* ...)
     ((@@ (derivative language) make-alt) (delay L) (delay (alt L* ...))))))

(define-syntax cat
  (syntax-rules ()
    ((_) 'eps)
    ((_ L) L)
    ((_ L L* ...)
     ((@@ (derivative language) make-cat) (delay L) (delay (cat L* ...))))))

(define-syntax rep
  (syntax-rules ()
    ((_) 'empty)
    ((_ L) ((@@ (derivative language) make-rep) (delay L)))))

(define δ
  (fix* #f (match-lambda
	     ('empty #f)
	     ('eps #t)
	     ((? char?) #f)
	     (($ <rep> _) #t)
	     (($ <alt> L L')
	      (or (δ (force L)) (δ (force L'))))
	     (($ <cat> L L')
	      (and (δ (force L)) (δ (force L')))))))
(define nullable? δ)

(define D
  (memoize
   (lambda (c language)
    (match language
      ('empty 'empty)
      ('eps 'empty)
      ((? char? a) (if (eq? a c)
		       'eps
		       'empty))
      (($ <alt> L L')
       (alt (D c (force L)) (D c (force L'))))
      (($ <cat> (= force (? δ L)) L')
       (alt (D c (force L'))
	    (cat (D c L) (force L'))))
      (($ <cat> L L')
       (cat (D c (force L)) (force L')))
      (($ <rep> L)
       (cat (D c (force L)) language))))))
(define derivative D)

(define (recognize? w L)
  (match w
    ((? string?)
     (recognize? (string->list w) L))
    (()
     (δ L))
    ((head tail ...)
     (recognize? tail (D head L)))))

;;; Define some test/example languages

(define d-lang
  (alt (cat d-lang #\d)
       'eps))
(define S-lang
  (alt (cat S-lang #\x)
       'eps))
(define N-lang
  (alt (cat N-lang #\+ N-lang)
       #\N))			;kleene plus
(define xyz-lang
  (alt (cat xyz-lang (cat #\x #\y #\z))
       (cat #\x #\y #\z)))
(define rep-lang
  (rep #\a))
(define parens-lang
  (alt (cat parens-lang parens-lang)
       (cat #\( parens-lang #\))
       'eps))
(define ab-lang
  (alt (cat #\a ab-lang #\b)
       (cat #\a #\b)))
(define aab-lang
  ;; L = {a^nb^m; n>m}
  (letrec ((S' (alt (cat #\a S' #\b) 'eps))
	   (A  (alt (cat #\a A) #\a)))
    (cat A S')))
(define palindrome-lang
  (alt (cat #\a palindrome-lang #\a)
       (cat #\b palindrome-lang #\b)
       'eps))
(define double-lang
  (alt (cat #\a double-lang #\b)
       (cat double-lang double-lang)
       'eps))				;e.g. abaabb, aababb, ababab