(in-package :lojban-dot)

; location of png files that we generate (not needed for inline svg)
(defparameter image-location "/home/lojban-dot/public_html/images/")

;web url to access the images we generate
(defparameter image-address "http://subvert-the-dominant-paradigm.net/~lojban-dot/images/")
;(defparameter image-address "http://localhost/~jbominji/images/")

; counter to name generated images
(defvar *image-index* nil)

; url user will use to access araneida
(defvar *site-url*)
;(setf *site-url* (araneida:make-url :scheme "http" :host "localhost" :port 9072))
(setf *site-url* (araneida:make-url :scheme "http" :host "subvert-the-dominant-paradigm.net" :port 9072))


; --------------------------------------------------------------------------------
; Araneida setup
;

(defvar *listener*)

;(araneida:start-listening *listener*)
;(araneida:stop-listening *listener*)

(defun restart-lojban-dot ()
  (format t "starting lojban-dot")
  (setf *listener*  (make-instance 'araneida:threaded-http-listener
				   :port (araneida:url-port *site-url*)))
  
  (araneida:install-handler (araneida:http-listener-handler *listener*)
			    (make-instance 'ldot)
			    (araneida:urlstring (araneida:merge-url *site-url* "/generator")) nil)  
  (araneida:start-listening *listener*)
  )

(defun make-temporary-filename (suffix)
  (if (or 
       (null *image-index*)
       (> *image-index* 100))
      (setf *image-index* 1)
      (incf *image-index*))
  (concatenate 'string (format nil "~A" *image-index*) "." suffix)
)

(defun show-parsed-text-html (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)))))
    `(((|html:span| :class "parsed-text") ,(subseq input start end))
      ((|html:span| :class "unparsed-text") ,(subseq input end)))))

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

(defun make-graph (request)
  (sb-thread:with-mutex (*make-graph-mutex*)
    (let* ((params (araneida:url-query-alist (araneida:request-url request)))
	   (jbocku (araneida:body-param "jbocku" params))
	   (output-type (araneida:body-param "output-type" params))
	   (tree-type (araneida:body-param "tree-type" params))
	   (show-morphology (araneida:body-param "show-morphology" params)))
	   
      (if (not (null jbocku))
	  (progn
	    ;(format t "~A ~A" output-type (class-of output-type))
	    (lojban-parser:initialize-parser)
	    (let* ((pr (lojban-parser:parse-lojban jbocku :save-parse-tree t))
		   (matched (cl-peg:parse-result-matched pr))
		   (show-morph (equal show-morphology "show-morphology")))
	      (if matched
		  (let ((graph 
			 (cond 
			   ((equal tree-type "full-parse-tree")  (cl-dot:generate-graph (lojban-parser:make-parse-tree pr 
														       :collapse-tree nil 
														       :keep-morphology show-morph)))
			   ((equal tree-type "raw-parse-tree")  (cl-dot:generate-graph (cl-peg:parse-result-root-parse-node pr)))
			   ;((equal tree-type "edited-parse-tree")
			   (t (cl-dot:generate-graph (lojban-parser:make-parse-tree pr :collapse-tree t :keep-morphology show-morph))))))		  
;			   (t (return-from make-graph '("unable to determine parse tree type"))))))
		    (progn
					;			    (cl-dot:print-graph graph)
		      (append (show-parsed-text-html pr)
			      `(((|html:br|))
				,(cond ((equal output-type "produce-svg-output") (make-svg-file image-location
												image-address
												(concatenate 'string (make-temporary-filename "svg"))
												graph))
				       ((equal output-type "produce-inline-svg-output") (make-inline-svg graph))
;				       ((equal output-type "produce-png-output") 
				       (t (make-png-file image-location 
												image-address 
												(concatenate 'string (make-temporary-filename "png"))
												graph))
;				       (t "internal error selecting output format")
				       )))))
			"parse failed")))
	    '("no lojban input")
	    ))))

(defun make-inline-svg (graph)
  (extract-svg (cl-dot::dot-graph-stdout graph "svg"))
)

