;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:VECTOR-FONT -*- ;;; File "BUILD-FONT" ;;; Converting Animate-4D IFF fonts to more usable format. ;;; Written and maintained by Jamie Zawinski. ;;; ;;; ChangeLog: ;;; ;;; 2 Jan 89 Jamie Zawinski Created. ;;; (in-package "VECTOR-FONT" :nicknames '("VF") :use '("LISP" "IFF" #+TI "TICL")) (import '( iff::sc3d-vert iff::sc3d-vert-p iff::sc3d-vert-x iff::sc3d-vert-y iff::sc3d-vert-z iff::sc3d-edge iff::sc3d-edge-p iff::sc3d-edge-a iff::sc3d-edge-b iff::sc3d-face iff::sc3d-face-p iff::sc3d-face-a iff::sc3d-face-b iff::sc3d-face-c iff::sc3d-hier iff::sc3d-hier-p iff::sc3d-hier-name iff::sc3d-hier-verts iff::sc3d-hier-children iff::sc3d-scene iff::sc3d-scene-p iff::sc3d-scene-verts iff::sc3d-scene-edges iff::sc3d-scene-faces iff::sc3d-scene-hiers iff::sc3d-scene-vnams iff::iff-read iff::iff-describe ) "VECTOR-FONT") (export '(load-font-directory create-vector-font) "VF") (defun load-font-directory (pathname) (setq pathname (merge-pathnames pathname (make-pathname :name :wild :type "scene" :version :newest))) (let* ((files (directory pathname)) (alist '())) (dolist (f files) (let* ((name (pathname-name f)) (scene (iff-read f nil))) (when (= (length name) 2) (setq name (string (int-char (parse-integer name :radix 16))))) (when scene (push (cons name scene) alist)))) alist)) (defun create-letter (scene) "Given an IFF SCENE representing a character of an Animate-4D font, build and return a LETTER structure." (let* ((hiers (sc3d-scene-hiers scene)) front-hier) ;; ;; SA4D font scenes have named objects for the front, back, and sides of a letter. ;; Look through the HIERs for the "front" HIER, which ends in the string "_f". ;; (dotimes (i (length hiers)) (let* ((name (sc3d-hier-name (aref hiers i)))) (when (string-equal name "_f" :start1 (- (length name) 2)) (setq front-hier (aref hiers i)) (return)))) (when front-hier (let* ((all-verts (sc3d-scene-verts scene)) (all-edges (sc3d-scene-edges scene)) (all-faces (sc3d-scene-faces scene)) (vertices (sc3d-hier-verts front-hier)) (edges '()) (faces '()) (max-x 0) (max-y 0) (min-x MOST-POSITIVE-FIXNUM) (min-y MOST-POSITIVE-FIXNUM) (width 0) (height 0) (name (sc3d-hier-name front-hier))) (setq name (subseq name 0 (- (length name) 2))) ; strip off the "_f". ;; ;; Edges. ;; Find those edges of the SCENE which contain points of the HIER. ;; (dotimes (i (length all-edges)) (let* ((edge (aref all-edges i)) (vert-1 (aref all-verts (sc3d-edge-a edge))) (vert-2 (aref all-verts (sc3d-edge-b edge)))) (when (or (find vert-1 vertices :test #'eq) (find vert-2 vertices :test #'eq)) (push edge edges) ;; ;; Getting the box size. Set the LEFT, RIGHT, TOP, and BOTTOM of the letter to the position of the ;; right, left, top, and bottommost points actually used in the letter. ;; (setf max-x (max max-x (sc3d-vert-x vert-1) (sc3d-vert-x vert-2)) max-y (max max-y (sc3d-vert-z vert-1) (sc3d-vert-z vert-2)) min-x (min min-x (sc3d-vert-x vert-1) (sc3d-vert-x vert-2)) min-y (min min-y (sc3d-vert-z vert-1) (sc3d-vert-z vert-2))) ))) ;; ;; Triangles. ;; Find those faces of the SCENE which contain points of the HIER. ;; (dotimes (i (length all-faces)) (let* ((face (aref all-faces i))) (when (or (find (aref all-verts (sc3d-face-a face)) vertices :test #'eq) (find (aref all-verts (sc3d-face-b face)) vertices :test #'eq) (find (aref all-verts (sc3d-face-c face)) vertices :test #'eq)) (push face faces)))) ;; ;; Set the WIDTH and HEIGHT of the letter to the position of the rightmost and topmost points ;; that are present anywhere in the entire scene - this is so that there may be a lone point ;; off in space saying "the letter must have this much space to the right." ;; (dotimes (i (length all-verts)) (let* ((vert (aref all-verts i))) (setf width (max width (sc3d-vert-x vert)) height (max height (sc3d-vert-z vert))))) ;; ;; making the thing. ;; (let* ((letter (make-letter :width width :height height :left min-x :right max-x :bottom min-y :top max-y :name name))) ;; ;; Convert the IFF SC3D-VERT, SC3D-EDGE, and SC3D-FACE structures to LINE and FACE structures. (flet ((edge-to-line (edge) (make-line :x1 (sc3d-vert-x (aref all-verts (sc3d-edge-a edge))) :y1 (sc3d-vert-z (aref all-verts (sc3d-edge-a edge))) :x2 (sc3d-vert-x (aref all-verts (sc3d-edge-b edge))) :y2 (sc3d-vert-z (aref all-verts (sc3d-edge-b edge))))) (face-to-face (face) (make-face :x1 (sc3d-vert-x (aref all-verts (sc3d-face-a face))) :y1 (sc3d-vert-z (aref all-verts (sc3d-face-a face))) :x2 (sc3d-vert-x (aref all-verts (sc3d-face-b face))) :y2 (sc3d-vert-z (aref all-verts (sc3d-face-b face))) :x3 (sc3d-vert-x (aref all-verts (sc3d-face-c face))) :y3 (sc3d-vert-z (aref all-verts (sc3d-face-c face)))))) (setq edges (mapcar #'edge-to-line edges)) (setq faces (mapcar #'face-to-face faces))) (setf (letter-lines letter) edges) (setf (letter-faces letter) faces) (clean-up-letter letter) letter))))) (defun clean-up-letter (letter) (let* ((edges (letter-lines letter)) (faces (letter-faces letter)) (dup-edges ()) (lines-and-their-faces ())) (dolist (face faces) (flet ((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)))))) (let* ((line-1 (find-if #'(lambda (line) (this-line-p line (face-x1 face) (face-y1 face) (face-x2 face) (face-y2 face))) edges)) (line-2 (find-if #'(lambda (line) (this-line-p line (face-x2 face) (face-y2 face) (face-x3 face) (face-y3 face))) edges)) (line-3 (find-if #'(lambda (line) (this-line-p line (face-x1 face) (face-y1 face) (face-x3 face) (face-y3 face))) edges)) ) ;; ;; Fill DUP-EDGES with a list of all of the lines which border the faces. ;; There are three lines per face, so this list contains duplicate EQ lines. ;; (when line-1 (push line-1 dup-edges)) (when line-2 (push line-2 dup-edges)) (when line-3 (push line-3 dup-edges)) (flet ((push-line (line which) (when 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)))))) ;; ;; Fill LINES-AND-THEIR-FACES with a list of the form: ;; ;; (( ( . 1) ( . 0) ( . 2) ... ) ;; ( ( . 0) ( . 1) ... )) ;; ;; This is so we can easilly find all of the faces which contain a given line, and what edge of that ;; face the line occupies. ;; (push-line line-1 0) (push-line line-2 1) (push-line line-3 2)) ))) ;; ;; Delete edges which appear twice - if it's there twice, then it's on the inside of the figure, and ;; we don't want to draw it in "outline" mode. ;; (setq edges (remove-duplicated-items dup-edges :test #'equal)) ;; ;; Annotate faces with which edges to draw - if the edge is there twice, only draw it once. ;; Look at LINES-AND-THEIR-FACES to find all of the faces which contain a given line. ;; The first face which contains this line draws the edge on which this line appears. ;; Subsequent faces which contain this line do NOT draw the edge on which this line appears. ;; This guarentees that the shared edge of two triangles is drawn only once, and therfore the ;; triangles do not overlap. ;; (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))) (frob-face (car (car list)) (cdr (car list)) 1) (dolist (cons (cdr list)) (frob-face (car cons) (cdr cons) 0))))) ;; ;; Install the lists. (setf (letter-lines letter) edges) (setf (letter-faces letter) faces) letter)) (defun remove-duplicated-items (list &key (test #'eql)) "Returns a new list, which is a copy of LIST with all items removed which appeared more than once." (let* ((result '())) (do* ((rest list (cdr rest))) ((null rest)) (cond ((member (car rest) (cdr rest) :test test) (setf (cdr rest) (delete (car rest) (cdr rest) :test test))) (t (push (car rest) result)))) (nreverse result))) (defun create-vector-font (name scene-alist) (let* ((vector (make-array 256)) (vf (make-vector-font :name name :vector vector)) (ch 0) ) (dolist (cons scene-alist) (let* ((name (car cons)) (scene (cdr cons)) ;; Amigas and Lispms have the same symbol character mapping! No conversion is necessary. (code (when (= 1 (length name)) (char-code (char name 0)))) (letter (when code (create-letter scene)))) (when (and code letter) (setf (aref vector code) letter) (setf ch (max ch (letter-height letter))) ))) (setf (vector-font-char-height vf) ch) (dotimes (i 255) (let* ((letter (aref vector i))) (when letter (setf (letter-height letter) ch)))) ;; ;; If there is no space character defined, then make one. ;; (unless (aref vector (char-code #\Space)) (let* ((model (or (aref vector (char-code #\n)) ; base it's width on lowercase N or uppercase I. (aref vector (char-code #\I))))) (when model (setf (aref vector (char-code #\Space)) (make-letter :name #\Space :width (letter-width model) :height ch))))) vf)) ;(defvar *scene-font* (load-font-directory "eti:/usr2/jwz/iff-font/*.scene")) ;(defvar *vector-font* (create-vector-font "vec" *scene-font*)) #+TI (defun save-vector-font (font-symbol pathname) (check-type font-symbol symbol "a symbol holding a vector font.") (let* ((font (symbol-value font-symbol))) (check-type font vector-font) (dump-forms-to-file pathname `((proclaim '(special ,font-symbol)) (setq ,font-symbol ',font)) '(:mode :LISP :package "VECTOR-FONT"))))