(in-package "KPML-I")

;;; File: markup-formatter.lisp
;;; John. Feb00. Prague
;;;
;;; Provides a formatting  output for strings that are  marked up with
;;; an HTML-like markup. Formatted strings are presented on the stream
;;; given as  argument.  The stream must  be a CLIM stream  and can be
;;; plugged into a normal pane display method. The markup is currently
;;; very simple.
;;;
;;; Linebreaking cleaned up: Bremen, March00.
;;; 

(defvar *line-width* 50)
(defvar *ol-index* 0)
(defvar *right-hand-margin-space* 50)

#||

(defmethod INFO-DISPLAYER ((frame info-display-frame) stream)
  (clim:with-text-style 
      (stream *sans-serif--roman--10*)
      (format-marked-up-string 
       stream (slot-value frame 'info-to-display)
       :width (- (/ (clim:bounding-rectangle-width
		     (clim:pane-viewport-region stream))
		    (clim:stream-string-width stream "i"))
		 *right-hand-margin-space*))))

(STARTUP-AN-INFO-WINDOW "html test" "here is a slot")

||#

(defun FORMAT-MARKED-UP-STRING 
       (stream string 
               &key
               (open-markup-bracket #\<)
               (close-markup-bracket #\>)
               (close-tag-marker #\/)
               (width *line-width*)
	       (errorp nil)
               )
  (declare (special open-markup-bracket 
		    close-markup-bracket close-tag-marker *ol-index*))
  (macrolet ((format-tagged-substring (&optional (width nil))
              `(progn                                      
                   (setf i (1+ end))
                   (+ i (format-marked-up-string 
                         stream (subseq string i)
                         ,@(if width `(:width ,width)))))))
  (loop for i from 0
        while (< i (length string))
        as char = (char string i)
        when (char= char open-markup-bracket)
        do
        (multiple-value-bind (tag closing? end)     
            (if (char= (char string (1+ i)) close-tag-marker)
                (get-closing-tag string i)
              (get-opening-tag string i))
          (cond (closing?
                 (case tag
                   ((:h1 :h2) (terpri stream)(terpri stream))
                   (:ul (terpri stream)))
                 (return-from FORMAT-MARKED-UP-STRING end))
                (t
                 (setf i
                   (case tag
		     (:p (terpri stream)(terpri stream)(format stream "  ") (+ i 2))
		     (:br (terpri stream)(+ i 3))
		     (:b (clim:with-text-face (stream :bold) (format-tagged-substring)))
		     (:e (clim:with-text-face 
			  (stream :italic) 
			  (format-tagged-substring)))
		     (:emph (clim:with-text-face 
			     (stream '(:italic :bold)) 
			     (format-tagged-substring)))
		     (:bigfix (clim:with-text-style  
			       (stream *fix--bold--16*)
			       (format-tagged-substring)))
		     (:red (clim:with-drawing-options 
			    (stream :ink clim:+red+)
			    (format-tagged-substring)))
		     (:h1 
		      (clim:with-text-size 
		       (stream :larger)
		       (clim:with-text-size (stream :larger)(format-tagged-substring))))
		     (:h2 (clim:with-text-size (stream :larger)(format-tagged-substring)))
		     (:ol 
		      (terpri stream)
		      (let ((end-list 0)
			    (numbering T)
			    (*ol-index* 0))
			(declare (special numbering *ol-index*))
			(clim:formatting-table 
			 (stream :move-cursor t)
			 (setf end-list (format-tagged-substring)))
			end-list))
		     (:ul
		      (terpri stream)
		      (let ((end-list 0)
			    (numbering nil)
			    )
			(declare (special numbering *ol-index*))
			(clim:formatting-table 
			 (stream :move-cursor t)
			 (setf end-list (format-tagged-substring)))
			end-list))
		     (:li
		      (let ((end-item 0))
			;; formatting-table-row with two cells
			;; cell 1: bullet
			;; cell 2: content
			(clim:formatting-row (stream)
			  (clim:formatting-cell (stream)
			     (terpri stream)
			     (clim:with-text-size 
			      (stream :larger)
			      (clim:with-text-face 
			       (stream :bold)
			       (if numbering
				   (format stream "(~A)   " 
					   (setf *ol-index* (1+ *ol-index*)))
				 (put-bullet-on-stream stream)))))
			  (clim:formatting-cell (stream)
			    (terpri stream)
			    (setf end-item (format-tagged-substring (- width 20)))))
			end-item))
		     (otherwise
		      (when errorp 
			(print "unknown tag")
			(print tag))
		      end))))))
        else
        do
        (let ((position (ceiling (/ (CLIM:STREAM-CURSOR-POSITION stream)
				    (clim:stream-string-width stream "x")))))
          (if (and (> position width)
                   (char= char #\space))
              (terpri stream)
            (format stream "~a" char)))
        finally
        (return i))))


;;; ----------------------------------------------------------------------
;;; Get opening or closing tags. These differ only by the offset where the
;;; tag starts (because it is after the close tag marker or not).
;;; ----------------------------------------------------------------------

(defun GET-CLOSING-TAG (string i)
  (get-opening-or-closing-tag string i 2 T))

(defun GET-OPENING-TAG (string i)
    (get-opening-or-closing-tag string i 1 nil))

(defun GET-OPENING-OR-CLOSING-TAG (string i offset closing?)
  (let* ((substring (subseq string i))
         (ending-pos (position close-markup-bracket substring)))
    (values 
     (intern (string (read-from-string (subseq substring offset ending-pos)))
             "KEYWORD")
     closing?
     (+ ending-pos i)
     )))

(defun PUT-BULLET-ON-STREAM (stream)
  (format stream "*  "))

#+ignore
(STARTUP-AN-INFO-WINDOW "html test" "<h1>Title 1</h1>This is a long and complicated paragraph about the necessity of not having lines that are anywhere near too long for the line in which they <b>are</b> to be displayed. <p> And here is a list:<ul><li>one</li><li>two</li><li>three</li><li>four<ul><li>four.a<ul><li>four.a.1</li><li>four.a.2</li></ul></li><li>four.b</li></ul></li><li>five</li></ul><br>and that was it.<p>Next paragraph.")
