;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:VECTOR-FONT; Fonts:(CPTFONT HL12 TR12I COURIER CPTFONT HL12B); Vsp:0 -*-

;1;; File "3VECTORIZE-FONT*"*
;1;;*
;1;; 5ChangeLog:**
;1;;*
;1;;    29 May 89*	1Jamie Zawinski*	1 Created.*
;1;;    18 Aug 89*	1Jamie Zawinski *	1 Added the ability to compile the font to polylines.*
;1;;*    19 Dec 89*	1Jamie Zawinski *	 1Added ability to edit the triangular faces making up a filled vector-font.*
;1;;*



(defflavor 4vf-editor-pane*
	   ((raster-font-name	'FONTS:CMR18)
	    (vector-font	nil)
	    (char		#\A)
	    (last-point-added	nil)
	    (current-lines	nil)
	    (current-faces	nil)
	    (any-changes	nil)
	    (mouse-doc		nil)
	    )
	   (w:window
	    tv:list-mouse-buttons-mixin
	    )
  :gettable-instance-variables
  :settable-instance-variables
  :initable-instance-variables)


(defmethod 4(vf-editor-pane :magnification)* ()
  (let* ((fd (fed:font-get-fd raster-font-name))
	 (cd (aref fd char))
	 (w (array-dimension cd 1))
	 (h (array-dimension cd 0)))
    (when (zerop h) (setq h (fed:fd-line-spacing fd)))
    (when (zerop w) (setq w 1))
    (min (floor (tv:sheet-inside-height) h)
	 (floor (tv:sheet-inside-width) w))))

(defmethod 4(vf-editor-pane :display-raster-char)* (&optional (draw-lines t))
  "2Draw the specified raster-character in a grid on SELF.*"
  (let* ((fd (fed:font-get-fd raster-font-name))
	 (cd (aref fd (char-int char)))
	 (w (array-dimension cd 1))
	 (h (array-dimension cd 0))
	 (mag (send self :magnification))
	 (w*mag (* w mag))
	 (h*mag (* h mag))
	 (line-color-offset (if (w:color-system-p self) w:*default-blinker-offset* 8))
	 )
    (when (< mag 4) (setq draw-lines nil))
    (send self :clear-screen)
    (dotimes (y h)
      (let* ((y*mag (* y mag)))
	(dotimes (x w)
	  (when (plusp (aref cd y x))
	    (send self :draw-filled-rectangle (* mag x) y*mag (1- mag) (1- mag))))
	(when draw-lines (send self :draw-line 0 y*mag w*mag y*mag 1 line-color-offset tv:alu-add))))
    (when draw-lines
      (send self :draw-line 0 h*mag w*mag h*mag 1 line-color-offset tv:alu-add)
      (dotimes (x (1+ w))
	(let* ((x*mag (* x mag)))
	  (send self :draw-line x*mag 0 x*mag h*mag 1 line-color-offset tv:alu-add))))
    ;1;*
    ;1; Draw the character's bounding-box.*
    (send self :draw-rectangle tv:left-margin-size tv:top-margin-size
	  (+ tv:left-margin-size (* mag (1+ (fed:cd-char-width cd))))
	  (+ tv:top-margin-size  (* mag (1+ (fed:fd-baseline fd))))
	  3 line-color-offset tv:alu-add)

    (values w h)))


(defmethod 4(vf-editor-pane :display-lines)* (&optional (points-too t) (faces-too t))
  (let* ((mag (send self :magnification))
	 (mag/2 (floor mag 2))
	 (point-color-offset (if (w:color-system-p self) w:*default-blinker-offset* 8))
	 (line-color-offset  (if (w:color-system-p self) w:*default-blinker-offset* 8))
	 (num-points 10))
    (let* ((points '()))
      (dolist (line current-lines)
	(let* ((p1 (car line))
	       (p2 (cdr line))
	       (x1 (+ mag/2 (* mag (car p1))))
	       (y1 (+ mag/2 (* mag (cdr p1))))
	       (x2 (+ mag/2 (* mag (car p2))))
	       (y2 (+ mag/2 (* mag (cdr p2)))))
	  (when points-too
	    (pushnew p1 points :test #'equalp)
	    (pushnew p2 points :test #'equalp))
	  (when (equalp p1 p2) (error "3Zero-length line!*"))
	  (send self :draw-line x1 y1 x2 y2 1 line-color-offset w:alu-add)
	  ))
      (when faces-too
	(tv:prepare-sheet (self)
	  (dolist (face current-faces)
	    (let* ((p1 (first face))
		   (p2 (second face))
		   (p3 (third face))
		   (x1 (+ mag/2 (* mag (car p1))))
		   (y1 (+ mag/2 (* mag (cdr p1))))
		   (x2 (+ mag/2 (* mag (car p2))))
		   (y2 (+ mag/2 (* mag (cdr p2))))
		   (x3 (+ mag/2 (* mag (car p3))))
		   (y3 (+ mag/2 (* mag (cdr p3))))
		   )
	      (sys:%draw-shaded-triangle x1 y1 x2 y2 x3 y3 w:alu-add
					 t t t
					 nil self)))))
      
      (when last-point-added (pushnew last-point-added points :test #'equalp))
      (when points-too
	(dolist (point points)
	  (let* ((x (+ mag/2 (* mag (car point))))
		 (y (+ mag/2 (* mag (cdr point)))))
	    (send self :draw-filled-circle (1- x) (1- y) (max 1 (- mag/2 2)) point-color-offset w:alu-add num-points))))
      )))


(defmethod 4(vf-editor-pane :after :refresh)* (&optional (type :complete-redisplay))
  (when (eq type :complete-redisplay)
;    (send self :display-raster-char nil)
    (send self :display-lines)))


(defmethod 4(vf-editor-pane :before :tyi)*       (&rest ignore) (tv:who-line-clobbered) (tv:mouse-warp 0 0 t))
(defmethod 4(vf-editor-pane :before :any-tyi)*   (&rest ignore) (tv:who-line-clobbered) (tv:mouse-warp 0 0 t))
(defmethod 4(vf-editor-pane :before :read-char)* (&rest ignore) (tv:who-line-clobbered) (tv:mouse-warp 0 0 t))
(defmethod 4(vf-editor-pane :before :read-any)*  (&rest ignore) (tv:who-line-clobbered) (tv:mouse-warp 0 0 t))

(defmethod 4(vf-editor-pane :process-input)* ()
  (send self :clear-input)
  (setq mouse-doc nil)
  (unless (eq self tv:selected-window) (send self :select))
  (loop
    (let* ((blip (tv:read-any self)))
      (setq mouse-doc nil)
      (cond ((characterp blip)
	     (case blip
	       (#\End (send self :bury) (return))
	       ((#\Control-L #\Clear-Screen) (send self :refresh))
	       ((#\Tab #\Control-Tab)
		(send self :clear-screen)
		(send self :display-lines (char/= blip #\Tab) (char= blip #\Tab))
		(setq mouse-doc '(:documentation "3Any character to flush.*"))
		(tv:read-any self)
		(setq mouse-doc nil)
		(send self :refresh))
	       
	       (#\Control-Left-Arrow
		(cond ((plusp (char-int char))
		       (send self :edit-vf-char (int-char (1- char))))
		      (t (setq mouse-doc "3Can't go backwards.*") (beep) nil)))
	       
	       (#\Control-Right-Arrow
		(cond ((< (char-int char) 127)
		       (send self :edit-vf-char (int-char (1+ char))))
		      (t (setq mouse-doc "3Can't go forwards.*") (beep) nil)))
	       
	       (t (cond ((graphic-char-p blip)
			 (send self :edit-vf-char blip))
			(t (setq mouse-doc "3Bad character!*")
			   (beep))))))
	    ((and (consp blip) (eq (car blip) :mouse-button))
	     (let* ((x (- (fourth blip) tv:left-margin-size))
		    (y (- (fifth blip) tv:top-margin-size)))
	       (block DITCH
		 (when (case (second blip)
			 (#\Mouse-L-1  (send self :add-point        x y t))
			 (#\Mouse-L-2  (send self :add-point        x y nil))
			 (#\S-Mouse-L-1(send self :add-face         x y))
			 (#\Mouse-M-1  (send self :delete-some-line x y))	;1 Can't call it 5:delete-line*, that's taken...*
			 (#\Mouse-M-2  (send self :delete-point     x y))
			 (#\Mouse-R-1  (send self :move-point       x y))
			 (t
			  (setq mouse-doc "3Bad mouse button!*")
			  (beep) (return-from DITCH)))
		   (tv:mouse-standard-blinker tv:default-screen)
		   (setq any-changes t)
		   (send self :refresh))
		 (setq mouse-doc nil))))
	    (t
	     (setq mouse-doc "3Bad character!*")
	     (beep))))))


(defmethod 4(vf-editor-pane :who-line-documentation-string)* ()
  (let* ((std '(:Mouse-L-1 "3Add a connected point*"	:Mouse-L-2 "3Add a new point*"
		:Mouse-M-1 "3Delete a Line*"		:Mouse-M-2 "3Delete all lines connected to a point*"
		:Mouse-R-1 "3Move a point*"		:Mouse-R-2 "3System Menu*")))
    (cond ((null mouse-doc) std)
	  ((stringp mouse-doc) (list* :DOCUMENTATION mouse-doc std))
	  (t mouse-doc))))


(defun 4find-point-in-lines *(x y lines)
  (dolist (line lines)
    (let* ((p1 (car line)) (p2 (cdr line)))
      (cond ((and (= x (car p1)) (= y (cdr p1))) (return (values p1 line)))
	    ((and (= x (car p2)) (= y (cdr p2))) (return (values p2 line)))))))

(defun 4find-point-in-faces *(x y faces)
  (dolist (face faces)
    (let* ((p1 (first face))
	   (p2 (second face))
	   (p3 (third face)))
      (cond ((and (= x (car p1)) (= y (cdr p1))) (return (values p1 face)))
	    ((and (= x (car p2)) (= y (cdr p2))) (return (values p2 face)))
	    ((and (= x (car p3)) (= y (cdr p3))) (return (values p3 face)))))))


(defun 4find-line-in-lines *(x1 y1 x2 y2 lines)
  (dolist (line lines)
    (let* ((p1 (car line)) (p2 (cdr line)))
      (when (or (and (= x1 (car p1)) (= y1 (cdr p1))
		     (= x2 (car p2)) (= y2 (cdr p2)))
		(and (= x2 (car p1)) (= y2 (cdr p1))
		     (= x1 (car p2)) (= y1 (cdr p2))))
	(return line)))))


(defmethod 4(vf-editor-pane :move-point)* (x y)
  "2X and Y are pixel-positions relative to SELF.*"
  (let* ((mag (send self :magnification))
	 (px (round x mag))
	 (py (round y mag))
	 (point (if (and (eql px (car last-point-added))
			 (eql py (cdr last-point-added)))
		    last-point-added
		    (find-point-in-lines px py current-lines)
		    (find-point-in-faces px py current-faces)
		    )))
    (cond (point
	   (setq mouse-doc '(:Mouse-L-1 "3Select the new position of this point.*"))
	   (let* (blip)
	     (tv:mouse-set-blinker-definition :character 8 8 :on :set-character (int-char #o032))  ;1 circle-dot*
	     (loop
	       (setq blip (tv:read-any self))
	       (setq mouse-doc nil)
	       (cond ((and (consp blip) (eq (car blip) :mouse-button)
			   (char= (second blip) #\Mouse-L))
		      (let* ((mx (fourth blip))
			     (my (fifth blip))
			     (px2 (floor mx mag))
			     (py2 (floor my mag)))
			(setf (car point) px2
			      (cdr point) py2))
		      (return T))
		     (t (setq mouse-doc "3Bad Character!*")
			(beep) nil)))))
	  (t (setq mouse-doc "3No point indicated!*")
	     (beep) nil))))


(defmethod 4(vf-editor-pane :add-point)* (x y &optional link-p)
  (unless last-point-added (setq link-p nil))
  (let* ((mag (send self :magnification))
	 (px (round x mag))
	 (py (round y mag))
	 (existant-point (if (and (eql px (car last-point-added))
				  (eql py (cdr last-point-added)))
			     last-point-added
			     (find-point-in-lines px py current-lines)))
	 (existant-line  (and last-point-added
			      (find-line-in-lines px py (car last-point-added) (cdr last-point-added) current-lines))))
    
    (cond ((and (not link-p) existant-point)			;1 We're not linking, and there's a point there already - *
	   (setq last-point-added existant-point)		;1 Make it be the ``last point.''*
	   t)
	  ((and link-p existant-point existant-line)		;1 We're linking, but these two points are already connected - beep.*
	   (setq mouse-doc "3The indicated points are already connected!*")
	   (beep) nil)
	  ((and existant-point (eq existant-point last-point-added))   ;1 Clicked twice on the same point - beep.*
	   (setq mouse-doc "3The indicated points are the same!*")
	   (beep) nil)
	  ((not link-p)
	   (setq last-point-added (cons px py))
	   t)
	  (t
	   (let* ((point (or existant-point (cons px py))))
	     (push (cons point last-point-added) current-lines)
	     (setq last-point-added point)
	     t)))))


(defmethod 4(vf-editor-pane :delete-point)* (x y)
  (let* ((mag (send self :magnification))
	 (px (round x mag))
	 (py (round y mag))
	 (existant-point (find-point-in-lines px py current-lines))
	 (last-point-p (and (eql px (car last-point-added))
			    (eql py (car last-point-added)))))
    (cond ((and (null existant-point)
		(not last-point-p))
	   (setq mouse-doc "3No point indicated!*")
	   (beep) nil)
	  (last-point-p (setq last-point-added nil) t)
	  (t
	   (loop
	     (multiple-value-bind (ignore line) (find-point-in-lines px py current-lines)
	       (if line
		   (setq current-lines (delete line current-lines :test #'eq))
		   (return))))
	   (when (and last-point-added
		      (not (find-point-in-lines (car last-point-added) (cdr last-point-added) current-lines)))
	     (setq last-point-added nil))
	   t))))


(defmethod 4(vf-editor-pane :delete-some-line)* (x y)
  (let* ((mag (send self :magnification))
	 (px (round x mag))
	 (py (round y mag))
	 (existant-point (find-point-in-lines px py current-lines))
	 (md '(:Mouse-L-1 "3Select the other endpoint of the line to delete.*")))
    (cond ((null existant-point)
	   (setq mouse-doc "3No point indicated!*")
	   (beep) nil)
	  (t
	   (let* (blip)
	     (tv:mouse-set-blinker-definition :character 8 8 :on :set-character (int-char #o032))  ;1 circle-dot*
	     (setq mouse-doc md)
	     (loop
	       (setq blip (tv:read-any self))
	       (setq mouse-doc md)
	       (cond ((and (consp blip) (eq (car blip) :mouse-button) (char= (second blip) #\Mouse-L))
		      (let* ((mx (fourth blip))
			     (my (fifth blip))
			     (px2 (floor mx mag))
			     (py2 (floor my mag))
			     (line (find-line-in-lines px py px2 py2 current-lines)))
			(cond (line
			       (setq current-lines (delete line current-lines :test #'eq))
			       (when (and last-point-added
					  (not (find-point-in-lines (car last-point-added) (cdr last-point-added)
								    current-lines)))
				 (setq last-point-added nil))
			       (return T))
			      (t (setq mouse-doc "3No line indicated!*")
				 (beep) nil))))
		     (t (setq mouse-doc "3Bad character!*")
			(beep) nil))))))))


(defmethod 4(vf-editor-pane :add-face)* (x y)
  "2X and Y are pixel-positions relative to SELF.*"
  (let* ((mag (send self :magnification))
	 (px (round x mag))
	 (py (round y mag))
	 (point (find-point-in-lines px py current-lines)))
    (cond (point
	   (let* (point2 point3)
	     (flet ((next-click ()
		     (let* (blip)
		       (tv:mouse-set-blinker-definition :character 8 8 :on :set-character (int-char #o032))  ;1 circle-dot*
		       (loop
			 (setq blip (tv:read-any self))
			 (setq mouse-doc nil)
			 (cond ((and (consp blip) (eq (car blip) :mouse-button)
				     (or (char= (second blip) #\Mouse-L)
					 (char= (second blip) #\S-Mouse-L)))
				(let* ((mx (fourth blip))
				       (my (fifth blip))
				       (px2 (floor mx mag))
				       (py2 (floor my mag))
				       (point (and (not (or (and (eql px2 (car point)) (eql py2 (cdr point)))
							    (and (eql px2 (car point2)) (eql py2 (cdr point2)))
							    (and (eql px2 (car point3)) (eql py2 (cdr point3)))))
						   (or (find-point-in-lines px2 py2 current-lines)
						       (find-point-in-faces px2 py2 current-faces)
						       (and (char= (second blip) #\S-Mouse-L)
							    (cons px2 py2))))))
				  (if point
				      (return point)
				      (setq mouse-doc "3No indicated point!*")
				      (beep))))
			       (t (setq mouse-doc "3Bad Character!*")
				  (beep)))))))
	       (setq mouse-doc '(:Mouse-L-1 "3Select the second point for this face.*")
		     point2 (next-click)
		     mouse-doc '(:Mouse-L-1 "3Select the third (and last) point for this face.*")
		     point3 (next-click)
		     mouse-doc nil)
	       (push (list point point2 point3) current-faces))))
	  (t (setq mouse-doc "3No point indicated!*")
	     (beep) nil))))



;(defun 4flip-vf-char-h *(letter)
;  (let* ((offset (letter-height letter)))
;    (dolist (line (letter-lines letter))
;      (setf ;(line-x1 line) (- offset (line-x1 line))
;	    (line-y1 line) (- offset (line-y1 line))
;	    ;(line-x2 line) (- offset (line-x2 line))
;	    (line-y2 line) (- offset (line-y2 line))
;	    ))))


(defmethod 4(vf-editor-pane :build-vf-char)* (&optional lines-only)
  (let* ((vf-lines '())
	 (vf-faces '())
	 (fd (fed:font-get-fd raster-font-name))
	 (cd (aref fd (char-int char)))
	 (bit-width (array-dimension cd 1))
	 (bit-height (array-dimension cd 0))
	 (char-width (fed:cd-char-width cd))
	 (line-height (fed:fd-baseline fd))
	 (below (- bit-height line-height))
	 )
    (dolist (line current-lines)
      (push (make-line :x1 (caar line) :y1 (- (- bit-height (cdar line)) below)
		       :x2 (cadr line) :y2 (- (- bit-height (cddr line)) below)
		       )
	    vf-lines))
    (if (not lines-only)
	(dolist (face current-faces)
	  (push (make-face :x1 (caar face)   :y1 (- (- bit-height (cdar face)) below)
			   :x2 (caadr face)  :y2 (- (- bit-height (cdadr face)) below)
			   :x3 (caaddr face) :y3 (- (- bit-height (cdaddr face)) below)
			   )
		vf-faces))
	(let* ((old-letter (and vector-font (aref (vector-font-vector vector-font) (char-int char)))))
	  (when old-letter
	    (setq vf-faces (letter-faces old-letter)))))
    (make-letter :name char
		 :lines vf-lines
		 :faces vf-faces
		 :width  char-width
		 :height line-height
		 :left 0 :top 0
		 :right  bit-width
		 :bottom bit-height
		 )))

(defmethod 4(vf-editor-pane :update-vector-font)* (&optional lines-only)
  (unless vector-font
    (setq vector-font (or (get raster-font-name :vector-font)
			  (make-vector-font :name (string raster-font-name) :vector (make-array 128))))
    (setf (get raster-font-name :vector-font) vector-font))
  (let* ((vc (send self :build-vf-char lines-only)))
    (setf (aref (vector-font-vector vector-font) (char-int char)) vc)
    (setf (vector-font-char-height vector-font)
	  (max (vector-font-char-height vector-font) (letter-height vc)))
    (values vector-font vc)))


;(defmethod 4(vf-editor-pane :mindless-shuffle)* ()
;  (send self :expose)
;  (dotimes (i 128)
;    (send self :edit-vf-char (make-char i))
;    (send self :update-vector-font)))

(defmethod 4(vf-editor-pane :disassemble-vf-char)* ()
  (let* ((lines '())
	 (faces '())
	 (letter (aref (vector-font-vector vector-font) (char-int char)))
	 (height (and letter (letter-height letter))))
    (when letter
      (dolist (vf-line (letter-lines letter))
	(cond ((line-p vf-line)
	       (let* ((x1 (line-x1 vf-line))
		      (y1 (- height (line-y1 vf-line)))
		      (x2 (line-x2 vf-line))
		      (y2 (- height (line-y2 vf-line)))
		      (p1 (or (find-point-in-lines x1 y1 lines) (cons x1 y1)))
		      (p2 (or (find-point-in-lines x2 y2 lines) (cons x2 y2))))
		 (push (cons p1 p2) lines)))
	      (t ;1 otherwise it's a polyline.*
	       (let* ((first-x (aref vf-line 0 0))
		      (first-y (- height (aref vf-line 0 1)))
		      (last-x first-x)
		      (last-y first-y))
		 (dotimes (i (1- (array-dimension vf-line 0)))
		   (let* ((x (aref vf-line (1+ i) 0))
			  (y (- height (aref vf-line (1+ i) 1)))
			  (p1 (or (find-point-in-lines last-x last-y lines) (cons last-x last-y)))
			  (p2 (or (find-point-in-lines x y lines) (cons x y))))
		     (setq last-x x last-y y)
		     (push (cons p1 p2) lines)))
		 (when (polyline-closed-p vf-line)
		   (let* ((p1 (or (find-point-in-lines last-x last-y lines) (cons last-x last-y)))
			  (p2 (or (find-point-in-lines first-x first-y lines) (cons first-x first-y))))
		     (push (cons p1 p2) lines)))
		 ))
	      ))
      (dolist (vf-face (letter-faces letter))
	(let* ((x1 (face-x1 vf-face))
	       (y1 (- height (face-y1 vf-face)))
	       (x2 (face-x2 vf-face))
	       (y2 (- height (face-y2 vf-face)))
	       (x3 (face-x3 vf-face))
	       (y3 (- height (face-y3 vf-face)))
	       (p1 (or (find-point-in-lines x1 y1 lines)
		       (find-point-in-faces x1 y1 faces)
		       (cons x1 y1)))
	       (p2 (or (find-point-in-lines x2 y2 lines)
		       (find-point-in-faces x2 y2 faces)
		       (cons x2 y2)))
	       (p3 (or (find-point-in-lines x3 y3 lines)
		       (find-point-in-faces x3 y3 faces)
		       (cons x3 y3))))
	  (push (list p1 p2 p3) faces)))
      )
    (values lines faces)))

(defun 4find-consecutive-line *(line lines &optional head-p)
  (let* ((p (if head-p (car line) (cdr line)))
	 (x (car p))
	 (y (cdr p)))
    (dolist (line2 lines)
      (let* ((p1 (car line2))
	     (p2 (cdr line2)))
	(cond ((and (= x (car p1)) (= y (cdr p1)))
	       (return (values line2 nil)))
	      ((and (= x (car p2)) (= y (cdr p2)))
	       (return (values line2 t))))))))


;(defmethod 4(vf-editor-pane :display-some-lines)* (lines)
;  (let* ((old current-lines))
;    (unwind-protect
;	(progn
;	  (setq current-lines lines)
;	  (send self :refresh)
;	  )
;      (setq current-lines old))))


(defmethod 4(vf-editor-pane :compile-vf-char)* ()
  (send self :update-vector-font t)	  ;1 decompose any polylines into real lines for *:compile-faces-of-char1.*
  (let* ((lines (send self :disassemble-vf-char))
	 (letter (aref (vector-font-vector vector-font) (char-int char)))
	 (polypoints nil)
	 (lone-lines nil)
	 )
;    (send self :expose)
    (when (and letter (letter-faces letter))
      (send self :compile-faces-of-char))
    ;1; compose all possible lines into polylines.* 
    (loop
      (unless (and lines letter) (return))
      (let* ((line (pop lines)))
	(multiple-value-bind (attached-line head-p) (find-consecutive-line line lines nil)
	  (cond (attached-line
		 (push (list (if head-p (car attached-line) (cdr attached-line))
			     (copy-list (cdr line))
			     (copy-list (car line)))
		       polypoints)
		 (setq lines (delete attached-line lines :test #'eq)))
		(t
		 (push line lone-lines)))
	  (when attached-line
	     (loop
	       (let* (next-line)
		 (multiple-value-setq (next-line head-p) (find-consecutive-line attached-line lines head-p))
		 (cond (next-line
			(push (copy-list (if head-p (car next-line) (cdr next-line)))
			      (car polypoints))
			(setq lines (delete next-line lines :test #'eq))
			(setq attached-line next-line))
		       (t (return))))))
	  )))
    (let* ((real-polys '())
	   (fd (fed:font-get-fd raster-font-name))
	   (cd (aref fd (char-int char)))
	   (bit-height (array-dimension cd 0))
	   (line-height (fed:fd-baseline fd))
	   (below (- bit-height line-height)))
      (when polypoints
	(dolist (point-set polypoints)
	  (let* ((closed-p (equalp (car point-set) (car (last point-set)))))
	    (when closed-p (pop  point-set))
	    (dolist (point point-set)
	      (setf (cdr point) (- (- bit-height (cdr point)) below)))
	    (push (make-polyline closed-p point-set) real-polys))))
      (values real-polys lone-lines))))


(defmethod 4(vf-editor-pane :compile-faces-of-char*) ()
  "2Iterate over the triangular faces composing the current character, and annotate the DRAW-WHICH-EDGES slot with something reasonable
  (so that the character can be drawn with ALU-XOR, ALU-ADD, etc and the interior subdivisions will be invisible).
  This can't cope with polylines; the polylines must be decomposed into simple lines before calling this.*"
  (let* ((letter (aref (vector-font-vector vector-font) (char-int char)))
	 (edges (letter-lines letter))
	 (faces (letter-faces letter))
	 (dup-edges ())
	 (lines-and-their-faces ()))
    (dolist (face faces)
      (setf (face-draw-which-edges face) #b000)
      (labels ((this-line-p (line x1 y1 x2 y2)
		 (or (and (= x1 (line-x1 line)) (= y1 (line-y1 line))
			  (= x2 (line-x2 line)) (= y2 (line-y2 line)))
		     (and (= x2 (line-x1 line)) (= y2 (line-y1 line))
			  (= x1 (line-x2 line)) (= y1 (line-y2 line)))))
	       (get-line (x1 y1 x2 y2)
		 (or (find-if #'(lambda (line) (this-line-p line x1 y1 x2 y2))
			      edges)
		     (car (push (make-line :x1 x1 :y1 y1 :x2 x2 :y2 y2) edges)))))
	(let* ((line-1 (get-line (face-x1 face) (face-y1 face) (face-x2 face) (face-y2 face)))
	       (line-2 (get-line (face-x2 face) (face-y2 face) (face-x3 face) (face-y3 face)))
	       (line-3 (get-line (face-x3 face) (face-y3 face) (face-x1 face) (face-y1 face))))
	  ;1;*
	  ;1; Fill DUP-EDGES with a list of all of the lines which border the faces.*
	  ;1; There are three lines per face, so this list contains duplicate EQ lines.*
	  ;1;*
	  (push line-1 dup-edges)
	  (push line-2 dup-edges)
	  (push line-3 dup-edges)
	  (flet ((push-line (line which)
		   (assert line)
		   (let* ((a (assoc line lines-and-their-faces)))
		     (if a
			 (pushnew (cons face which) (cdr a))
			 (push (list line (cons face which))
			       lines-and-their-faces)))))
	    ;1;*
	    ;1; Fill LINES-AND-THEIR-FACES with a list of the form:*
	    ;1;*
	    ;1;*    (( <line-1> (<face-1> . 1) (<face-2> . 0) (<face-3> . 2) ... )
	    ;1;*     ( <line-2> (<face-1> . 0) (<face-5> . 1) ... ))
	    ;1;*
	    ;1; This is so we can easilly find all of the faces which contain a given line, and what edge of that*
	    ;1; face the line occupies.*
	    ;1;*
	    (push-line line-1 0)
	    (push-line line-2 1)
	    (push-line line-3 2))
	  )))
;1    ;;*
;1    ;; Delete edges which appear twice - if it's there twice, then it's on the inside of the figure, and *
;1    ;; we don't want to draw it in "outline" mode.*
;1    ;;*
;1    (setq edges (remove-duplicated-items dup-edges :test #'equal))*
    ;1;*
    ;1; Annotate faces with which edges to draw - if the edge is there twice, only draw it once.*
    ;1; Look at LINES-AND-THEIR-FACES to find all of the faces which contain a given line.*
    ;1; The first face which contains this line draws the edge on which this line appears.*
    ;1; Subsequent faces which contain this line do NOT draw the edge on which this line appears.*
    ;1; This guarentees that the shared edge of two triangles is drawn only once, and therfore the*
    ;1; triangles do not overlap.*
    ;1;*
    (flet ((frob-face (face which val)
	     (setf (face-draw-which-edges face)
		   (dpb val (lisp:byte 1 which) (face-draw-which-edges face)))))
      (dolist (cons lines-and-their-faces)
	(let* ((list (cdr cons)))
	  ;1; draw the first*
	  (frob-face (car (car list)) (cdr (car list)) 1)
	  ;1; ditch the rest*
	  (dolist (cons (cdr list))
	    (frob-face (car cons) (cdr cons) 0)))))
    letter))


(defmethod 4(vf-editor-pane :compile-munch)* ()
  (multiple-value-bind (polylines lone-lines) (send self :compile-vf-char)
    (send self :set-current-lines lone-lines)
    (multiple-value-bind (ignore vc) (send self :update-vector-font t)
      (setf (letter-lines vc) (nconc polylines (letter-lines vc)))
      )))

(defmethod 4(vf-editor-pane :compile-font)* ()
  (let* ((v (vector-font-vector vector-font)))
    (dotimes (i (length v))
      (when (aref v i)
	(unless (send self :exposed-p) (format t "3~C *" (make-char i)))
	(send self :edit-vf-char (make-char i))
	(send self :compile-munch)
	))))


(defmethod 4(vf-editor-pane :edit-vf-char)* (new-char)
  (check-type new-char character)
  (unwind-protect
      (progn
	(when any-changes
	  (let* ((*query-io* self))
	    (when (y-or-n-p "3~&There are unsaved changes; save them? *")
	      (send self :update-vector-font))))
	(setq char new-char
	      last-point-added nil
	      any-changes nil)
	(multiple-value-setq (current-lines current-faces) (send self :disassemble-vf-char)))
    (when (send self :exposed-p)
      (send self :refresh))))

(defmethod 4(vf-editor-pane :name-for-selection*) () (send self :name))

(defmethod 4(vf-editor-pane :save-font)* (pathname &optional (compile-p t))
  (when compile-p
    (format t "3~&Compiling: *")
    (send self :compile-font))
  (sys:dump-forms-to-file pathname
			  `((setf (get ',raster-font-name :vector-font) ',vector-font))
			  `(:mode :COMMON-LISP
			    :package "3VECTOR-FONT*"
			    :vector-font-name ,raster-font-name)))


(defun 4vectorize-font *(raster-font)
  (assert (and (symbolp raster-font) (tv:font-evaluate raster-font))
	  (raster-font)
	  "3RASTER-FONT is not a symbol naming a bitmap font.*")
  (w:select-or-create-window-of-flavor 'VF-EDITOR-PANE)
  (send tv:selected-window :set-raster-font-name raster-font)
  (unless (send tv:selected-window :set-vector-font (get raster-font :vector-font))
    (send tv:selected-window :update-vector-font))
  (send tv:selected-window :edit-vf-char (send tv:selected-window :char))
  (send tv:selected-window :process-input))




;1;; This is how much code it took for me to realize that converting a raster font to a vector font automatically*
;1;; was really really really hard.*
;1;;*

;(defun bounded-aref (bm x y)
;  "2Like aref, but returns zero if we go out of bounds.*"
;  (let* ((w (array-dimension bm 1))
;	 (h (array-dimension bm 0)))
;    (if (and (< -1 x w) (< -1 y h))
;	(aref bm y x)
;	0)))


;(defun 4analyze-bitmap *(bitmap &optional (draw-p t))
;  (let* ((w (array-dimension bitmap 1))
;	 (h (array-dimension bitmap 0))
;	 (bm2 (make-array (array-dimensions bitmap) :element-type 'bit :initial-element 0))
;	 )
;    (dotimes (y h)
;      (dotimes (x w)
;	(let* ((state (bounded-aref bitmap x y))
;	       (up    (bounded-aref bitmap x (1- y)))
;	       (down  (bounded-aref bitmap x (1+ y)))
;	       (left  (bounded-aref bitmap (1- x) y))
;	       (right (bounded-aref bitmap (1+ x) y))
;	       (state-change-p (and (plusp state)
;				    (not (= state up down left right))))
;	       (interior-p (plusp (logand up down left right)))
;	       )
;	  (when state-change-p
;	    (setf (aref bm2 y x) 1)
;	    (when draw-p (send window :draw-rectangle 10 10 (+ 100 (* x 10)) (+ 100 (* y 10)) tv:alu-xor))
;	    )
;	  (when interior-p
;	    (when draw-p (send window :draw-gray-rectangle 10 10 (+ 100 (* x 10)) (+ 100 (* y 10)) w:50%-gray tv:alu-xor))
;	    ))))
;    bm2))

;(defun 4analyze-edges *(bitmap)
;  (let* ((w (array-dimension bitmap 1))
;	 (h (array-dimension bitmap 0))
;	 (vectors '())
;	 )
;    (dotimes (y h)
;      (dotimes (x w)
;	(let* ((state (bounded-aref bitmap x y))
;	       (up    (bounded-aref bitmap x (1- y)))
;	       (down  (bounded-aref bitmap x (1+ y)))
;	       (left  (bounded-aref bitmap (1- x) y))
;	       (right (bounded-aref bitmap (1+ x) y))
;	       )
;	  (when (plusp state)
;	    (when (and (plusp right) (zerop left))	;1 opens right and not left*
;	      (let* ((run-length (do* ((i 0 (1+ i)))
;				      ((zerop (bounded-aref bitmap (+ x i) y))
;				       i))))
;		(push (list x y (+ x run-length) y) vectors)))
;	    (when (and (plusp down) (zerop up))		;1 opens down and not up*
;	      (let* ((run-length (do* ((i 0 (1+ i)))
;				      ((zerop (bounded-aref bitmap x (+ y i)))
;				       i))))
;		(push (list x y x (+ y run-length)) vectors)))
;	    ))))
;    (dolist (v vectors)
;      (let* ((x1 (pop v)) (y1 (pop v))
;	     (x2 (pop v)) (y2 (pop v)))
;	(multiple-value-setq (x2 y2) (find-nearest-vector x1 y1 x2 y2 vectors))
;	(send window :draw-line (+ 100 (* x1 10)) (+ 100 (* y1 10)) (+ 100 (* x2 10)) (+ 100 (* y2 10)) tv:alu-seta)
;;	(sleep 0.1)
;	))))

;(defun find-nearest-vector (x1 y1 x2 y2 vectors)
;  (let* ((distance most-positive-fixnum)
;	 (closest nil))
;    (dolist (cons vectors)
;      (let* ((vx1 (first cons)) (vy1 (second cons))
;	     (vx2 (third cons)) (vy2 (fourth cons))
;	     )
;	(flet ((check (x y)
;		 (unless (or (and (= x x1) (= y y1))
;			     (and (= x x2) (= y y2))
;			     (< y y1)
;			     )
;		   (let* ((dx (- x1 x))
;			  (dy (- y1 y))
;			  (dist (float (sqrt (+ (expt dx 2) (expt dy 2))) 1.0s0)))
;		     (when (< dist distance) (setq closest (cons x y) distance dist))
;		     (when (zerop distance) (return))))))
;	  (check vx1 vy1)
;	  ;(check vx2 vy2)
;	  )))
;    (if (and closest (< distance 4))
;	(values (car closest) (cdr closest))
;	(values x2 y2))))

;(defun 4perim-walk *(bitmap)
;  (let* ((w (array-dimension bitmap 1))
;	 (h (array-dimension bitmap 0))
;	 x y)
;    (block GOTONE
;      (dotimes (j h)
;	(dotimes (i w)
;;	  (send window :draw-gray-rectangle 10 10 (+ 100 (* i 10)) (+ 100 (* j 10)) w:50%-gray tv:alu-xor)
;	  (when (plusp (bounded-aref bitmap i j))
;	    (setq x i y j)
;	    (return-from GOTONE)))))
;    (let* ((path '())
;	   (dir nil)
;	   )
;      (loop
;	(push (cons x y) path)
;	(setf (aref bitmap y x) 0)
;	(send window :draw-point (+ 105 (* x 10)) (+ 105 (* y 10)) tv:alu-xor)
	
;	(macrolet ((test (test &body body)
;		     `(when ,test ,@body (return-from COND))))
;	  (macrolet ((+1=0 () '(test (plusp (bounded-aref bitmap (1+ x) y)) (incf x) (setq dir :r)))
;		     (-1=0 () '(test (plusp (bounded-aref bitmap (1- x) y)) (decf x) (setq dir :l)))
;		     (=0+1 () '(test (plusp (bounded-aref bitmap x (1+ y))) (incf y) (setq dir :d)))
;		     (=0-1 () '(test (plusp (bounded-aref bitmap x (1- y))) (decf y) (setq dir :u)))
		     
;		     (+1+1 () '(test (plusp (bounded-aref bitmap (1+ x) (1+ y))) (incf x) (incf y) (setq dir :rd)))
;		     (-1+1 () '(test (plusp (bounded-aref bitmap (1- x) (1+ y))) (decf x) (incf y) (setq dir :ld)))
;		     (+1-1 () '(test (plusp (bounded-aref bitmap (1+ x) (1- y))) (incf x) (decf y) (setq dir :ru)))
;		     (-1-1 () '(test (plusp (bounded-aref bitmap (1- x) (1- y))) (decf x) (decf y) (setq dir :lu)))

;		     (done () '(return))
;		     )
;	    (block COND
;	      (case dir
;		(:l  (-1-1) (-1+1) (=0-1) (=0+1) (+1-1) (+1+1) (-1=0) (+1=0) (done))
;		(:r  (+1+1) (+1-1) (=0-1) (=0+1) (-1+1) (-1-1) (+1=0) (-1=0) (done))
;		(:u  (-1-1) (+1-1) (-1=0) (+1=0) (-1+1) (+1+1) (=0-1) (=0+1) (done))
;		(:d  (+1+1) (-1+1) (-1=0) (+1=0) (-1+1) (-1-1) (=0+1) (=0-1) (done))
		
;		(:lu (-1=0) (=0-1) (-1+1) (+1-1) (=0+1) (+1=0) (-1-1) (+1+1) (done))
;		(:ru (=0-1) (+1=0) (-1-1) (+1+1) (-1=0) (+1=0) (+1-1) (-1+1) (done))
;		(:ld (-1=0) (+1=0) (-1-1) (+1+1) (=0-1) (+1=0) (-1+1) (+1-1) (done))
;		(t   (+1=0) (=0+1) (-1+1) (+1-1) (-1=0) (=0-1) (+1+1) (-1-1) (done))

;;		(:l  (-1=0) (-1-1) (-1+1) (=0-1) (=0+1) (+1-1) (+1+1) (+1=0) (done))
;;		(:r  (+1=0) (+1+1) (+1-1) (=0-1) (=0+1) (-1+1) (-1-1) (-1=0) (done))
;;		(:u  (=0-1) (-1-1) (+1-1) (-1=0) (+1=0) (-1+1) (+1+1) (=0+1) (done))
;;		(:d  (=0+1) (+1+1) (-1+1) (-1=0) (+1=0) (-1+1) (-1-1) (=0-1) (done))
		
;;		(:lu (-1-1) (-1=0) (=0-1) (-1+1) (+1-1) (=0+1) (+1=0) (+1+1) (done))
;;		(:ru (+1-1) (=0-1) (+1=0) (-1-1) (+1+1) (-1=0) (+1=0) (-1+1) (done))
;;		(:ld (-1+1) (-1=0) (+1=0) (-1-1) (+1+1) (=0-1) (+1=0) (+1-1) (done))
;;		(t   (+1+1) (+1=0) (=0+1) (-1+1) (+1-1) (-1=0) (=0-1) (-1-1) (done))
;		)))))
      
;      (let* ((x1 (car (car path)))
;	     (y1 (cdr (car path))))
;      (dolist (cons (cdr path))
;	(let* ((x2 (car cons)) (y2 (cdr cons)))
;	  (send window :draw-line (+ 105 (* x1 10)) (+ 105 (* y1 10)) (+ 105 (* x2 10)) (+ 105 (* y2 10)) tv:alu-xor)
;	  (setq x1 x2 y1 y2)))
;      ))))


;(setq f (fed:font-get-fd 'fonts:cmr18))
;(setq a (aref f (char-code #\A)))
;(setq b (aref f (char-code #\B)))
;(setq c (aref f (char-code #\C)))
;(setq x (aref f (char-code #\X)))
;(setq pl (aref f (char-code #\+)))

;(setq bb (analyze-bitmap a))
;(analyze-edges bb)