(defun make-svg-file (image-location image-address fname graph)
  (cl-dot:dot-graph graph (concatenate 'string image-location fname) "svg")
  `((|html:embed| :src ,(concatenate 'string image-address fname) :width "1000" :height "1000"))

  )

(defun make-png-file (image-location image-address fname graph)
  (cl-dot:dot-graph graph (concatenate 'string image-location fname) "png")
  `((|html:img| :src ,(concatenate 'string image-address fname)))
  )

(defgeneric extract-svg (xml-string))
(defmethod extract-svg (xml-string)
  (let* ((scanner (cl-ppcre::create-scanner ".*<svg "))
	 (start (multiple-value-bind (s e) (cl-ppcre:scan scanner xml-string) s)))
    (if (not (numberp start))
	(progn
	  (format t "~A" xml-string)
	  "failed to match string <svg> in xml output from dot")
	(let ((result (subseq xml-string start)))
;	  (format t "scan ~A" (cl-ppcre:scan scanner xml-string))
	  (if (null result)
	      (progn
		(format t "~A" xml-string)
		"failed to parse svg output from dot")
	      result)))))

(defgeneric find-pv (pv name))

(defmethod find-pv ((l list) name)
  (loop for c in l thereis (find-pv c name))
)

(defmethod find-pv ((pv cl-peg:parse-node) name)
  (let ((pe (cl-peg:parse-node-parse-element pv)))
    (cond 
      ((and
	(typep pe 'cl-peg:named-non-terminal)
	(equal (slot-value pe 'cl-peg::name)  name))
       pv)
      (t (find-pv (cl-peg:parse-node-children pv) name)))))


(defclass ldot (araneida:handler) ())


(defmethod araneida:handle-request-response ((araneida:handler ldot) method (request1 araneida:request))
  (progn
    (araneida:request-send-headers request1 :content-type "text/xml")
    (araneida:html-stream
     (araneida:request-stream request1)
     (let* ((params (araneida:url-query-alist (araneida:request-url request1)))
	    (jbocku (araneida:body-param "jbocku" params))
	    (output-type (araneida:body-param "output-type" params))
	    (tree-type (araneida:body-param "tree-type" params))
	    (show-morphology (araneida:body-param "show-morphology" params))
	    )
       `((|html:html| :|xmlns:html| "http://www.w3.org/1999/xhtml" :|xmlns| "http://www.w3.org/2000/svg" :|xmlns:xul| "http://www.mozilla.org/keymaster/gatekeeper/there.is.only.xul")
	 (|html:head| 
	  (|html:title| "Lojban dot generator")
	  ((|html:style|) ,ldot-style))
	 (|html:body| 
	  (|html:h1| "Lojban dot generator")
	  ((|html:form| :action "generator" :method "get" :id "mainForm") 
	   ((|html:table|)
	    ((|html:tr|)
	     ((|html:td| :valign "top")
	      ((|html:textarea| :name "jbocku" :cols "80" :rows "10") ,
	       (if (null jbocku)
		   ""
		   jbocku))
	      )
	     ((|html:td| :valign "top")
	      ((|html:table|)
	       ((|html:div| :class "tree-type-selection")
		((|html:tr|)
		 ((|html:td| :valign "top") "edited parse tree")
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "tree-type" :value "edited-parse-tree" ,@(if (or (null tree-type) (equal tree-type "edited-parse-tree")) '(:checked "checked")))))
		 )
		((|html:tr|)
		 ((|html:td| :valign "top") "full parse tree")
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "tree-type" :value "full-parse-tree" ,@(if (equal tree-type "full-parse-tree") '(:checked "checked")))))
		 )
		((|html:tr|)
		 ((|html:td| :valign "top") "raw parse tree")
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "tree-type" :value "raw-parse-tree" ,@(if (equal tree-type "raw-parse-tree") '(:checked "checked")))))
		 )
		)

	       ((|html:div| :class "show-morphology-selection")
		((|html:tr|)
		 ((|html:td| :valign "top") "hide morphology")
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "show-morphology" :value "hide-morphology" ,@(if (not (equal show-morphology "show-morphology")) '(:checked "checked")))))
		 )
		((|html:tr|)
		 ((|html:td| :valign "top") "show morphology")
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "show-morphology" :value "show-morphology" ,@(if (equal show-morphology "show-morphology") '(:checked "checked")))))
		 )		
	       ))


	       ((|html:div| :class "output-type-selection")
		((|html:tr|)
		 ((|html:td| :valign "top")
		  "produce png output")
		 ((|html:td| :valign "top")
		  ((|html:input| :type "radio" :name "output-type" :value "produce-png-output" ,@(if (or (null output-type) (equal output-type "produce-png-output")) '(:checked "checked")))))
		 )
		((|html:tr|)
		 ((|html:td| :valign "top") 	       "produce svg output" )
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "output-type" :value "produce-svg-output" ,@(if (equal output-type "produce-svg-output") '(:checked "checked")))))
		 )
		((|html:tr|)
		 ((|html:td| :valign "top") 	       	       "produce inline svg output" )
		 ((|html:td| :valign "top") ((|html:input| :type "radio" :name "output-type" :value "produce-inline-svg-output" ,@(if (equal output-type "produce-inline-svg-output") '(:checked "checked")))))
		 )
		)

	      


	      )))
	      ((|html:input| :type "submit" :class "button" :name "submitbutton" :value "parse")) )

	 ((|html:hr|))
	 ,@(make-graph request1)))))))

; --------------------------------------------------------------------------------
; Style sheet
;

(defparameter ldot-style "

body {
	background-color: #ffffff;
	font-family: verdana, arial, helvetica;
	font-size: 8pt;
	color: black; 
}

div.output-type-selection {
  background-color: #ddffdd;
  color: black;
}

div.tree-type-selection {
  background-color: #ffffcc;
  color: black;

}

div.show-morphology-selection {
  background-color: #ffdddd;
  color: black;
}

.parsed-text {
}

.unparsed-text {
 color: #ee0000;
}
")

(export '(*listener*))