;;; -*- mode:lisp; package: tv; base:10.; -*- ;;; ;;; VECTOR ;;; This file contains code to implement vector character drawing ;;; on the lisp machine. ;;; Vector characters are drawn, naturally, as sequences of line segments. ;;; These segments are stored internally (and externally) in NORMALIZED ;;; form, which means that the coordinates of the body of the character ;;; are constrained by a box from (0 -20) to (100 100). The negative ;;; vertical region allows descenders. In principal, there is no reason ;;; why characters might not extend out of that range. ;;; Some of the benefits to be expected from vector character drawing ;;; are: ;;; Ability to rotate characters, thus writing in any direction. ;;; Ability to compress or expand characters, in either dimension. ;;; Ability to create "slanted" characters for emphasis if desired. ;;; ;;; The initial emphasis of this project is to create a TV:VECTOR-CHARACTER-MIXIN ;;; flavor which supports vector character operations. The methods will be: ;;; ;;; :DRAW-VECTOR-CHARACTER char base-x base-y ;;; &key (height 100.) (width 100.) (rotation 0) (slant 0) font ;;; ;;; :DRAW-VECTOR-STRING string from-x from-y to-x to-y ;;; &key (height 100.) (width 100.) (slant 0) (stretch-p nil) font ;;; The string drawing message offers the option of "stretching" the characters. If ;;; requested, the width of the characters will be computed based on the length of the ;;; line and the number of characters in the string. ;;; The representation for a character is a list of line-segments, each of which is ;;; a list of 4 coordinates: x1 y1 x2 y2. A font is a list of 128 character definitions, ;;; exactly. Naturally, you may have a NULL representation if you wish. This representation ;;; easily lends itself to external printing. ;;; ********** ;;; ;;;; NOTE WELL: ;;; ;;; The coordinate system in this package is a little screwy. Characters are ;;; drawn UPWARDS from their baseline, that is in the -Y direction. ;;; **************************************************************** ;;; Necessary Loads, Constants, Declarations. ;;; **************************************************************** ;;; Initialize the three vectors used for transformation stuff. (defvar *vector-input-array* (make-array '(1 3)) "Used for input of coordinates to matrix multiplication.") (fillarray *vector-input-array* '(0 0 1)) (defvar *vector-output-array* (make-array '(1 3)) "Used for result of matrix multiplication calculations.") (fillarray *vector-output-array* '(0 0 1)) (defvar *vector-transformation-array* (make-array '(3 3)) "Used for the transformation matrix.") (fillarray *vector-transformation-array* '(0 0 0 0 0 0 0 0 1)) ;;; Test character. (defconst *test-a* '((0 0 45. 100.) (45. 100. 90. 0.) (22. 50 68. 50.))) ;;; **************************************************************** ;;; Internal Macros, Structure Definitions, FLAVOR definitions. ;;; **************************************************************** ;;; The mixin you should use. Suggested that you mix this into some window. (defflavor vector-character-mixin () () (:required-flavors tv:sheet)) (defflavor vector-character-window () (vector-character-mixin window)) ;;; **************************************************************** ;;; User Accessible Code ;;; **************************************************************** ;;; Draws a string. This is more efficient than drawing characters, ;;; since it computes certain things only once. (defmethod (vector-character-mixin :draw-vector-string) (string from-x from-y to-x to-y &key (wide 100.) (high 100.) (slant 0) (stretch-p nil) (alu tv:alu-ior) (font nil)) (let* ((atan (atan (- from-y to-y) (- to-x from-x))) (cos-rot (cos atan)) (sin-rot (sin atan)) (length (line-length from-x from-y to-x to-y)) (widd (if stretch-p (// length (string-length string)) wide)) (wid ( // widd 100.0)) ;; Normalize for int-draw-vect-char (hei (// high 100.0))) ;; Now, loop over the characters in the string, moving from ;; the FROM point to the TO point, spacing along the line ;; WIDE at a time. (loop with delta-x = (- to-x from-x) with delta-y = (- to-y from-y) for i from 0 to (1- (string-length string)) for frac = (// (* widd i) length) do (lexpr-send self ':internal-draw-vector-character (+ (* frac delta-x) from-x) (+ (* frac delta-y) from-y) wid hei cos-rot sin-rot slant alu (vector-get-char (aref string i) font))))) ;;; Draws a character. (defmethod (vector-character-mixin :draw-vector-character) (char base-x base-y &key (iwidth 100.) (iheight 100.) (rotation 0.) (slant 0) (alu tv:alu-ior) font) (lexpr-send self ':internal-draw-vector-character base-x base-y (// iwidth 100.0) (// iheight 100.0) (cos rotation) (sin rotation) slant alu (vector-get-char char font))) ;;; One of the biggies. Loads a vector character set from a bunch ;;; of files. Use the graph editor to create a file for each character ;;; in the character set. Then run this function. It loops through ;;; the alphabet, from 1 to 127, constructing a character from the ;;; appropriate file. (You must save in files numbered from 1. to 127. ;;; (note the decimal-point in the name of the file.)) (defun load-vector-font (&optional (font-name ':standard) (directory "bigbird://ct//lmcode//graph//vectorfonts//")) (putprop (intern font-name ':fonts) (vector-font-normalize (loop for i from 1 to 127 do (format t " ~:C" i) collect (massage-font-file (format nil "~A~D." directory i)))) ':vector-font)) ;;; **************************************************************** ;;; Internal Code ;;; **************************************************************** ;;; Retrieves a font from a symbol, and returns the correct character. Crude. (defun vector-get-char (char font-symbol) (nth (1- char) (get (intern font-symbol ':fonts) ':vector-font))) ;;; Internal method. Requires you to provide all the parameters. The ;;; segments must have already been looked up. We ask for the sine and ;;; cosine of the rotation because it will be more efficient in printing ;;; a string to compute it once. Height and width are the SCALING factors ;;; to transform the 100 x 100 character. These aren't really pixel ;;; sizes. ;;; ;;; +++++++++++ Temporarily, we are not supporting slant. ;;; ;;; Note that we don't bother worrying about endpoints. Thus, if you ;;; are worried about looks, you ought to specify ALU functions of ;;; IOR for drawing and ANDCA for erasing. ;;; +++++ A future improvement MAY keep track of points drawn inside ;;; a character, and not redraw them where possible. Don't hold your ;;; breath. *** "IGNORE" argument was "slant". (defmethod (vector-character-mixin :internal-draw-vector-character) (base-x base-y iwidth iheight cos-rot sin-rot ignore alu &rest segments) ;; First, load the matrix with the right transformations. (aset (* iwidth cos-rot) *vector-transformation-array* 0 0) (aset (* iheight sin-rot -1) *vector-transformation-array* 0 1) (aset (* iwidth sin-rot) *vector-transformation-array* 1 0) (aset (* iheight cos-rot) *vector-transformation-array* 1 1) ;; Now, draw the segments. (loop for segment in segments for x1 = (progn (aset (first segment) *vector-input-array* 0 0) (aset (second segment) *vector-input-array* 0 1) (math:multiply-matrices *vector-input-array* *vector-transformation-array* *vector-output-array*) (aref *vector-output-array* 0 0)) for y1 = (aref *vector-output-array* 0 1) for x2 = (progn (aset (third segment) *vector-input-array* 0 0) (aset (fourth segment) *vector-input-array* 0 1) (math:multiply-matrices *vector-input-array* *vector-transformation-array* *vector-output-array*) (aref *vector-output-array* 0 0)) for y2 = (aref *vector-output-array* 0 1) do (send self ':draw-line (fix (+ base-x x1)) (fix (+ base-y y1)) (fix (+ base-x x2)) (fix (+ base-y y2)) alu))) ;;; Returns the length of a line from point x1 y1 to x2 y2 (defun line-length (x1 y1 x2 y2) (sqrt (+ (sqr (- x2 x1)) (sqr (- y2 y1))))) ;;; Square of X. (defun sqr (x) (* x x)) ;;; Loads in a character description from a file (defun massage-font-file (filename) (if (probef filename) ;; If file is found, read it in. File contains one big list ;; whose third element is list of arcs. Second element is list ;; of nodes. (let ((stuff (with-open-file (stream filename ':in) (read stream)))) (loop for arc in (third stuff) ;; Let someone else do the real work. collect (massage-font-file-arc arc (second stuff)))))) ;;; Given an arc (and all the nodes), return a segment description ;;; for the arc. All we need is the coordinates for the head and ;;; tail, factored down by 10. (I think). (defun massage-font-file-arc (arc all-nodes) (let ((head (nth (second (memq 'head arc)) all-nodes)) (tail (nth (second (memq 'tail arc)) all-nodes))) (list (second (memq 'x head)) (second (memq 'y head)) (second (memq 'x tail)) (second (memq 'y tail))))) ;;; This function accepts a font description (list of 127 characters) ;;; and normalizes the dimensions correctly. We look at the "A" character ;;; and from it compute the HEIGHT and BASE positions, then normalize ;;; all characters accordingly. (defun vector-font-normalize (font) (cond ((not (nth #/A font)) ;If no A character (format t "~%Sorry, font can't be normalized.")) (t (let ((height 0) (base-y 0) (base-x 0)) ;; First, compute the extent of the A character. (loop for segment in (nth #/A font) minimize (first segment) into min-x minimize (third segment) into min-x minimize (second segment) into min-y minimize (fourth segment) into min-y maximize (second segment) into max-y maximize (fourth segment) into max-y finally (setq height (// (- max-y min-y) 100.0) base-x min-x base-y min-y)) (format t "~%Character Height factor: ~A" height) (format t "~%Character Base: ~D ~D" base-x base-y) ;; Now, loop through all characters, DESTRUCTIVELY modifying ;; them with the normalized sizes. (loop for char in font do (loop for segment in char do (setf (first segment) (// (- (first segment) base-x) height 1.2)) do (setf (second segment) (// (- (second segment) base-y) height)) do (setf (third segment) (// (- (third segment) base-x) height 1.2)) do (setf (fourth segment) (// (- (fourth segment) base-y) height))))) font)))