;; Datum grammar acceptors - Procedural interface.

;; Copyright (c) 2007 David Van Horn
;; Licensed under the Academic Free License version 3.0

;; <[email protected]>

(module grammar-procedures mzscheme
  (require (lib "contract.ss"))
  
  ;;; context-free acceptor cfa: [input] -> trial
  ;;; input, output: list of objects
  ;;; trial: (union #f #t output)
  ;;;   #f: the cfa failed to accept
  ;;;   #t: the cfa failed through report-if-bad
  ;;;   output: tail of list after cfa has accepted some prefix
  ;;; element: (union cfa datum)
  
  (define input/c   (listof any/c))
  (define output/c  (listof any/c))
  (define datum/c   (not/c procedure?))
  (define trial/c   (or/c boolean? output/c))
  (define cfa/c     (-> input/c trial/c))
  (define element/c (or/c cfa/c datum/c))
  
  (provide/contract
   [try       (-> element/c input/c cfa/c trial/c)]
   [predicate (-> procedure? cfa/c)]
   
   ;; FIXME:
   [alt (->* () (listof any/c #;element/c) (cfa/c))]
   [seq (->* () (listof any/c #;element/c) (cfa/c))]
   [lst (->* () (listof any/c #;element/c) (cfa/c))]
   
   [star (-> element/c cfa/c)]
   [plus (-> element/c cfa/c)]
   [opt  (-> element/c cfa/c)]
   [dot  (-> element/c element/c cfa/c)]
   
   [report-if-bad  (-> symbol? cfa/c cfa/c)]   
   [cfa->predicate (-> cfa/c (-> any/c boolean?))]
   [cfa any/c])
  
  
  (define grammar-input
    (lambda (x)
      (if (or (pair? x) (null? x))
	x
	#f)))
  
  (define try ; [element input cfa] -> trial
    (lambda (element input cfa)
      (if (procedure? element)
	(let ((trial (element input)))
	  (or (and (grammar-input trial) (cfa trial))
	    trial))
	(and (pair? input)
	  (equal? element (car input))
	  (cfa (cdr input))))))

  (define predicate ; [predicate] -> cfa
    (lambda (pred)
      (lambda (input)
	(and (pair? input)
	  (pred (car input))
	  (cdr input)))))

  (define alt ; (list element) -> cfa
    (lambda elements
      (lambda (input)
	(let loop ((elements elements))
	  (and (not (null? elements))
	    (or (try (car elements) input (lambda (x) x))
	      (loop (cdr elements))))))))

  (define seq ; (list element) -> cfa
    (lambda elements
      (let loop ((elements elements))
	(lambda (input)
	  (if (null? elements)
	    input
	    (try (car elements) input
	      (loop (cdr elements))))))))

  (define lst ; (list element) -> cfa
    (lambda elements
      (lambda (input)
	(and (pair? input)
	  (list? (car input))
	  (try (apply seq elements)
	    (car input)
	    (lambda (trial)
	      (and (null? trial) (cdr input))))))))

  (define star ; [element] -> cfa
    (lambda (element)
      (lambda (input)
	(if (null? input) input
	  (let ((trial (try element input (lambda (x) x))))
	    (if (grammar-input trial)
	      ((star element) trial)
	      (or trial input)))))))

  (define plus ; [element] -> cfa
    (lambda (element)
      (seq element (star element))))

  (define opt ; [element] -> cfa
    (lambda (element)
      (alt (seq element) (seq))))

  (define dot ; [element element] -> cfa
    (lambda (prefix-element suffix-element)
      (lambda (input)
	(and (pair? input)
	  (pair? (car input))
	  (not (list? (car input)))
	  (let loop ((object (car input)) (ls '()))
	    (if (pair? object)
	      (loop (cdr object) (cons (car object) ls))
	      (and ((seq prefix-element) (reverse ls))
		((seq suffix-element) (list object))
		(cdr input))))))))

  (define report-if-bad ; [symbol cfa] -> cfa
    (lambda (name cfa) ; assume cfa accepts (car input)
      (lambda (input)
	(or (grammar-input (cfa input))
            ;(parameterize ((print-level 2))
            (begin
              (if (pair? input) (printf "Bad ~s: ~s~n" name (car input)))
              #t)))))

  (define cfa->predicate
    (lambda (cfa)
      (lambda (object)
	(and (null? (cfa (list object))) #t))))
  
  (define cfa
    (lambda (cfa) cfa))
  
  )