;;;==========================================================================
;;;                   Simple 3-LISP Expression Recognizer
;;;==========================================================================
;;;
;;; Recognizes 3-LISP expressions including rails, pairs and simple symbols.
;;; Does not handle numerals, handles, strings, or booleans.

;;; Assumed grammar:  (<token> is the primitive lexical item)
;;;
;;;     <expression> ::= <rail-exp> | <pair-exp> | <identifier>
;;; 
;;;     <rail-exp>   ::= "[" <expression>* "]"
;;;     <pair-exp>   ::= "(" <expression>+ ")"
;;;     <identifier> ::= <alphanumeric token>

;;; RECOGNIZE  Main recognition routine.  Returns a message
;;; =========  identifying whether or not the STRING encodes a single
;;;            well-formed 3-LISP expression.  This version ignores
;;;            the information signaled by an error.

(define recognize
   (lambda [string]
      (init-lex)
      (setup-lex string)      
      (let [[answer (error-protect (recognize-expression)
                         (lambda [message]
                            (if (= message "Recognition error")
                                $false
                                (error message 'passed-on))))]]
         (if (and answer (= (next-token) 'eot))
             "Accepted"
             "Rejected"))))

;;; Ancillary recognition functions:
;;;
;;;    All the following recognition functions are responsible for
;;;    recognizing just one type of 3-LISP expression.  They use
;;;    GET-TOKEN etc. from the lexical-analyser package, which are set
;;;    up by a call to INIT-LEX.  Thus they require a call to SETUP-LEX 
;;;    before running (as is done by RECOGNIZE above).  They all call
;;;    the procedure ERROR-IN-RECOGNITION immediately upon finding a
;;;    syntactic error of any sort, which should not return, as the
;;;    procedures below are not guaranteed to do anything sensible
;;;    about continuing from errors.  ERROR-IN-RECOGNITION simply
;;;    causes an error, which is caught by the ERROR-PROTECT in 
;;;    RECOGNIZE, above.

;;; RECOGNIZE-EXPRESSION  Attempts to recognize an arbitrary 3-LISP
;;; ====================  expression.

(define RECOGNIZE-EXPRESSION
   (lambda []
      (select (next-token)
         ["[" (recognize-rail)]
         ["(" (recognize-pair)]
         [$true (recognize-identifier)])))


;;; RECOGNIZE-RAIL  attempts to recognize a 3-LISP rail expression
;;; ==============

(define RECOGNIZE-RAIL
   (lambda []
      (get-token)                        ; skip the open bracket
      (recognize-exp-list "]")
      (get-token)                        ; skip the close bracket   
      $true))


;;; RECOGNIZE-EXP-LIST  attempts to recognize a list of 3-LISP expressions
;;; ==================  delimited by (but not including) the token
;;;                     ENDING-TOKEN.

(define RECOGNIZE-EXP-LIST
   (lambda [ending-token]
      (if (= (next-token) ending-token)
          $true
          (begin (recognize-expression)
                 (recognize-exp-list ending-token)))))


;;; RECOGNIZE-PAIR  attempts to recognize a 3-LISP pair expression
;;; ==============

(define RECOGNIZE-PAIR
   (lambda []
      (get-token)                        ; skip the open parenthesis
      (recognize-expression)             ; there must be at least one exp. 
      (recognize-exp-list ")")
      (get-token)                        ; skip the close parenthesis
      $true))


;;; RECOGNIZE-IDENTIFIER  attempts to recognize a 3-LISP identifier
;;; ====================

(define RECOGNIZE-IDENTIFIER
   (lambda []
      (let [[tok (get-token)]]
         (cond [(member tok ['eot "[" "]" "(" ")"])
                (error-in-recognition tok)]
               [(every-character
                   (lambda [ch] (not (member ch *special-chars*)))
                   tok)
                $true]
               [$true (error-in-recognition tok)]))))

;;; ERROR-IN-RECOGNITION   Signals an error.
;;; ====================

(define ERROR-IN-RECOGNITION
   (lambda [string]
      (error "Recognition error" ↑string)))


(define EVERY-CHARACTER
   (lambda [predicate string]
      (cond [(string-null string) $true]
            [(predicate (string-first string))
             (every-character predicate (string-rest string))]
            [$true $false])))