;; CFG-Rules

(defparameter *rule-tag* '*rule-tag*)
(defun make-rule (lhs first-rhs &rest rest-rhs)
  `(,*rule-tag* ,lhs . (,first-rhs ,@rest-rhs)))
(defun is-rule (x)
  (and (consp x)
       (eq (first x) *rule-tag*)))
(defun rule-error (f x)
  (error "In ~a -- Expected a rule, but got ~a of type ~a"
         f x (type-of x)))
(defun copy-rule (rule)
  (cond ((is-rule rule)
         (apply #'make-rule (lhs rule) (copy-list (rhs rule))))
        (t (rule-error 'copy-rule rule))))

(defun lhs (rule)
  (cond ((is-rule rule)
         (second rule))
        (t (error "In lhs -- Expected a rule, but got ~a of type ~a"
                  rule (type-of rule)))))
(defun rhs (rule)
  (cond ((is-rule rule)
         (cddr rule))
        (t (error "In rhs -- Expected a rule, but got ~a of type ~a"
                  rule (type-of rule)))))
(defun print-rule (rule &optional (stream *standard-input*))
  (cond ((is-rule rule)
         (format stream "{Rule: ~a -> ~a~{ ~a~}}"
                (lhs rule) (first (rhs rule))
                (rest (rhs rule))))))

;; Grammar

(defun grammar-error (f x y)
  (error "In ~a -- Expected a grammar and a rule,~
          but got ~a and ~a of type ~a and ~a"
         f x y (type-of x) (type-of y)))

(defparameter *grammar-tag* '*grammar-tag*)
(defun make-grammar (&key (name "No-name")
                          (start-symbol nil)
                          (non-terminals nil)
                          (terminals nil)
                          )
  `(,*grammar-tag*
    (name . ,name)
    (start-symbol . ,start-symbol)
    (non-terminals . ,non-terminals)
    (terminals . ,terminals)
    (rules . nil) ;; assoc list
    ))

(defmacro grammar-name (grammar) `(cdr (second ,grammar)))
(defmacro grammar-start-symbol (grammar) `(cdr (third ,grammar)))
(defmacro grammar-non-terminals (grammar) `(cdr (fourth ,grammar)))
(defmacro grammar-terminals (grammar) `(cdr (fifth ,grammar)))
(defmacro grammar-rules (grammar) `(cdr (sixth ,grammar)))

(defun is-grammar (x)
  (and (consp x)
       (eq (car x) *grammar-tag*)))

(defun print-grammar (grammar &optional (stream *standard-input*))
  (cond ((is-grammar grammar)
         (format stream "#<Grammar ``~a'' with ~a rules.~
                       ~%  Start-Sym: ~a~
                       ~%  Non-Terminals: ~a~
                       ~%  Terminals: ~a~
                       ~%  and the following rules:"
                 (grammar-name grammar)
                 (length (grammar-rules grammar))
                 (grammar-start-symbol grammar)
                 (grammar-non-terminals grammar)
                 (grammar-terminals grammar))
         (mapc #'(lambda (assoc)
                   (format stream "~%    ")
                   (print-rule (cdr assoc)))
               (grammar-rules grammar))
         (format stream ">")
         t)
        (t (warn "In print-grammar -- Expected a grammar but got ~a of type ~a"
                 grammar (type-of grammar)))))

(defun add-rule (grammar rule)
  (cond ((and (is-grammar grammar)
              (is-rule rule))
         (setf (grammar-rules grammar)
           (acons (lhs rule) rule (grammar-rules grammar)))
         grammar)
        (t (grammar-error 'add-rule grammar rule))))

(defun find-all-rules-with-lhs (grammar sym)
  (cond ((and (is-grammar grammar)
              (symbolp sym))
         (mapcan #'(lambda (assoc)
                     (when (eq sym (car assoc))
                       (list (cdr assoc))))
                 (grammar-rules grammar)))))
(defun find-all-rules-with-first-rhs (grammar sym)
  (cond ((and (is-grammar grammar)
              (symbolp sym))
         (mapcan #'(lambda (assoc)
                     (when (eq sym (first (rhs (cdr assoc))))
                       (list (cdr assoc))))
                 (grammar-rules grammar)))))

(defun add-grammar-from-file (grammar path)
  (cond ((is-grammar grammar)
         (with-open-file (stream path)
           ;; Read name -- a string
           (setf (grammar-name grammar)
             (string-trim '(#\space #\tab) (read-line stream)))
           ;; Start symbol
           (setf (grammar-start-symbol grammar)
             (read-from-string (read-line stream)))
           ;; non-terminals 
           (setf (grammar-non-terminals grammar)
             (read-from-string
              (concatenate 'string
                "(" (read-line stream nil "") ")")))
           ;; terminals
           (setf (grammar-terminals grammar)
             (read-from-string
              (concatenate 'string
                "(" (read-line stream nil "") ")")))
           ;; rules -- S -> NP VP
           (loop for row = (read-line stream nil "eof")
               for row-as-list = (read-from-string
                                (concatenate 'string
                                  "(" row ")"))
               until (equal row "eof")
               do (add-rule
                   grammar
                   (apply #'make-rule
                          (first row-as-list)
                          (cddr row-as-list)))))
         grammar)
        (t (grammar-error
            'add-grammar-from-file
            grammar path))))