;;; -*- Mode:Lisp; Syntax:Common-Lisp; Package:VECTOR-FONT -*- ;;; File "VECTOR-FONT" ;;; Drawing scalable 2D or 3D fonts on the TI screen. ;;; Includes a screensaver that picks random text from memory (that's right) and spins them around. ;;; ;;; ChangeLog: ;;; ;;; 4 Jan 89 Jamie Zawinski Created. ;;; 28 May 89 Jamie Zawinski Added 3D support! ;;; 6 Jun 89 Jamie Zawinski Started working on PolyLines. ;;; 18 Aug 89 Jamie Zawinski Got polylines working. ;;; 6 Dec 89 Jamie Zawinski Sped it up some more; got 3DTEXT-DEMO working (mostly). ;;; ;;; This is pretty gross code; forgive me my trespasses. ;;; ;;; The matrix operations are unwrapped into the corresponding EQs, and most of the functions ;;; take huge argument lists so that I don't have to recompute that much (just pass it on the stack). ;;; ;;; There is a lot of duplicated code (esp in the compute-extent part) which could be macro'ed out. ;;; ;;; This doesn't make the best screensaver, as it conses a small amount of temporary data, which ;;; could burn you if you have GC off. ;;; ;;; Also, if picking strings directly from memory is enabled, this will cause a heroic amount of swapping. ;;; ;;; The code for picking random strings from memory is really really gross - don't look to hard... ;;; There are IGNORE-ERRORS in there because SYS:MAP-OBJECTS occasionally gets an error - apparently the ;;; garbage collector sometimes leaves DTP-FREE headers in (what is marked as) a non-free region. ;;; Even worse - SYS:%STRUCTURE-SIZE-SAFE sometimes ILLOPs!! This really really shouldn't happen!! ;;; ;;; Explorer dependancies: ;;; ;;; o This won't run on a microexplorer because I call the ucode drawing primitives directly (as usual). ;;; o Someone porting this to other implementations may find filled text difficult - the Explorer has ;;; a microcoded procedure for drawing an arbitrary filled triangle. ;;; o The polylines code (which speeds up drawing of outline characters by almost x2) uses the esoteric ;;; :array-leader defstruct type. This could easilly have been implemented differently. ;;; (in-package "VECTOR-FONT" :nicknames '("VF") :use (if (find-package "IFF") '("LISP" "TICL" "IFF") '("LISP" "TICL"))) (export '(;; Drawing a string in a font of any size and aspect ratio: ;; draw-vector-char draw-hollow-vector-char draw-vector-string draw-hollow-vector-string vector-string-width ;; ;; Drawing a string in a font of any size and aspect ratio rotated and translated in three dimensions: ;; draw-hollow-vector-string draw-solid-hollow-vector-string compute-string-extent ;; ;; The raison d'etre: ;; 3dtext-demo countdown *string-pickers* *areas-with-strings* *symbols-ok* *gensyms-ok* ) "VF") (defstruct (line (:print-function %print-line)) "A structure for describing a line between two points." (x1 0 :type fixnum) (y1 0 :type fixnum) (x2 0 :type fixnum) (y2 0 :type fixnum)) (defun %print-line (self stream ignore) (format stream "#<~s ~d,~d ~d,~d>" (type-of self) (line-x1 self) (line-y1 self) (line-x2 self) (line-y2 self))) (defstruct (polyline (:type :array-leader) :named (:constructor %make-polyline) (:callable-constructors nil) (:print-function %print-polyline)) "A structure for describing a succession of connected lines." (fill-pointer 0 :type fixnum) (closed-p nil :type (member T NIL)) ) (defun (:property polyline sys:named-structure-invoke) (op self &rest args) (ecase op (:which-operations '(:print-self :describe :which-operations)) (:print-self (%print-polyline self (first args) (second args))) (:describe (sys:describe-defstruct self 'polyline) (format t "~&Points:~%") (dotimes (i (array-dimension self 0)) (format t " ~4D, ~D~%" (aref self i 0) (aref self i 1))) t))) (defun make-polyline (closed-p points) (let* ((npoints (length points)) (p (%make-polyline :make-array (:element-type 'fixnum :dimensions (list npoints 2)) :closed-p closed-p))) (do* ((rest points (cdr rest)) (i 0 (1+ i))) ((null rest)) (setf (aref p i 0) (caar rest) (aref p i 1) (cdar rest))) p)) (defun %print-polyline (struct stream ignore) (format stream "#<~S, ~D point~:P ~D>" (type-of struct) (array-dimension struct 0) (sys:%pointer struct))) (defstruct (face (:print-function %print-face)) "A structure for describing a filled triangle between three points." (x1 0 :type fixnum) (y1 0 :type fixnum) (x2 0 :type fixnum) (y2 0 :type fixnum) (x3 0 :type fixnum) (y3 0 :type fixnum) ;; This slot holds three bits, specifying which of the three edges should be drawn. ;; This is so that adjascent triangles will not overlap. (draw-which-edges #b111 :type (unsigned-byte 3)) ) (defun %print-face (self stream ignore) (format stream "#<~s ~d,~d ~d,~d ~d,~d (~3,'0b)>" (type-of self) (face-x1 self) (face-y1 self) (face-x2 self) (face-y2 self) (face-x3 self) (face-y3 self) (face-draw-which-edges self))) (defstruct letter "A structure representing a glyph in terms of the lines and triangles composing it." (name #\null :type (or string string-char)) (lines () :type list) ; LINES are used for drawing the character as an outline. (faces () :type list) ; FACES are used for drawing the character filled in. (width 0 :type fixnum) ; WIDTH and HEIGHT are how much space is intended for this character. (height 0 :type fixnum) ; Don't draw another character closer than this. (left 0 :type fixnum) ; (right 0 :type fixnum) ; LEFT, RIGHT, TOP, and BOTTOM describe the rectangle which the character actually (top 0 :type fixnum) ; occupies. This is the absolute minimum area in which this glyph will fit. (bottom 0 :type fixnum) ; ) (defstruct vector-font "A structure representing a set of characters by the points in them rather than by a bitmap." (name "" :type string) (char-height 0 :type fixnum) ; the height of the tallest character in the font. (vector #() :type vector) ; array elements contain NIL or a LETTER structure. ) ;;; ;;; Drawing Filled letters. ;;; (defun %draw-vector-char (window-or-array letter x y alu x-scale y-scale &optional pattern-or-nil) "Draw the letter on the window at XY. The window is assumed to be prepared, and have an appropriate clip region." (dolist (face (letter-faces letter)) (let* ((x1 (+ x (floor (* x-scale (face-x1 face))))) (y1 (+ y (floor (* y-scale (face-y1 face))))) (x2 (+ x (floor (* x-scale (face-x2 face))))) (y2 (+ y (floor (* y-scale (face-y2 face))))) (x3 (+ x (floor (* x-scale (face-x3 face))))) (y3 (+ y (floor (* y-scale (face-y3 face))))) (bits (face-draw-which-edges face))) (sys:%draw-shaded-triangle x1 y1 x2 y2 x3 y3 alu (logbitp 0 bits) (logbitp 1 bits) (logbitp 2 bits) pattern-or-nil window-or-array)))) (defun draw-vector-char (window char vector-font x y line-height &optional (alu tv:alu-transp) (aspect-ratio 1) color) "Draw the character on the window at XY. The character will be LINE-HEIGHT pixels tall." (let* ((letter (aref (vector-font-vector vector-font) (char-code char)))) (cond (letter (let* ((y-scale (float (/ line-height (letter-height letter)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale))) (setq y-scale (- y-scale)) (tv:prepare-color (window color) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (tv:prepare-sheet (window) (%draw-vector-char window letter x y alu x-scale y-scale)))) (* (letter-width letter) x-scale))) (t 0)))) (defun draw-vector-string (window string vector-font x y line-height &optional (alu tv:alu-transp) (aspect-ratio 1) color) "Draw the string on the window at XY. The characters will be LINE-HEIGHT pixels tall." (let* ((y-scale (float (/ line-height (vector-font-char-height vector-font)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale))) (setq y-scale (- y-scale)) (tv:prepare-color (window color) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (tv:prepare-sheet (window) (dotimes (i (length string)) (let* ((c (char-code (char string i))) (letter (aref (vector-font-vector vector-font) c))) (when letter (%draw-vector-char window letter (floor x) (floor y) alu x-scale y-scale)) (incf x (* (letter-width letter) x-scale)))))))) (ceiling x)) ;;; ;;; Outline 2D letters. ;;; (defun %draw-hollow-vector-char (window letter x y alu x-scale y-scale) "Draw the letter on the window at XY. The window is assumed to be prepared, and have an appropriate clip region." (declare (inline line-p) (optimize (speed 3) (safety 0))) (dolist (line (letter-lines letter)) (if (line-p line) (let* ((x1 (+ x (floor (* x-scale (line-x1 line))))) (y1 (+ y (floor (* y-scale (line-y1 line))))) (x2 (+ x (floor (* x-scale (line-x2 line))))) (y2 (+ y (floor (* y-scale (line-y2 line)))))) (sys:%draw-line x1 y1 x2 y2 alu nil window) ) ;; ;; Otherwise, it's a polyline. ;; (let* ((length (array-dimension line 0)) (first-x (+ x (floor (* x-scale (aref line 0 0))))) (first-y (+ y (floor (* y-scale (aref line 0 1))))) (prev-x first-x) (prev-y first-y)) (dotimes (i (1- length)) (let* ((this-x (+ x (floor (* x-scale (aref line (1+ i) 0))))) (this-y (+ y (floor (* y-scale (aref line (1+ i) 1)))))) ;(format t "~&~s ~s ~s ~s" prev-x prev-y this-x this-y) (sys:%draw-line prev-x prev-y this-x this-y alu nil window) (setq prev-x this-x prev-y this-y))) (when (polyline-closed-p line) (sys:%draw-line prev-x prev-y first-x first-y alu nil window)) ;(sleep 2) )))) (defun draw-hollow-vector-char (window char vector-font x y line-height &optional (alu tv:alu-transp) (aspect-ratio 1) color) (let* ((letter (aref (vector-font-vector vector-font) (char-code char)))) (cond (letter (let* ((y-scale (float (/ line-height (letter-height letter)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale))) (setq y-scale (- y-scale)) (tv:prepare-color (window color) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (tv:prepare-sheet (window) (%draw-hollow-vector-char window letter x y alu x-scale y-scale)))) (* (letter-width letter) x-scale))) (t 0)))) (defun draw-hollow-vector-string (window string vector-font x y line-height &optional (alu tv:alu-transp) (aspect-ratio 1) color) "Draw the string on the window at XY. The characters will be LINE-HEIGHT pixels tall." (let* ((y-scale (float (/ line-height (vector-font-char-height vector-font)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale))) (setq y-scale (- y-scale)) (tv:prepare-color (window color) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (tv:prepare-sheet (window) (dotimes (i (length string)) (let* ((c (char-code (char string i))) (letter (aref (vector-font-vector vector-font) c))) (when letter (%draw-hollow-vector-char window letter (floor x) (floor y) alu x-scale y-scale)) (incf x (* (letter-width letter) x-scale)))))))) (ceiling x)) ;;; ;;; 3D letters. ;;; (defsubst project (x y z scale perspective) "Translates 3space into 2space. SCALE is for sizing the image without affecting apparent perspective. 0.5 means halve the image, 2 means double it. PERSPECTIVE is the angle of view. Infinity means orthogonal projection. 0 means 360 view." (declare (values x y) (optimize speed)) (let* ((s*p (* scale perspective)) (p+z (+ perspective z))) (values (floor (* s*p x) p+z) (floor (* s*p y) p+z)))) (defsubst matrot (x y sin cos) (values (+ (* cos x) (* (- sin) y)) (+ (* sin x) (* cos y)))) (defsubst rotate (x y z xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) " Return X, Y, and Z rotated on all three axes. X-THETA is how many radians to rotate it around the X axis. Similarly for Y-THETA and Z-THETA." (declare (values x-prime y-prime z-prime)) (let* ((x2 x) (y2 y) (z2 z)) (multiple-value-setq (x2 y2) (matrot x2 y2 xy-sin xy-cos)) (multiple-value-setq (x2 z2) (matrot x2 z2 xz-sin xz-cos)) (multiple-value-setq (z2 y2) (matrot z2 y2 zy-sin zy-cos)) (values (round x2) (round y2) (round z2)))) (defun rotate-and-project (x y z scale perspective xo yo zo xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) "Returns projection of X,Y,Z rotated around 0,0,0, plus XO,YO,ZO. XO,YO,ZO are the translation to apply AFTER rotation." (declare (values x y)) (declare (inline rotate project)) (multiple-value-setq (x y z) (rotate x y z xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos)) (incf x xo) (incf y yo) (incf z zo) (project x y z scale perspective)) (defsubst map-point (x y z scale perspective xo yo zo origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (multiple-value-bind (2x 2y) (rotate-and-project x y z scale perspective xo yo zo xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (values (+ 2x origin-x) (+ 2y origin-y)))) (defsubst draw-line (x1 y1 z1 x2 y2 z2 scale perspective window &optional (alu tv:alu-xor) (xo 0) (yo 0) (zo 0) (origin-x 0) (origin-y 0) xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum origin-x origin-y)) (multiple-value-bind (2x1 2y1) (map-point x1 y1 z1 scale perspective xo yo zo origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum 2x1 2y1)) (multiple-value-bind (2x2 2y2) (map-point x2 y2 z2 scale perspective xo yo zo origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum 2x2 2y2)) (sys:%draw-line 2x1 2y1 2x2 2y2 alu t window) ))) (defsubst draw-face (x1 y1 z1 x2 y2 z2 x3 y3 z3 bits shade scale perspective window &optional (alu tv:alu-xor) (xo 0) (yo 0) (zo 0) (origin-x 0) (origin-y 0) xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (multiple-value-bind (2x1 2y1) (rotate-and-project x1 y1 z1 scale perspective xo yo zo xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (multiple-value-bind (2x2 2y2) (rotate-and-project x2 y2 z2 scale perspective xo yo zo xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (multiple-value-bind (2x3 2y3) (rotate-and-project x3 y3 z3 scale perspective xo yo zo xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (incf 2x1 origin-x) (incf 2x2 origin-x) (incf 2x3 origin-x) (incf 2y1 origin-y) (incf 2y2 origin-y) (incf 2y3 origin-y) (sys:%draw-shaded-triangle 2x1 2y1 2x2 2y2 2x3 2y3 alu (logbitp 0 bits) (logbitp 1 bits) (logbitp 2 bits) shade window))))) (defun %draw-solid-hollow-vector-char (window letter x y z alu x-scale y-scale perspective xo yo zo string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos ) "X Y Z The position of this letter relative to the lower-left corner of the string. XO YO ZO The point, relative to the lower-left corner of the string, to which rotations apply. *-SIN,COS Appropriate values for use in rotation. STRING-X,Y,Z The position of the lower-left corner of the string. " (declare (inline line-p) (optimize (speed 3) (safety 0))) (dolist (line (letter-lines letter)) (if (line-p line) (let* ((x1 (- (+ x (floor (* x-scale (line-x1 line)))) xo)) (y1 (+ (+ y (floor (* y-scale (line-y1 line)))) yo)) (z1 (- z zo)) (x2 (- (+ x (floor (* x-scale (line-x2 line)))) xo)) (y2 (+ (+ y (floor (* y-scale (line-y2 line)))) yo)) (z2 (- z zo))) ;; ;; Call this with XYZ values relative to the origin of the string. ;; XO,YO,ZO are position of the origin of the string. ;; (draw-line x1 y1 z1 x2 y2 z2 1 perspective window alu string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos)) ;; ;; PolyLine ;; (let* ((length (array-dimension line 0)) (first-3x (- (+ x (floor (* x-scale (aref line 0 0)))) xo)) (first-3y (+ (+ y (floor (* y-scale (aref line 0 1)))) yo)) (first-3z (- z zo))) (declare (fixnum length)) (multiple-value-bind (first-x first-y) (map-point first-3x first-3y first-3z 1 perspective string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum first-x first-y)) (let* ((prev-x first-x) (prev-y first-y)) (declare (fixnum prev-x prev-y)) (dotimes (i (1- length)) (let* ((this-3x (- (+ x (floor (* x-scale (aref line (1+ i) 0)))) xo)) (this-3y (+ (+ y (floor (* y-scale (aref line (1+ i) 1)))) yo)) (this-3z first-3z)) (multiple-value-bind (this-x this-y) (map-point this-3x this-3y this-3z 1 perspective string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum this-x this-y)) (sys:%draw-line prev-x prev-y this-x this-y alu nil window) (setq prev-x this-x prev-y this-y)))) (when (polyline-closed-p line) (sys:%draw-line prev-x prev-y first-x first-y alu nil window) ) )))))) (defun %draw-solid-vector-char (window letter x y z alu x-scale y-scale shade perspective xo yo zo string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) "X Y Z The position of this letter relative to the lower-left corner of the string. XO YO ZO The point, relative to the lower-left corner of the string, to which rotations apply. *-SIN,COS Appropriate values for use in rotation. STRING-X,Y,Z The position of the lower-left corner of the string. " (dolist (face (letter-faces letter)) (let* ((x1 (+ x (floor (* x-scale (face-x1 face))))) (y1 (+ y (floor (* y-scale (face-y1 face))))) (z1 z) (x2 (+ x (floor (* x-scale (face-x2 face))))) (y2 (+ y (floor (* y-scale (face-y2 face))))) (z2 z) (x3 (+ x (floor (* x-scale (face-x3 face))))) (y3 (+ y (floor (* y-scale (face-y3 face))))) (z3 z) (bits (face-draw-which-edges face))) (decf x1 xo) (decf y1 (- yo)) (decf z1 zo) (decf x2 xo) (decf y2 (- yo)) (decf z2 zo) (decf x3 xo) (decf y3 (- yo)) (decf z3 zo) ;; ;; Call this with XYZ values relative to the origin of the string. ;; XO,YO,ZO are position of the origin of the string. ;; (draw-face x1 y1 z1 x2 y2 z2 x3 y3 z3 bits shade 1 perspective window alu string-x string-y string-z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos)))) (defun draw-solid-hollow-vector-string (window string vector-font x y z ; string-position xo yo zo ; string-origin origin-x origin-y ; screen-origin-position xy-theta xz-theta zy-theta ; rotation perspective fill-p &optional (line-height 100) (alu tv:alu-transp) (aspect-ratio 1) (shade w:50%-gray) color) "Draw the string on the window at XY. The characters will be LINE-HEIGHT pixels tall." (let* ((y-scale (float (/ line-height (vector-font-char-height vector-font)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale)) (xy-sin (float (sin xy-theta) 1.0s0)) (xy-cos (float (cos xy-theta) 1.0s0)) (xz-sin (float (sin xz-theta) 1.0s0)) (xz-cos (float (cos xz-theta) 1.0s0)) (zy-sin (float (sin zy-theta) 1.0s0)) (zy-cos (float (cos zy-theta) 1.0s0)) (cx 0) (cy 0) (cz 0)) (setq y-scale (- y-scale)) (tv:prepare-color (window color) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (tv:prepare-sheet (window) (dotimes (i (length string)) (let* ((c (char-code (char string i))) (letter (aref (vector-font-vector vector-font) c))) (cond (letter (if fill-p (%draw-solid-vector-char window letter cx cy cz alu x-scale y-scale shade perspective xo yo zo x y z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (%draw-solid-hollow-vector-char window letter cx cy cz alu x-scale y-scale perspective xo yo zo x y z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos)) (incf cx (* (letter-width letter) x-scale))) ((= c (char-code #\Newline)) (setq cx 0 cy (+ cy line-height))) (t nil))))))) (values (ceiling cx)))) (defun compute-string-extent-internal (x y z ; string-position xo yo zo ; string-origin origin-x origin-y ; screen-origin-position perspective line-height cx cy xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos left-side-p) (declare (ignore left-side-p)) (let* ((x1 (- cx xo)) (y1 (+ cy yo)) (z1 (- zo)) (x2 x1) (y2 (- y1 line-height)) (z2 z1)) (multiple-value-bind (2x1 2y1) (map-point x1 y1 z1 1 perspective x y z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum 2x1 2y1)) (multiple-value-bind (2x2 2y2) (map-point x2 y2 z2 1 perspective x y z origin-x origin-y xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos) (declare (fixnum 2x2 2y2)) (values 2x1 2y1 2x2 2y2) )))) (defun compute-string-extent (string vector-font x y z ; string-position xo yo zo ; string-origin origin-x origin-y ; screen-origin-position xy-theta xz-theta zy-theta ; rotation perspective &optional (line-height 100) (aspect-ratio 1)) "Compute the smallest enclosing quadrangle of this 3string." (declare (values topleft-x topleft-y bottomleft-x bottomleft-y topright-x topright-y bottomright-x bottomright-y)) (let* ((y-scale (float (/ line-height (vector-font-char-height vector-font)) 1.0s0)) (x-scale (* (float aspect-ratio 1.0s0) y-scale)) (xy-sin (float (sin xy-theta) 1.0s0)) (xy-cos (float (cos xy-theta) 1.0s0)) (xz-sin (float (sin xz-theta) 1.0s0)) (xz-cos (float (cos xz-theta) 1.0s0)) (zy-sin (float (sin zy-theta) 1.0s0)) (zy-cos (float (cos zy-theta) 1.0s0)) (cx 0) (cy (- line-height (* y-scale (letter-height (aref (vector-font-vector vector-font) (char-code #\Space)))) )) ;(cz 0) ) (setq y-scale (- y-scale)) (let* (letter first-char-topleft-x first-char-topleft-y first-char-bottomleft-x first-char-bottomleft-y last-char-topright-x last-char-topright-y last-char-bottomright-x last-char-bottomright-y ) (dotimes (i (length string)) (let* ((c (char-code (char string i))) (l (aref (vector-font-vector vector-font) c))) ;; ## doesn't work with multi-line strings! (when l (when (null letter) (setq letter l) (multiple-value-setq (first-char-topleft-x first-char-topleft-y first-char-bottomleft-x first-char-bottomleft-y) (compute-string-extent-internal x y z xo yo zo origin-x origin-y perspective line-height cx cy xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos t))) (incf cx (* (letter-width l) x-scale)) ))) (multiple-value-setq (last-char-topright-x last-char-topright-y last-char-bottomright-x last-char-bottomright-y) (compute-string-extent-internal x y z xo yo zo origin-x origin-y perspective line-height cx cy xy-sin xy-cos xz-sin xz-cos zy-sin zy-cos nil)) (values first-char-topleft-x first-char-topleft-y first-char-bottomleft-x first-char-bottomleft-y last-char-topright-x last-char-topright-y last-char-bottomright-x last-char-bottomright-y)))) (defstruct string-object string vector-font height ; The height of the letters of this string. (aspect 1) ; The width of the string is based on HEIGHT, ASPECT, and the actual string. (x 0) (y 0) (z 0) ; The position of this string in 3space. X+ is the real position of a point PX. (xo 0) (yo 0) (zo 0) ; The points on a character of a vector-font are relative to the ; bottom left corner of that character. These slots represent the ; position in 3space which we want to think of as the ``origin'' of ; the string. Consider the string to have the lower-left corner of its ; leftmost character at the origin when thinking about these. (xy-theta 0) (xz-theta 0) (zy-theta 0) ; The rotation of the string around its origin. ) (defun draw-string-object (window string-object origin-x origin-y perspective fill-with &optional (alu tv:alu-transp)) (draw-solid-hollow-vector-string window (string-object-string string-object) (string-object-vector-font string-object) (string-object-x string-object) (string-object-y string-object) (string-object-z string-object) (string-object-xo string-object) (string-object-yo string-object) (string-object-zo string-object) origin-x origin-y (string-object-xy-theta string-object) (string-object-xz-theta string-object) (string-object-zy-theta string-object) perspective (not (null fill-with)) (string-object-height string-object) alu (string-object-aspect string-object) (if (eq fill-with 'T) W:100%-BLACK fill-with) )) (defun erase-string-object (window string-object origin-x origin-y perspective &optional (alu tv:alu-setz)) (multiple-value-bind (lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (compute-string-object-extent string-object origin-x origin-y perspective) (tv:prepare-sheet (window) (sys:%draw-shaded-triangle lx1 ly1 lx2 ly2 rx1 ry1 alu t t nil nil window) (sys:%draw-shaded-triangle rx2 ry2 lx2 ly2 rx1 ry1 alu t t nil nil window) ))) (defun compute-string-object-extent (string-object origin-x origin-y perspective) (compute-string-extent (string-object-string string-object) (string-object-vector-font string-object) (string-object-x string-object) (string-object-y string-object) (string-object-z string-object) (string-object-xo string-object) (string-object-yo string-object) (string-object-zo string-object) origin-x origin-y (string-object-xy-theta string-object) (string-object-xz-theta string-object) (string-object-zy-theta string-object) perspective (string-object-height string-object) (string-object-aspect string-object) )) (defun vector-string-width (string vector-font line-height &optional (aspect-ratio 1)) "Compute the length of the given string or character at the given scale. Returns three values: o the last X position reached; o the maximum X position reached; o the maximum Y position reached." (declare (values last-x max-x max-y)) (setq string (string string)) (let* ((last-x 0) (max-x 0) (max-y 0) (vector (vector-font-vector vector-font)) (x-scale (* (float aspect-ratio 1.0s0) (float (/ line-height (vector-font-char-height vector-font)) 1.0s0)))) (dotimes (i (length string)) (let* ((c (char string i)) (letter (and (< 0 (char-code c) (length vector)) (aref vector (char-code c))))) (cond (letter (incf last-x (* x-scale (letter-width letter)))) ((char= c #\Newline) (setq max-x (max max-x last-x) last-x 0 max-y (+ max-y line-height))) ))) (setq max-x (max max-x last-x)) (values (ceiling last-x) (ceiling max-x) (ceiling max-y)))) ;;; a screenhack! Pick random strings from memory and spin them around in threespace!! ;;; ;;; For testing. ;;; #+comment (defun spin (&optional (string "TEST") fill-with) (let* ((line-height 100) (string-object (make-string-object :string string :height line-height :vector-font (get 'FONTS:CMR18 :vector-font))) (persp 200) (origin-x 350) (origin-y 150) (window tv:selected-window) ) (multiple-value-bind (ignore width height) (vector-string-width string (string-object-vector-font string-object) line-height) (incf height line-height) (setf (string-object-xo string-object) (round width 2)) (setf (string-object-yo string-object) (- line-height (round height 2))) (setf (string-object-x string-object) 70) (setf (string-object-xz-theta string-object) -0.5) (let ((lx1 0) (ly1 0) (lx2 0) (ly2 0) (rx1 0) (ry1 0) (rx2 0) (ry2 0)) (declare (fixnum lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (optimize speed (safety 0))) ;; Erase previous image. ; (dotimes (i 50) (loop (let* ((alu tv:alu-xor)) (tv:prepare-sheet (window) (sys:%draw-shaded-triangle lx1 ly1 lx2 ly2 rx1 ry1 alu t t t nil window) (sys:%draw-shaded-triangle rx2 ry2 lx2 ly2 rx1 ry1 alu t t nil nil window) )) (sleep 0.3) (send window :clear-screen) ;; Draw current image. (draw-string-object window string-object origin-x origin-y persp fill-with) ;; Compute bounding box (quadrangle, really) for erase. (multiple-value-setq (lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (compute-string-object-extent string-object origin-x origin-y persp)) ; (incf (string-object-z string-object) -7) (incf (string-object-xy-theta string-object) 0.1) ; (incf (string-object-zy-theta string-object) 0.5) (incf (string-object-xz-theta string-object) 0.1) ))))) (defun countdown (&optional (from 10) (line-height 300) (inc 0.1) fill-with) (let* ((string-object (make-string-object :height line-height :xz-theta (* pi 3/2) :vector-font (get 'FONTS:CMR18 :vector-font))) (persp 200) (origin-x 350) (origin-y 150) (window tv:selected-window) ) (send window :clear-screen) (do* ((i from (1- i))) ((<= i 0)) (setf (string-object-string string-object) (princ-to-string i)) (multiple-value-bind (ignore width height) (vector-string-width (string-object-string string-object) (string-object-vector-font string-object) line-height) (incf height line-height) (setf (string-object-xo string-object) (round width 2)) (setf (string-object-yo string-object) (round (* height .3))) ) (let ((lx1 0) (ly1 0) (lx2 0) (ly2 0) (rx1 0) (ry1 0) (rx2 0) (ry2 0)) (declare (fixnum lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (optimize speed (safety 0))) (dotimes (i (ceiling (* pi 2) inc)) ;; Erase previous image. (let* ((alu tv:alu-back)) (tv:prepare-sheet (window) (sys:%draw-shaded-triangle lx1 ly1 lx2 ly2 rx1 ry1 alu t t t nil window) (sys:%draw-shaded-triangle rx2 ry2 lx2 ly2 rx1 ry1 alu t t nil nil window) )) ;; Draw current image. (draw-string-object window string-object origin-x origin-y persp fill-with) ;; Compute bounding box (quadrangle, really) for erase. (multiple-value-setq (lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (compute-string-object-extent string-object origin-x origin-y persp)) ; (setf (string-object-xz-theta string-object) 0) (incf (string-object-xz-theta string-object) inc) ; (incf (string-object-zy-theta string-object) inc) ; (incf (string-object-xy-theta string-object) inc) ))) (send window :clear-screen) 0)) (defvar *string-munchage* (make-array (length (documentation 'format)) ; Rough guess at the largest docstring. :element-type 'string-char :fill-pointer 0) "So we don't cons so much in MUNCH-ME-A-STRING.") (defvar *more-string-munchage* (make-array (array-total-size *string-munchage*) :element-type 'string-char :fill-pointer 0) "So we don't cons so much in MUNCH-ME-A-STRING.") ;(defun pick-words-from-string (string min-length max-length) ; (setq string (string-trim '(#\Space #\Tab) string)) ; (let* ((breaks (list 0)) ; (words-in-string nil) ; (break-chars '(#\Space #\Tab #\- #\_ #\:))) ; (dotimes (i (length string)) ; (when (and (member (char string i) break-chars :test #'char=) ; (not (eql i (car breaks)))) ; (push i breaks))) ; (unless (cdr breaks) (return-from PICK-WORDS-FROM-STRING string)) ; (push nil breaks) ; (let* ((end (cdr breaks))) ; (setq breaks (nreverse breaks) ; words-in-string (length breaks)) ; (setf (cdr end) breaks)) ; (dotimes (i (random words-in-string)) (pop breaks)) ; (let* ((n-words (1+ (random words-in-string))) ; (i 0) (j 0)) ; (setf (fill-pointer *more-string-munchage*) 0) ; (with-output-to-string (stream *more-string-munchage*) ; (loop ; (let* ((start (pop breaks)) ; (end (car breaks)) ; (word (subseq string start end))) ; (cond ((or (and (plusp j) (> (+ i (length word)) max-length)) ; (and (< min-length i) (> j n-words))) ; (return)) ; (t ; (unless (string= "" word) ; (incf i (length word)) ; (incf j) ; (unless (member (char word 0) break-chars :test #'char=) ; (princ #\Space stream)) ; (write-string word stream) ; )))))) ; *more-string-munchage*))) (defun munch-words-from-string-munchage (string low-limit limit) (let* ((ch-start (position-if #'alphanumericp *string-munchage*)) (ch-end (position-if #'alphanumericp *string-munchage* :from-end t)) (ch-len (- ch-end ch-start)) (range (- limit low-limit)) (target (+ low-limit (if (zerop range) 0 (random range)))) (start (if (> ch-len target) (random (- ch-len target)) 0)) (subseq-start (position-if #'alphanumericp string :start (position-if-not #'alphanumericp string :start start))) (subseq-end (or (position-if-not #'alphanumericp string :start (+ subseq-start target)) (length string)))) (replace (the string *string-munchage*) (the string *string-munchage*) :start1 0 :start2 subseq-start :end2 subseq-end) (setf (fill-pointer *string-munchage*) (- subseq-end subseq-start)))) (defun munch-me-a-string (&optional string) "Calls PICK-RANDOM-STRING until it gets one, then picks some random words from that string and returns them. This will always return a reasonably short string with some alphabetic characters in it." ; (return-from MUNCH-ME-A-STRING "12345ABCDEFGH") (let* (symbolp munched (limit 15) (low-limit 8)) (cond ((null string) (do () ((and (setq string (pick-random-string)) (not (zerop (length (string string))))))) (munch-me-a-string string)) (t (setf (fill-pointer *string-munchage*) 0) (cond (nil ; (setq symbolp (symbolp string)) (let* ((pn (cond ((null (symbol-package string)) "#") ((eq (symbol-package string) *keyword-package*) "") (t (package-name (symbol-package string))))) (lpn (length pn)) (sn (symbol-name string)) (lsn (length sn))) (setf (fill-pointer *string-munchage*) (min (+ lpn lsn 1) (array-total-size *string-munchage*))) (replace *string-munchage* pn :end1 lpn) (setf (aref *string-munchage* lpn) #\:) (replace *string-munchage* sn :start1 (1+ lpn)))) (t (unless (stringp string) (setq string (string string))) (setf (fill-pointer *string-munchage*) (min (length string) (array-total-size *string-munchage*))) (replace *string-munchage* string))) (when (> (length *string-munchage*) limit) (setq munched t) (munch-words-from-string-munchage (string string) low-limit limit)) (nsubstitute #\Newline #\Tab *string-munchage* :test #'char=) ;(nsubstitute #\Space #\- *string-munchage* :test #'char=) ;(nsubstitute #\Space #\_ *string-munchage* :test #'char=) ;(nsubstitute #\Space #\| *string-munchage* :test #'char=) ;(nsubstitute #\Newline #\: *string-munchage* :test #'char=) ;(nsubstitute #\Newline #\/ *string-munchage* :test #'char=) (nsubstitute #\Null #\( *string-munchage* :test #'char=) ;; Don't want to see parens! (nsubstitute #\Null #\) *string-munchage* :test #'char=) (nsubstitute #\Space #\Newline *string-munchage* :test #'char=) (values *string-munchage* symbolp munched))))) (defun bellcurve (n) "Picks a random number from -N to N, with a standard distribution." (let* ((n/2 (if (integerp n) (1+ (ceiling n 2)) (/ n 2)))) (- (+ (random n/2) (random n/2) (random n/2) (random n/2)) n))) (defun 3dtext-demo (&optional (window tv:selected-window)) (loop (when (and (boundp 'tv:*the-screen-is-black*) tv:*the-screen-is-black*) ;; Just in case... (send tv:who-line-screen :clear-screen)) (let* ((string (munch-me-a-string)) (line-height (+ 25 (random 75))) (fills (if (w:color-system-p window) '#.(list nil nil nil nil nil nil nil w:pink w:cyan w:magenta w:yellow w:green w:orange w:light-brown w:red-purple w:75%-gray w:50%-gray w:33%-gray) '#.(list nil nil nil nil nil nil nil w:100%-black w:100%-black w:100%-black w:100%-black w:75%-gray w:50%-gray w:33%-gray))) (fill-with (nth (random (length fills)) fills)) (string-object (make-string-object :string string :height line-height :vector-font (get 'FONTS:CMR18 :vector-font))) (origin-x (round (tv:sheet-width window) 2)) (origin-y (round (tv:sheet-height window) 2)) (persp 200) ) (ignore-errors (let* ((start-time (time:time)) (end-time (+ start-time (* 60 5))) (i (bellcurve 0.4s0)) (j (bellcurve 1.0s0)) (k (bellcurve 0.4s0)) (m (bellcurve 30)) (n (bellcurve 20)) (o (bellcurve 8)) ) (send window :clear-screen) ; just in case we left some turds (which isn't that unlikely). (let ((lx1 0) (ly1 0) (lx2 0) (ly2 0) (rx1 0) (ry1 0) (rx2 0) (ry2 0)) (declare (fixnum lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (optimize speed (safety 0))) (loop ;; Erase previous image. ; (let ((alu tv:alu-xor)) (let ((alu tv:alu-back)) (tv:prepare-sheet (window) (tv:with-clipping-rectangle ((tv:sheet-left-margin-size window) (tv:sheet-top-margin-size window) (tv:sheet-width window) (tv:sheet-height window)) (sys:%draw-shaded-triangle lx1 ly1 lx2 ly2 rx1 ry1 alu t t nil nil window) (sys:%draw-shaded-triangle rx2 ry2 lx2 ly2 rx1 ry1 alu t t nil nil window) ))) ;; ;; Draw current image. (draw-string-object window string-object origin-x origin-y persp fill-with) ;; ;; Compute bounding box (quadrangle, really) for erase. (multiple-value-setq (lx1 ly1 lx2 ly2 rx1 ry1 rx2 ry2) (compute-string-object-extent string-object origin-x origin-y persp)) (let* ((now (time:time))) (when (> now end-time) (return)) (do* () ((/= (time:time) now))) ; tick. ) (incf (string-object-x string-object) m) (incf (string-object-y string-object) n) (incf (string-object-z string-object) o) (incf (string-object-xy-theta string-object) i) (incf (string-object-zy-theta string-object) j) (incf (string-object-xz-theta string-object) k) ))))))) (defmacro do-regions-in-area ((region area) &body body) `(do* ((,region (sys:area-region-list ,area) (sys:region-list-thread ,region))) ((minusp ,region)) ,@body)) (defparameter *string-pickers* '(pick-random-string-from-editor pick-random-string-from-dictionary pick-random-string-from-cool-area) "A list of functions which, when called, will return a string to display. They may also return NIL, in which case we try again. These functions are called with no arguments.") (defun pick-random-string () "Returns a random string (or symbol) from out of the blue. It might be really really long (like a disk buffer) so be careful. Might also be NIL - if so, call this again, dude." (let* ((n (length *string-pickers*))) (if (zerop n) "ERROR: No Pickers!" (funcall (nth (random n) *string-pickers*))))) (defun pick-random-string-from-editor () "Returns a random line from a random editor buffer." (let* ((buffers-and-line-counts '())) (dolist (cons zwei:*zmacs-buffer-name-alist*) (let* ((interval (cdr cons)) (n (zwei:count-lines interval))) (when (> n 1) (push (cons interval n) buffers-and-line-counts)))) (when buffers-and-line-counts (let* ((which-buf (random (length buffers-and-line-counts))) (cons (nth which-buf buffers-and-line-counts)) (buffer (car cons)) (lines (cdr cons))) (setq buffers-and-line-counts nil) ; cut it loose fast so GC will get it. (flet ((do-buffer (buffer &optional bp nlines) (let* ((first-bp (or bp (zwei:interval-first-bp buffer))) (first-line (zwei:bp-line first-bp)) (line first-line) (which-line (random nlines)) (done-once nil) (i 0)) (loop (setq line (if line (zwei:line-next line) first-line) done-once t) (incf i) (cond ((and done-once (eq line first-line) (zerop i)) (return)) ; looping ((string= "" line) nil) ((>= i which-line) (return line))) )))) (cond ((typep buffer 'ZWEI:MAIL-FILE-BUFFER) ; descend into it, not just this message. I'd like to do (let* ((infs (send buffer :inferiors)) ; this for VisiDoc too, but it's not set up the same way. (inf (nth (random (length infs)) infs))) (do-buffer inf (send inf :headers-end-bp) lines))) ((typep buffer 'ZWEI:MAIL-SUMMARY-BUFFER) ; These aren't interesting. Ignore them. nil) (t (do-buffer buffer nil lines)))))))) ;(defun pick-random-object-from-hash-table (ht) ; (let* ((n (and ht (sys:hash-table-fullness ht))) ; (i (and n (random n)))) ; (when i ; (catch 'DONE ; (maphash #'(lambda (key ignore) ; (when (stringp key) ; (when (zerop (decf i)) (throw 'DONE key)))) ; ht) ; nil)))) (defun pick-random-object-from-hash-table (hash-table) (or (with-lock ((sys:hash-table-lock hash-table) :whostate "Hash Table Lock") (when (sys:rehash-for-gc hash-table) ;; Some %POINTER's may have changed, try rehashing (funcall (sys:hash-table-rehash-function hash-table) hash-table ())) (setq hash-table (sys:follow-structure hash-table)) (sys:inhibit-gc-flips (let* ((blen (sys:hash-table-block-length hash-table)) (random (random (floor (array-total-size hash-table) blen))) (elt (* random blen)) (loc (aloc hash-table (1+ elt)))) (if (= sys:DTP-NULL (sys:%p-data-type loc)) nil (sys:contents loc))))) ;; hash miss - try again. (pick-random-object-from-hash-table hash-table))) (defun pick-random-string-from-dictionary () "When the speller is loaded, returns a random word from the dictionary." (when (find-package "SPELLER") (let* ((sym (find-symbol "*MAIN-DICTIONARY*" "SPELLER")) (ht (and (boundp sym) (symbol-value sym) (send (symbol-value sym) :spell-hash)))) (and ht (pick-random-object-from-hash-table ht))))) (defvar *areas-with-strings* '(SYS:P-N-STRING SYS:DEBUG-INFO-AREA FS:PATHNAME-AREA SYS:NR-SYM) "These are the areas that PICK-RANDOM-STRING-FROM-COOL-AREA looks at. If you have defined an area, and that area has strings or symbols in it, you can add it to this list.") (when (and (find-package "PEGASYS") (boundp (find-symbol "PARSER-STRING-AREA" "PEGASYS"))) (push (find-symbol "PARSER-STRING-AREA" "PEGASYS") *areas-with-strings*)) (defvar *symbols-ok* t "T if it's ok for the memory-walking code to return symbols as well as strings.") (defvar *gensyms-ok* t "T if it's ok for the memory-walking code to return uninterned symbols as well as strings.") (defun pick-random-string-from-cool-area () (let* ((i (random (length *areas-with-strings*))) (area (nth i *areas-with-strings*))) (pick-random-string-from-area area nil nil *symbols-ok* *gensyms-ok*))) (defun pick-random-string-from-area (area min-length max-length symbols-ok gensyms-ok) (catch 'DONE (dotimes (i 20) ; no more than this. (let* ((n-regions 0)) (when (symbolp area) (setq area (symbol-value area))) (do-regions-in-area (region area) (incf n-regions)) (let* ((which (random n-regions)) (the-region (do-regions-in-area (r area) (if (zerop which) (return r) (decf which)))) (region-length (sys:region-free-pointer the-region))) (block NIL (when (or (zerop region-length) (sys:region-free-p the-region)) (return)) (let* ((start-addr (random region-length)) (addr (sys:%pointer-plus (sys:region-origin the-region) start-addr))) (ignore-errors (sys:map-objects addr :analysis-function #'(lambda (obj &rest ignore) (when (and obj (neq obj 'T) (or (and symbols-ok (symbolp obj) (or gensyms-ok (symbol-package obj))) (and (stringp obj) (or (not (or min-length max-length)) (< (or min-length 0) (length obj) (or max-length most-positive-fixnum))) (dotimes (i (length obj) nil) (when (and (alpha-char-p (char obj i)) (/= i 0)) (return t))) ))) (throw 'DONE obj)))))))))))) (defun pick-random-string-from-vmem (&key (min-length 0) (max-length most-positive-fixnum) (symbols-ok t) (gensyms-ok t)) (catch 'DONE (loop (let* ((list SYS:AREA-LIST) (which-area (random (length list))) (area (nth which-area list)) (n-regions 0)) (when (symbolp area) (setq area (symbol-value area))) (do-regions-in-area (region area) (incf n-regions)) (let* ((which (random n-regions)) (the-region (do-regions-in-area (r area) (if (zerop which) (return r) (decf which)))) (region-length (sys:region-free-pointer the-region))) (block NIL (when (or (zerop region-length) (sys:region-free-p the-region)) (return)) (let* ((start-addr 0) ; (random region-length)) (addr (sys:%pointer-plus (sys:region-origin the-region) start-addr))) (ignore-errors (sys:map-objects addr :analysis-function #'(lambda (obj &rest ignore) (when (and obj (neq obj 'T) (or (and symbols-ok (symbolp obj) (or gensyms-ok (symbol-package obj))) (and (stringp obj) (< min-length (length obj) max-length) (dotimes (i (length obj) nil) (when (and (alpha-char-p (char obj i)) (/= i 0)) (return t))) ))) (throw 'DONE obj))))))))))))