(in-package :lojban-parser)

; setup a lojban parser with 
; initialize-parser

; 


(defvar *mutex* (sb-thread:make-mutex))

(defun get-mutex () 
  *mutex*
)

; the location of the lojban_grammar.peg file
(defparameter peg-grammar-location "/home/jbominji/jbominji/lojban_grammar.peg")

; the lojban grammar object created by cl-peg
(defvar *lojban-grammar* nil)

(defun initialize-parser ()
  (if (null *lojban-grammar*)
      (setf *lojban-grammar* (cl-peg:create-peg-parser peg-grammar-location))
      *lojban-grammar*
      ))

(defun parse-lojban (text &key (input-offset 0) (save-parse-tree t))
  (cl-peg:parse *lojban-grammar* text :input-offset input-offset :save-parse-tree save-parse-tree))

(defun make-parse-tree (pr &key (collapse-tree t) (keep-morphology nil))
  (let ((tree (build-lojban-objects pr (cl-peg:parse-result-root-parse-node pr) collapse-tree keep-morphology)))
;    (break tree)
    (if collapse-tree
	(collapse-tree tree)
	tree)))
	   

(defgeneric build-lojban-objects (pr pn collapse-tree keep-morphology))

(defmethod build-lojban-objects (pr (pn list) collapse-tree keep-morphology)
  (let ((result (loop for e in pn when (build-lojban-objects pr e collapse-tree keep-morphology) collect it)))
    (if (and (listp result)
	     (eq (list-length result) 1))
	(first result)
	result)))

(defmethod build-lojban-objects ((pr cl-peg:parse-result) (pn cl-peg:parse-node) collapse-tree keep-morphology)
  (let* ((pe (slot-value pn 'cl-peg::parse-element))
	 (sym (intern (symbol-name (slot-value pe 'cl-peg::name)) :lojban)))
    (if (isNamedNonTerminal pn)
	(cond ((member sym lojban:*grammar-leaf-nodes*)
	       (progn
;	      (format t "making ~A~%" sym)
		 (make-instance sym :grammar-label (string sym) :text (cl-peg:parse-node-input-string pr pn) :children 
				(when keep-morphology
				  (build-lojban-objects pr (cl-peg:parse-node-children pn) collapse-tree keep-morphology))))
	       )
	      ((eq sym 'lojban:|BRIVLA|)
	       (progn
;		 (format t "making BRIVLA~%")
		 (make-instance sym :grammar-label (string sym) :text (cl-peg:parse-node-input-string pr pn) :children (build-lojban-objects pr (cl-peg:parse-node-children pn) collapse-tree keep-morphology))))
	      (t
	       (progn 
		 (if (and collapse-tree
			  (equal (string-trim " " (cl-peg:parse-node-input-string pr pn)) ""))
		     nil
		     (make-instance 'lojban:jbovalsi :text (cl-peg:parse-node-input-string pr pn) :grammar-label sym :children (build-lojban-objects pr (slot-value pn 'cl-peg::children) collapse-tree keep-morphology))))
	       ))
	(build-lojban-objects pr (slot-value pn 'cl-peg::children) collapse-tree keep-morphology))))



(defun isNamedNonTerminal (pn)
  (let ((pe (slot-value pn 'cl-peg::parse-element)))
    (typep pe 'cl-peg:named-non-terminal)))

(defun collapse-tree (tree)
  (if (listp tree)
      (loop for i in tree when (collapse-tree i) collect it)
      (cond 
	((equal (string-trim " " (slot-value tree 'lojban::text)) "") nil)
	((eq (type-of tree) 'lojban:jbovalsi)
	 (let ((children (lojban:children tree)))
	   (if (listp children)
	       (progn 
		 (setf (slot-value tree 'lojban:children) (collapse-tree children))
		 tree)
	       (collapse-tree children))))
	(t (progn
;	     (format t "saving ~A" tree)
	     (setf (slot-value tree 'lojban:children) (collapse-tree (lojban:children tree)))
	     tree))
)))

(defun dump-parse-tree (tree stream)
  (if (listp tree)
      (loop for i in tree do (dump-parse-tree i stream))
      (cond 
	((equal (string-trim " " (slot-value tree 'lojban:text)) "") nil)
	((typep tree 'lojban:|BRIVLA|)
	 (progn (format stream "~A=( " (slot-value tree 'lojban:grammar-label) )
		(dump-parse-tree (lojban:children tree) stream)
		(format stream " ) ")))
	((or (eq (type-of tree) 'lojban:jbovalsi))

	 (let ((children (slot-value tree 'lojban:children)))
	   (if (listp children)
	       (progn 

		 (format stream "~A=( " (slot-value tree 'lojban:grammar-label) )
		      (dump-parse-tree children stream)
		      (format stream " ) ")
	       ))))
	(t (progn
	     (cond ((typep tree 'lojban:cmavo-group) (format stream "CMAVO=( "))
		   ((typep tree 'lojban:|CMENE|) (format stream "CMENE=( "))
		   (t nil))
;	     (format t "~%dumping ~A ~A~%" tree (slot-value tree 'lojban:text))
	     (format stream "~A=( ~A ) " (slot-value tree 'lojban:grammar-label) (slot-value tree 'lojban:text))

	     (cond ((typep tree 'lojban:cmavo-group) (format stream ") "))
		   ((typep tree 'lojban:|CMENE|) (format stream ") "))
		   (t nil))))	     
)))

(defun parse-and-output-to-stdout (text)
  (initialize-parser)
  (let* ((pr (parse-lojban text))
	 (matched (cl-peg:parse-result-matched pr)))
    (if matched
	(dump-parse-tree (make-parse-tree pr) *standard-output*)
	)
    (cl-peg:matched-all pr)
    ))

(defun show-parsed-text (pr)
  (let ((input (cl-peg:parse-result-original-input pr))
	(start (first (cl-peg:matched-region pr)))
	(end (first (rest (cl-peg:matched-region pr)))))
    (subseq input start end)))

(defun show-unparsed-text (pr)
  (let ((input (cl-peg:parse-result-original-input pr))
	(end (first (rest (cl-peg:matched-region pr)))))
    (subseq input end)))