;; mifrw.l -- convert Frame MIF
;;
;; $Id: mifrw.ol,v 1.1 92/08/19 18:37:59 connolly Exp $
;;
;; @@ marks hacks, kludges, and broken code
;; @# marks heuristics and approximations
;;

(require 'common)
(require 'objective-lisp)
(require 'mif)

(defMethod MIFReader :load (m)
  (do ((statement [self :read] [self :read])
       )
      ((null statement)
       )

      (format *trace-output* "~A "  (first statement))

      [m (first statement) statement]
      )
  )

(defMethod MIF MIFFile (statement) )
(defMethod MIF Comment (statement) )
(defMethod MIF Units (statement) )
(defMethod MIF Verbose (statement) )
(defMethod Mif ConditionCatalog (statement)  )
;(defMethod MIF PgfCatalog (statement) )
;(defMethod MIF FontCatalog (statement) )
(defMethod Mif TblCatalog (statement)  )
(defMethod Mif RulingCatalog (statement)  )
;(defMethod Mif VariableFormats (statement) )
;(defMethod Mif XRefFormats (statement) )
(defMethod Mif Document (statement)  )
(defMethod Mif BookComponent (statement)  )
(defMethod Mif Dictionary (statement)  )
;(defMethod Mif AFrames (statement) )
(defMethod Mif Tbls (statement)  )
(defMethod MIF Page (statement) )
(defMethod MIF TextFlow (statement) )


(defClass Catalog ()
  (entries)
  )

(defMethod Catalog :enter (key val)
  (push (cons key val) entries)
  )

(defMethod Catalog :lookup (key)
  (cdr (assoc key entries))
  )

(defMethod MIF PgfCatalog (statement)
  (setq PgfCatalog [Catalog :new])
  (dolist (entry (rest statement))
	  [PgfCatalog :enter (get-name '(PgfTag) entry) entry]
	  )
  )

(defMethod MIF FontCatalog (statement)
  (setq FontCatalog [Catalog :new])
  (dolist (entry (rest statement))
	  [FontCatalog :enter (get-name '(FTag) entry) entry]
	  )
  )

(defMethod Mif VariableFormats (statement) 
  (setq VariableFormats [Catalog :new])
  (dolist (format (rest statement))
	  (let ((name (get-name '(VariableName) format))
		(def (get-data '(VariableDef) format))
		)
	    [VariableFormats :enter name def]
	    ) )
  )

(defMethod Mif XRefFormats (statement)
  (setq XRefFormats [Catalog :new])
  (dolist (format (rest statement))
	  (let ((name (get-name '(XRefName) format))
		(def (get-data '(XRefDef) format))
		)
	    [XRefFormats :enter name def]
	    ) )
  )
	    
(defMethod Mif AFrames (statement)
  (setq AFrames [Catalog :new])
  (dolist (entry (rest statement))
	  [AFrames :enter (get-data '(ID) entry) entry]
	  )
  )
   
;;;;;;;;;;;;;
;; utlities

(defun find-data (tokens statements)
  ;; example: (find-data '(Para ParaLine TextRectID) (rest textflow))
  ;;   will find the first Para statement in the textflow,
  ;;        find the first ParaLine statement in the para,
  ;;        and find the first TextRectID therein.
  ;;        returns the rest of the TextRectID statemnt, e.g.: (12)
  (if (null tokens) statements
    (do* ((target (first tokens))
	  (s statements (rest s))
	 )
	((null s) nil)
	(let ((candidate (first (first s)) (first (first s)))
	      (result (rest (first s)) (rest (first s)))
	      )
	  (if (eq candidate target)
	      (return (find-data (rest tokens) result)) )
	  )
	) ) )

(defun get-data (tokens statement)
  (first (find-data tokens (rest statement)))
  )

(defun get-name (tokens statement)
  (let ((s (get-data tokens statement))
	)
    (cond ((equal s "") nil)
	  (s (intern s))
	  )
    )
  )

(defun find-statements (token statement)
  (remove-if-not #'(lambda (s)
		     (eq token (first s))
		     )
		 (rest statement))
  )

(defun twips (measure)
  (if (consp measure)
      (let ((n (first measure))
	    (u (and (rest measure) (second measure)))
	    )
	(truncate (* n (case u
			     (in 1440)
			     (pt 20)
			     (cm (* 1440 2.54))
			     (pica (/ 1440 12))
			     ))) )
    0) )


;;;;;;;;;;;;;;;;;;;;
;; special MIF routines
;; that maintain state for RTF routines
;; (should be subclass)
;;

(defMethod MIF Page (statement)
  (or MasterPages (setq MasterPages [Catalog :new])) ;; should be in :isnew
  (let ((type (get-data '(PageType) statement))
	(tag (get-name '(PageTag) statement))
	)
    (case type
	  (BodyPage (push statement body))
	  ((LeftMasterPage RightMasterPage OtherMasterPage)
	   [MasterPages :enter tag statement] )
	  ;; @# ReferencePage, HiddenPage
	  ) )
  )

(defMethod MIF :body-pages ()
  (reverse body)
  )

(defMethod MIF TextFlow (statement)
  (or TextFlows (setq TextFlows [Catalog :new])) ;; should be in :isnew
  [TextFlows :enter (get-data '(Para ParaLine TextRectID) statement) statement]
  )

(defMethod Mif :write-pages ()
  (dolist (page [self :body-pages])
	  [self :write-frame 
		[MasterPages :lookup (get-name '(PageBackground) page)]]
	  ;; no output unless there's something there!
	  (when [self :write-frame page]
		[out :end-section]
		(format *trace-output* "!~%" )
		)
	  ) )

(defMethod MIF :write-frame (frame &aux output)
  ;;@@ sort objects by brect?
  (dolist (object (rest frame))
	  (case (first object)
		(Frame [self :write-frame object])
		;;@@(TextLine [self :write-textline object])
		(ImportObject
		   [self :write-image object (get-data '(AnchorAlign) frame)] )
		(TextRect
		 (let* ((id (get-data '(id) object))
			(flow [TextFlows :lookup id])
			(tag (get-data '(tftag) flow))
			)
		   (when flow
			 [self :write-textflow flow]
			 (setq output t)
			 )
		   ) )
		) )
  output
  )

(defMethod  MIF :write-image (image &optional align)
  (let ((image (find-data '(FrameImage) (rest image)))
	)
    (and image [out :raster 'MifVec image align])
    ) )

(defMethod MIF :write-textflow (textflow)
  ;;@@footnotes
  ;;@@(setq hyper nil)
  (dolist (s (rest textflow))
	  (case (first s)
		(Para [self :write-para s])
		) )
  )

(defMethod MIF :write-para (para)
  ;; AFrames and Tbls before the paragraph
  [self :write-floats para '(Top Left Near)]
  
  (let* ((local-format (find-data '(Pgf) (rest para)))
	 (tag (get-name '(PgfTag) para))
	 (tag-format (and tag [PgfCatalog :lookup tag]))
	 (pgfnumstring (get-data '(PgfNumString) para))
	 (pgfnumberfont (or (get-name '(PgfNumberFont) local-format)
			    (and tag (get-name '(PgfNumberFont)
					       tag-format)) ))
	 )

    (when tag
	  [out :reset-paragraph-format tag tag-format]
	  [out :reset-character-format nil (get-data '(PgfFont) tag-format)]
	  )

    (when local-format
	  [out :change-paragraph-format local-format]
	  [out :change-character-format (get-data '(PgfFont) local-format)] )

    (when pgfnumstring
	  [out :save-character-format]
	  (if pgfnumberfont
	      [out :reset-character-format
		   pgfnumberfont
		   [FontCatalog :lookup pgfnumberfont]])
	  [out :pcdata pgfnumstring] ;; @@character set translation
	  [out :restore-character-format])
    )
  
  ;; Elements of the para
  (dolist (paraline (rest para))
	  (case (first paraline)
		(ParaLine
		 ;;@@ HACK! RTF widget doesn't do blank lines right!
		 (when (null (rest paraline))
		       [out :pcdata " "] )
		 
		 (dolist (s (rest paraline))
			 (case (first s)
			       ((Font PgfFont)
				;;@@[self :end-hyper]
				[out :change-character-format s] )
			       (String [out :pcdata (second s)]
				       ;;@@[self :hyper-not-empty]
				       )
			       (Char
				(case (second s)
				      (Tab [out :tab])
				      (HardSpace [out :pcdata " "]) ;;@@
				      (HardReturn [out :newline])
				      (t (ignore s)) ) )
			       (FNote (ignore s)) ;;@@
			       (Marker [out :marker
					    (get-data '(MType) s)
					    (get-data '(MText) s)])
			       (Variable
				[out :ndata
				     [VariableFormats :lookup
						      (get-name '(VariableName)
								v)]] )
			       ;;@@(XRef)
			       ) )
		 [out :end-record]
		 ) )
	  )
  
  ;;@@[self :end-hyper]
  [out :end-paragraph]
  (princ "." *trace-output*)
  
  ;; AFrames and tables after the para
  [self :write-floats para '(Inline Below Bottom Right Far)]
  )

(defMethod MIF :write-floats (para places)
  (dolist (paraline (rest para))
	  (when (eq (first paraline) 'ParaLine)
		(dolist (s (rest paraline))
			(case (first s)
			      (AFrame
			       (let* ((id (second s))
				      (frame [AFrames :lookup id])
				      (placement (get-data '(FrameType) frame))
				      )
				 (if (member placement places)
				     [self :write-frame frame])
				 ) ) ) ) ) ) )

;;;;;;;;;;;
;; methods with explicit RTF knowledge
;;

(defun format-marker (stream m)
  (let ((type (get-data '(MType) m))
	(text (get-data '(MText) m))
	)
    (case type
	  ;;@# 0, 1, 3, 4, 5, 6, 7
	  (2 (format stream "{\\v{\\xe ")
	     (format-string stream text)
	     (format stream "}}")
	     )
	  (8 (format stream "{\\field{\\fldrslt ")
	     (setq *HyperLink* (list nil text))
	     )
	  )
    ) )

(defun ignore (s)
  (pprint s *error-output*)
  )

(provide 'mifrw)