;;; Code stored as:  {turing}<3-lisp.problem-sets>sample-grammars.3-lisp
;;;                  {phylum}<3-lisp>course>problem-sets>sample-grammars.3-lisp


;;; =======================================================================

;;; Sample grammars:

(set *G*
     [['s (lambda [np] (lambda [vp] ['s np vp])) 'np 'vp]
      ['vp (lambda [v] (lambda [np] ['vp v np])) 'v 'np]
      ['vp (lambda [v] ['vp v]) 'v]
      ['v (lambda [lex] ['v lex]) "slept"]
      ['v (lambda [lex] ['v lex]) "loved"]
      ['v (lambda [lex] ['v lex]) "wielded"]
      ['np (lambda [lex] ['np lex]) "arthur"]
      ['np (lambda [lex] ['np lex]) "gwen"]
      ['np (lambda [lex] ['np lex]) "excalibur"]
     ])

(set montague-gram
     [['s (lambda [np] (lambda [vp] (pcons vp np))) 'np 'vp]
      ['vp (lambda [v] (lambda [np] (pcons v np))) 'v 'np]
      ['vp (lambda [v] v) 'v]
      ['v (lambda [lex] 'sleep/ ) "slept"]
      ['v (lambda [lex] 'love/ ) "loved"]
      ['v (lambda [lex] 'wield/ ) "wielded"]
      ['np (lambda [lex] 'arthur/ ) "arthur"]
      ['np (lambda [lex] 'gwen/ ) "gwen"]
      ['np (lambda [lex] 'excalibur/ ) "excalibur"]
     ])

(set 3L-description-grammar
     [['expr (lambda [pair] ['expr pair])
             'pair] 
      ['expr (lambda [rail] ['expr rail])
             'rail] 
      ['expr (lambda [atom] ['expr ['atom atom]])
             'identifier-expression] 
      ['expr (lambda [numexpr] ['expr ['numeral numexpr]])
             'numeral-expression]
      ['pair (lambda [paren]
                (lambda [fun]
                   (lambda [args] ['pair fun (cons 'pair-args args)])))
             "(" 'expr 'pair-args]
      ['pair-args (lambda [paren] [])
                  ")"]
      ['pair-args (lambda [first]
                     (lambda [rest] (cons first rest)))
                  'expr 'pair-args]
      ['rail (lambda [bracket]
                (lambda [elements] (cons 'rail elements)))
             "[" 'rail-args]
      ['rail-args (lambda [bracket] [])
                  "]"]
      ['rail-args (lambda [first]
                     (lambda [rest] (cons first rest)))
                  'expr 'rail-args]])

(set 3L-recognition-grammar
     [['expr id 'pair] 
      ['expr id 'rail] 
      ['expr id 'identifier-expression]
      ['pair (lambda [pren] (lambda [fun] (lambda [args] $true)))
             "(" 'expr 'pair-args]
      ['pair-args (lambda [pren] $true) ")"]
      ['pair-args (lambda [first] (lambda [rest] $true))
                  'expr 'pair-args]
      ['rail (lambda [brak] (lambda [elements] $true))
             "[" 'rail-args]
      ['rail-args (lambda [brak] $true) "]"]
      ['rail-args (lambda [first] (lambda [rest] $true))
                  'expr 'rail-args]])

(set 3L-structure-grammar
     [['expr id 'pair] 
      ['expr id 'rail] 
      ['expr (lambda [tok] (atom-notated tok)) 'identifier-expression]
      ['expr (lambda [numexp]
                (internalize (string-append numexp " ")))
             'numeral-expression]
      ['pair (lambda [paren]
                (lambda [fun]
                   (lambda [args]
                      (pcons fun (rcons . args)))))
             "(" 'expr 'pair-args]
      ['pair-args (lambda [paren] [])
                  ")"]
      ['pair-args (lambda [first]
                     (lambda [rest] (cons first rest)))
                  'expr 'pair-args]
      ['rail (lambda [bracket]
                (lambda [elements] (rcons . elements)))
             "[" 'rail-args]
      ['rail-args (lambda [bracket] []) "]"]
      ['rail-args (lambda [first]
                     (lambda [rest] (cons first rest)))
                  'expr 'rail-args]])

(define NORM
   (lambda [exp]
      (normalize exp global standard-escape id)))

(set 3L-process-grammar
     [['expr id 'pair] 
      ['expr id 'rail] 
      ['expr
       (lambda [tok] (binding (atom-notated tok) global))
       'identifier-expression]
      ['expr
       (lambda [numexp] (internalize (string-append numexp " ")))
       'numeral-expression]
      ['pair
       (lambda [paren]
          (lambda [fun]
             (lambda [args]
                (norm (pcons fun (rcons . args))))))
       "(" 'expr 'pair-args]
      ['pair-args
       (lambda [paren] [])
       ")"]
      ['pair-args
       (lambda [first]
          (lambda [rest]
             (cons first rest)))
       'expr 'pair-args]
      ['rail
       (lambda [bracket]
          (lambda [elements]
             (norm (rcons . elements))))
       "[" 'rail-args]
      ['rail-args
       (lambda [bracket] [])
       "]"]
      ['rail-args
       (lambda [first]
          (lambda [rest]
             (cons first rest)))
       'expr 'rail-args]])