;;; Alef Lazily Evaluates Functions
;;; (C) 2008-2009 Dr. Gergo ERDI <http://gergo.erdi.hu/>

(in-package :alef)

(defclass pnode ()
  ((symbol :initarg :symbol :accessor pnode-symbol)
   (signature :initform nil :accessor pnode-signature :type (or null signature))
   (parent :initform nil :accessor pnode-parent :type (or null pnode))
   (field-alist :initform (list) :accessor pnode-field-alist :type list))
  (:documentation
   "Program Node: A node in the parse tree of a program.
Necessary because we need identities for leafs."))

(defun make-pnode (symbol)
  (make-instance 'pnode :symbol symbol))

(defun pnode-fields (pnode)
  (declare (pnode pnode))
  (mapcar #'car (pnode-field-alist pnode)))

(defun pnode-children (pnode field)
  (declare (pnode pnode) (symbol field))
  (cdr (assoc field (pnode-field-alist pnode))))

(defun pnode-child (pnode field)
  (declare (pnode pnode) (symbol field))
  (let ((children (pnode-children pnode field)))
    (when (rest children) (error "Unexpected list in field ~A" field))
    (first children)))

(defun pnode-add-children (parent field new-children)
  (declare (pnode parent) (symbol field) (list new-children))
  (mapc  #'(lambda (child)
             (assert (not (pnode-parent child)))
             (setf (pnode-parent child) parent))
         new-children)
  (let ((children (cdr (assoc field (pnode-field-alist parent)))))
    (if children
        (nconc children new-children)
        (push (cons field new-children) (pnode-field-alist parent))))
  parent)

(defun pnode-add-child (parent field child)
  (pnode-add-children parent field (list child)))

(defun pnode-cca (pnode-1 pnode-2)
  "Closest common ancestor of pnode-1 and pnode-2"
  (declare (pnode pnode-1 pnode-2))
  (let ((ancestors-1 (make-hash-table)))
    (loop for ancestor-1 = pnode-1 then (pnode-parent ancestor-1)
          while ancestor-1
          do (setf (gethash ancestor-1 ancestors-1) t))
    (loop for ancestor-2 = pnode-2 then (pnode-parent ancestor-2)
          until (gethash ancestor-2 ancestors-1)
          while ancestor-2
          finally (return ancestor-2))))

(defvar *pnode-indent-depth* 0)

(defun print-pnode (root &optional (stream *standard-output*))
  (declare (pnode root) (stream stream))
  (labels ((format-indented (stream &optional (format-str "") &rest args)
             (apply #'format
                    stream
                    (format nil "~~&~~A~A~~%" format-str)
                    (make-string (* 2 *pnode-indent-depth*) :initial-element #\Space)
                    args)))
    (with-nice-types
      (format-indented stream "~S~:[~;~:*::~A~]" (pnode-symbol root) (when (pnode-signature root) (show-signature (pnode-signature root))))
      (dolist (field (nreverse (pnode-fields root)))
        (format-indented t " ~A:" field)
        (let ((*pnode-indent-depth* (1+ *pnode-indent-depth*)))
          (dolist (child (pnode-children root field))
            (print-pnode child stream)))))))