(defpackage :elk
  (:use :nyala :cl)
  (:shadow #:merge #:step))

(in-package :elk)

(defun glr-resolver (cat shifts reduces)
  (declare (ignore cat))
  (append shifts reduces))

;; This implementation is straight from the one given in Scott McPeak,
;; "Elkhound: A Fast, Practical GLR Parser Generator".

;; The pseudocode misses that a reduction may be followed by another right
;; away, actually any number of them. We fixed that in REDUCE-VIA-PATH by
;; checking each reduction for another an queueing them as well. [Marked by
;; "New:"] This leads to that *PATH-QUEUE* must in fact be a FIFO. We're not
;; entirely confident that this is the right thing to do. The alternative
;; would be to treat goto(Q,N) as a set and apply them all.

;;; Note

;; I really don't like all this special casing for the top category here. We
;; should rather seek to modifier lalr.lisp so that it makes us a nice accept
;; state we end up in when the was accepted. And leaves room for a failed
;; state as well.

(defvar *top-most*)
(defvar *path-queue*)
(defvar *table*)
(defvar *last-good-tok* nil)
(defvar *eval-queue* nil)

(declaim (inline stack-node-p make-stack-node stack-node-state stack-node-nexts))

(defstruct stack-node
  state                                 ;state number we're in
  nexts)                                ;list of links

(declaim (inline link-p make-link link-val link-from link-to))

(defstruct link
  val                                ;semantic value
  from                               ;stack-node coming from (the right one)
  to                                 ;stack-node going to (the left one)
  )

(declaim (inline make-path path-left-sib path-links))
(defun make-path (&key left-sib links)
  (cons left-sib links))
(defun path-left-sib (p) (car p))
(defun path-links (p) (cdr p))

(defvar *reduce-cache*)
(defvar *shift-cache*)
(defvar *goto-cache*)

(defun state-reduces (state cat)
  ;; ###
  (and (>= state 0)
       (let ((cache (svref *reduce-cache* state)))
         (let ((key cat))
           (declare (dynamic-extent key))
           (multiple-value-bind (res win) (gethash key cache)
             (if win res
                 (let ((key cat))
                   (let ((table *table*))
                     (setf (gethash key cache)
                           (remove-if-not #'nyala::reduce-action-p
                                          (ignore-errors
                                            (actions table state cat))))))))))))

(defun state-shifts (state cat)
  (let ((key (cons state cat)))
    (declare (dynamic-extent key))
    (multiple-value-bind (res win) (gethash key *shift-cache*)
      (if win res
          (let ((key (cons state cat)))
            (let ((table *table*))
              (setf (gethash key *shift-cache*)
                    (and (>= state 0)
                         (mapcar #'nyala::shift-action-goto
                                 (remove-if-not #'nyala::shift-action-p (actions table state cat)))))))))))

(defun goto (state nonterm)
  (let ((key (cons state nonterm)))
    (declare (dynamic-extent key))
    (multiple-value-bind (res win) (gethash key *goto-cache*)
      (if win res
          (let ((key (cons state nonterm)))
            (let ((table *table*))
              (setf (gethash key *goto-cache*)
                    (if (eq nonterm nyala::*topcat*)
                        -1
                        (nyala::shift-action-goto (car (actions *table* state nonterm)))))))))))

(defmacro enqueue (item place)
  `(push ,item ,place))

(defun do-reductions (token)
  (dolist (current *top-most*)
    (enqueue-reductions current token))
  (setq *eval-queue* nil)
  (do () ((null *path-queue*))
    (destructuring-bind (a p) (pop *path-queue*)
      (reduce-via-path a p token)))
  (dolist (k *eval-queue*)
    (ensure-evaluated k)))

(defun ensure-evaluated (link)
  ;; As feared this may result in infinite recursion. We may need to sort.
  (typecase (link-val link)
    ((cons (member :apply))
     (setf (link-val link)
           (apply (cadr (link-val link))
                  (mapcar #'ensure-evaluated (cddr (link-val link))))))
    ((cons (member :merge))
     (setf (link-val link)
           (apply #'merge (mapcar #'ensure-evaluated (cdr (link-val link)))))))
  (link-val link))

(defun do-shifts (token)
  (cond #+NIL
        ((and *top-most* (eql -1 (stack-node-state (car *top-most*))))
         (setq *top-most* (remove -1 *top-most* :test-not 'eql :key #'stack-node-state)))
        (t
         (dolist (current (shiftf *top-most* nil))
           (dolist (dest (state-shifts (stack-node-state current) (car token)))
             (let ((right-sib
                    (or (find dest (the list *top-most*) :key #'stack-node-state)
                        (car (push (make-stack-node :state dest) *top-most*)))))
               (add-link-2 current right-sib (cadr token))))))))

(defun add-link (left-sib right-sib val)
  (declare (type stack-node right-sib))
  (let ((link (make-link :val val :from right-sib :to left-sib)))
    (push link (stack-node-nexts right-sib))
    link))

(defun add-link-2 (left-sib right-sib val)
  (declare (type stack-node right-sib))
  (let ((link (make-link :val val :from right-sib :to left-sib)))
    (push link (stack-node-nexts right-sib))
    link))

(defun add-link-3 (left-sib right-sib val)
  (declare (type stack-node right-sib))
  (let ((link (make-link :val val :from right-sib :to left-sib)))
    (push link (stack-node-nexts right-sib))
    link))

(defun add-link-4 (left-sib right-sib val)
  (declare (type stack-node right-sib))
  (let ((link (make-link :val val :from right-sib :to left-sib)))
    (push link (stack-node-nexts right-sib))
    link))

;; What PATHES-OF-LENGTH is returned is a cons of the final stack node reached
;; and the list of links followed. So the starting link is the last cons. This
;; then is in the correct order for applying the action.

;; Most time spend here actually.

(defun pathes-of-length (a n stack-node token)
  (labels ((aux (n stack-node yet)
             (declare (type stack-node stack-node))
             (cond ((zerop n)
                    (list (make-path :left-sib stack-node
                                     :links yet
                                     ;; :goto (goto (stack-node-state stack-node) (nyala::reduce-action-goto a))
                                     ;; :action a
                                     )))
                   (t
                    (let ((ns (stack-node-nexts stack-node)))
                      (cond ((null (cdr ns))
                             (let ((link (car ns)))
                               (aux (1- n) (link-to link) (cons link yet))))
                            (t
                             (mapcan (lambda (link)
                                       (aux (1- n) (link-to link) (cons link yet)))
                                     ns))))))))
    (aux n stack-node nil)))

(defvar *action-vector*)

(defun reduction-function (table a)
  ;; Kludge for our stupid *TOPCAT*
  (if (nyala::reduce-action-function a)
      (aref *action-vector* (nyala::reduce-action-function a))
      #'(lambda (x) x)))

(defun reduce-via-path (action p token)
  (let* (;; (action (path-action p))
         (val (list* ':apply (reduction-function *table* action) (path-links p)))
         (left-sib (path-left-sib p))
         ;;(dest (path-goto p))
         (dest (goto (stack-node-state left-sib) (nyala::reduce-action-goto action))) )
    '(print `(,(nyala::reduce-action-goto a) = ,val))
    (progn ;;unless (member :tainted args)
      (let ((right-sib #+NIL (find dest (the list *top-most*) :key #'stack-node-state)
                       (loop for it in *top-most*
                             do (when (eq dest (stack-node-state (the stack-node it)))
                                  (return it)))))
        (cond ((not (null right-sib))
               (let ((deja-vu
                      (loop for it in (stack-node-nexts right-sib)
                            do (when (eq (link-to it) left-sib)
                                 (return it)))
                      #+NIL
                      (find left-sib (the list (stack-node-nexts right-sib)) :key #'link-to)))
                 (cond ((and (not (null deja-vu)))
                        ;; We're in trouble here. We might find these too late. I still don't quite
                        ;; get how.
                        (setf (link-val deja-vu) (list ':merge
                                                       (make-link :val (link-val deja-vu))
                                                       (make-link :val val))))
                       (t
                        (let ((link (add-link-3 left-sib right-sib val)))
                          (push link *eval-queue*)
                          (enqueue-limited-reductions link token))))))
              (t
               (setq right-sib (make-stack-node :state dest))
               (let ((link (add-link-4 left-sib right-sib val)))
                 (declare (ignorable link))
                 (push link *eval-queue*)
                 (push right-sib *top-most*))
               ;; New:
               (enqueue-reductions right-sib token))
              #+NIL
              (t
               (setq right-sib (make-stack-node :state dest))
               (let ((link (add-link-4 left-sib right-sib val)))
                 (declare (ignorable link))
                 (push link *eval-queue*)
                 ;; We're in trouble, when this link is used before computed.
                 (push right-sib *top-most*)
                 '(enqueue-limited-reductions link token)
                 )
               ;; New:
               (enqueue-reductions right-sib token)))))))

(defun enqueue-path (a p)
  (enqueue (list a p) *path-queue*))

(defun enqueue-reductions (right-sib token)
  (unless (eql -1 (stack-node-state right-sib))
    (dolist (a (state-reduces (stack-node-state right-sib) (car token)))
      (dolist (p (pathes-of-length a (nyala::reduce-action-npop a) right-sib token))
        (enqueue-path a p)))))

(declaim (inline link-same-p))
(defun link-same-p (a b)
  (declare (type link a b))
  (and (eq (link-from a) (link-from b))
       (eq (link-to a) (link-to b))))

#-NIL
(defun enqueue-limited-reductions (link token)
  (dolist (sn *top-most*)
    (dolist (a (state-reduces (stack-node-state sn) (car token)))
      (let ((n (nyala::reduce-action-npop a)))
        (dolist (p (pathes-of-length a n sn token))
          (when (member link (path-links p) :test #'link-same-p)
            (enqueue-path a p)))))))

#+NIL
(defun merge (x y)
  (if (and (consp x) (eq (car x) ':garbage)) y
      (if (and (consp y) (eq (car y) ':garbage)) x
          (if (glr::equal* x y) x (glr::cons-either (list x y))))))



(defun show-table (name)
  (let ((table (get name 'nyala::lalr-table)))
    (loop for q across (nyala::lalr-table-states table)
          do (progn
               (format t "~&State ~D:~%" (nyala::lalr-state-name q))
               (loop for tr in (remove-if-not #'nyala::shift-action-p (nyala::lalr-state-transitions q))
                     do (let ((cats (remove-if-not #'keywordp (nyala::lalr-action-categories tr))))
                          (when cats
                            (format t "~&    On ~{~S~^ ~} ~40T shift to ~D~%"
                                    cats
                                    (nyala::shift-action-goto tr)))))
               (loop for tr in (remove-if-not #'nyala::reduce-action-p (nyala::lalr-state-transitions q))
                     do (let ((cats (remove-if-not #'keywordp (nyala::lalr-action-categories tr))))
                          (when cats
                            (format t "~&    On ~{~S~^ ~} ~40T reduce ~S (~D)~%"
                                    cats
                                    (nyala::reduce-action-goto tr)
                                    (nyala::reduce-action-npop tr)))))))
    (terpri)
    (let ((goto-table nil))
      (loop for q across (nyala::lalr-table-states table)
            do (loop for tr in (remove-if-not #'nyala::shift-action-p (nyala::lalr-state-transitions q))
                     do (let ((cats (remove-if #'keywordp (nyala::lalr-action-categories tr))))
                          (dolist (cat cats)
                            (push (list cat (nyala::lalr-state-name q) (nyala::shift-action-goto tr)) goto-table)))))
      (loop for ps in (sort (clex2::partition goto-table :key 'car)
                            #'string<
                            :key 'caar)
            do (let ((cat (caar ps))
                     (gss (clex2::partition
                           (mapcar #'cdr (sort (copy-list ps) #'< :key 'second))
                           :key #'cadr)))
                 (format t "~&~S~%" cat)
                 (loop for gs in (sort gss #'< :key #'cadar) do
                       (let ((from (cadar gs))
                             (tos (mapcar #'car gs)))
                         (format t "    goto ~D from ~{~D~^, ~}~%" from (sort tos #'<)))))))))

(defun table-actions (table &aux (table (lalr-table table))
                                res)
  (loop for q across (nyala::lalr-table-states table)
        do (let ((qi (nyala::lalr-state-name q)))
             (loop for tr in (remove-if-not #'nyala::shift-action-p (nyala::lalr-state-transitions q))
                   do (loop for cat in (nyala::lalr-action-categories tr)
                            when (keywordp cat)
                            do (push (list qi cat (list :shift (nyala::shift-action-goto tr))) res)))
             (loop for tr in (remove-if-not #'nyala::reduce-action-p (nyala::lalr-state-transitions q))
                   do (loop for cat in (nyala::lalr-action-categories tr)
                            when (keywordp cat)
                            do (push (list qi cat (list :reduce (nyala::reduce-action-goto tr) (nyala::reduce-action-npop tr)))
                                     res)))))
  res)

(defun lalr-table (name-or-table)
  (etypecase name-or-table
    (nyala::lalr-table name-or-table)
    (t (or (get name-or-table 'nyala::lalr-table)
           (error "No such LALR table: ~S" name-or-table)))))

#+NIL
(defun heh (table
            &optional (sz 41234)
            &aux (table (lalr-table table))
                 (cats nil)
                 (res nil))
  (setq res (make-array sz :initial-element 0))
  (labels ((name-cat (cat)
             (or (position cat cats)
                 (prog1 (length cats) (setq cats (append cats (list cat)))))))
    (loop for (q cat action) in (table-actions table)
          do (let ((k (name-cat cat)))
               (let ((h (+ (* 882 k) q)))
                 (incf (aref res (mod h sz))))))
    (values
     res
     cats)))



(defvar *action-hash*
  (make-hash-table :test 'equal))

(defun actions (table state cat &aux (hash *action-hash*))
  (when (symbolp table)
    (setq table (get table 'nyala::lalr-table)))
  (let ((key (list table state cat)))
    (declare (dynamic-extent key))
    (car
     (or (gethash key hash)
         (let ((key (list table state cat)))
           (setf (gethash key hash)
                 (list
                  (REMOVE CAT
                          (nyala::lalr-state-transitions (svref (nyala::lalr-table-states table) state))
                          :key #'nyala::lalr-action-categories
                          :test-not #'member))))))))




(defun make-either* (xs)
  (let ((xs (remove-if #'garbagep xs)))
    (cond ((= 1 (length xs))
           (car xs))
          (t
           (cons ':either xs)))))

(defun garbagep (x)
  ;; (subst-if nil (lambda (y) (when (eq y ':\#garbage) (return-from garbagep t))) x)
  nil)

(defun merge (x y)
  (make-either* (remove-duplicates (list x y) :test 'equal)))

;; (defun merge (x y) (list :either x y))


;; Sigh.

(defvar *lookahead*)

(defun glr-driver (*table* scanner-function action-vector)
  (let ((*reduce-cache* (if (boundp '*reduce-cache*)
                            (let ((it *reduce-cache*))
                              (or
                               it
                               (progn
                                 (setf *reduce-cache*
                                       (make-array (length (nyala::lalr-table-states *table*))
                                                   :initial-element nil))
                                 (dotimes (i (length *reduce-cache*))
                                   (setf (svref *reduce-cache* i) (make-hash-table :test 'eq)))
                                 *reduce-cache*)))
                            (let ((*reduce-cache*
                                   (make-array (length (nyala::lalr-table-states *table*))
                                               :initial-element nil)))
                              (dotimes (i (length *reduce-cache*))
                                (setf (svref *reduce-cache* i) (make-hash-table :test 'eq)))
                              *reduce-cache*)))
        (*shift-cache* (if (boundp '*shift-cache*) *shift-cache* (make-hash-table :test 'equal)))
        (*goto-cache* (if (boundp '*goto-cache*) *goto-cache* (make-hash-table :test 'equal)))
        (*action-vector* action-vector))
    '(dotimes (i (length *reduce-cache*))
      (setf (svref *reduce-cache* i) (make-hash-table :test 'eq)))
    (let ((*top-most* (list (make-stack-node :state 0 :nexts nil)))
          (*path-queue* nil))
      (let ((tokens
             (loop for tok = (multiple-value-list (funcall scanner-function))
                   while (not (eq (car tok) ':eof))
                   collect tok)))
        (loop for tok in tokens
              do (progn
                   (let ()
                     (do-reductions tok)
                     (do-shifts tok))
                   (unless *top-most*
                     (apply #'nyala::report-parsing-error *last-good-tok*)
                     (return-from glr-driver nil))
                   (setq  *last-good-tok* tok))))
      (let ()
        (do-reductions (list :eof)))
      (make-either*
       (mapcan (lambda (q)
                 (when (eql -1 (stack-node-state q))
                   (mapcar #'link-val (stack-node-nexts q))))
               *top-most*)))))