;Copyright (C) 1993 by Matthew Belmonte.
;
;This is a recursive-descent parser for a language of well-formed formulae (WFF's) in the
;propositional calculus.  It demonstrates techniques to be understood and used in the
;design of your PURPLE parser, part of the final project for Theoretical Foundations of
;Computer Science at CTY.  This version of the WFF parser was prepared by Matthew Belmonte,
;based on his implementation of the same algorithm in Pascal.

;grammar for WFFs:
;Formula -> WFF end-token
;WFF -> WFF term-op Term | Term
;term-op -> implies-token | equiv-token
;Term -> Term arg-op Argument | Argument
;arg-op -> and-token | or-token
;Argument -> not-token Argument | left-p-token WFF right-p-token | identifier-token

;lexical definitions:
;end-token: .
;implies-token: =>
;equiv-token: =
;and-token: AN
;or-token: OR
;not-token: ~
;left-p-token: (
;right-p-token: )
;identifier-token: A | B | C | ... | Z

;Note that the two left-recursive productions WFF -> WFF term-op Term and
;Term -> Term arg-op Argument can be expressed as regular expressions
;WFF -> Term [term-op Term]* and Term -> Argument [arg-op Argument]*, respectively.
;The parsing functions for these symbols act according to such a translation.

;tree constructors
(define make-leaf
  (lambda (val)
    (cons val '())))

(define make-unary-node
  (lambda (parent child)
    (cons parent (cons child '()))))

(define make-binary-node
  (lambda (parent left-child right-child)
    (cons parent (cons left-child (cons right-child '())))))

;tree extractors (in a case in which it's possible for a node in the tree to have more than two
;children, you can construct a more general tree extractor by defining and instantiating a
;curried extractor).

(define root first)

(define left-child
  (lambda (tree)
    (first (rest tree))))

(define right-child
  (lambda (tree)
    (first (rest (rest tree)))))

;parsing functions

(define parse-identifier
  (lambda (token)
    (cond
      [(eq? (type token) 'identifier-token) (make-leaf (value token))]
      [else (error "unexpected token " (type token))])))

;Notice the use of "let" here.  This serves two purposes: it defines the order in which tokens
;are consumed from the input stream, and it allows actions, such as checking for a right
;parenthesis, to occur between the time the tree is parsed and the time it is returned.  You
;will find many similar uses of "let" in the functions that follow.

(define parse-argument
  (lambda (token)
    (cond
      [(eq? (type token) 'not-token) (make-unary-node 'not-token (parse-argument (get-next-token)))]
      [(eq? (type token) 'left-p-token)
       (let ((tree (parse-wff (get-next-token))))
         (cond
           [(eq? (type (get-next-token)) 'right-p-token) tree]
           [else (error "missing right parenthesis")]))]
      [else (parse-identifier token)])))

(define parse-term
  (lambda (token)
    (let ((first-argument (parse-argument token)))
      (parse-argument-suffix (get-next-token) first-argument))))

;Note the similarity between the functions parse-argument-suffix and parse-term-suffix.  This is
;natural because the grammar productions that implement terms and arguments are similar.  It's
;possible to replace these two similar functions with a more general one that takes a few more
;parameters.  You might want to do something like this when you write your parser.  Keep in mind
;that a function can take another function as a parameter.  So for example if a function
;parse-X is passed another parsing function, parse-Y, as a parameter, parse-X can apply parse-Y
;without knowing exactly what parse-Y does.

;invariant: left-tree is a parse tree that represents all the Arguments in the Term that are to
;the left of operator.
;bound: the number of Arguments in this Term that remain to be parsed.
(define parse-argument-suffix
  (lambda (operator left-tree)
    (cond
      [(or (eq? (type operator) 'and-token) (eq? (type operator) 'or-token))
       (let ((new-left-tree (make-binary-node (type operator) left-tree (parse-argument (get-next-token)))))
         (parse-argument-suffix (get-next-token) new-left-tree))]
      [else (begin (save-token operator) left-tree)])))

(define parse-wff
  (lambda (token)
    (let ((first-term (parse-term token)))
      (parse-term-suffix (get-next-token) first-term))))

;invariant: left-tree is a parse tree that represents all the Terms in this WFF that are to the
;left of operator.
;bound: the number of Terms in this WFF that remain to be parsed.
(define parse-term-suffix
  (lambda (operator left-tree)
    (cond
      [(or (eq? (type operator) 'implies-token) (eq? (type operator) 'equiv-token))
       (let ((new-left-tree (make-binary-node (type operator) left-tree (parse-term (get-next-token)))))
         (parse-term-suffix (get-next-token) new-left-tree))]
      [else (begin (save-token operator) left-tree)])))

;top-level parsing function
(define parse-formula
  (lambda ()
    (begin
      (init-parser)
      (let ((formula (parse-wff (get-next-token))))
        (cond
          [(eq? (type (get-next-token)) 'end-token) formula]
          [else (error "expected '.'")])))))