;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*- ;;; ;;; ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 149149 ;;; AUSTIN, TEXAS 78714-9149 ;;; ;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Authors: Delmar Hager, James Dutton, Teri Crowe ;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke (in-package "PICTURES") (defmacro valid-xcoord (var) `(typep ,var 'int16)) ;Private Macro: valid-xdistance ; Determine whether the given VAR is a valid distance for the X window system (defmacro valid-xdistance (var) `(typep ,var 'card16)) ;View Class Definition: ;;class-definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;Private Function: working-gcontext ; If GSTATE is nil, return the default-gcontext for VIEW. Otherwise, compute ; the working gcontext by combining the default gcontext with gstate. (DEFun search-for-gcontext (gstate view) (LET ((gcontext-cache (view-gcontext-cache view))) (DOTIMES (pos (LENGTH gcontext-cache) nil) (LET ((pair (ELT gcontext-cache pos))) (WHEN (gstate-equal gstate (FIRST pair)) (RETURN (SECOND pair))))))) (DEFMACRO prepare-gstate (gstate view) `(LET ((ga (slot-value ,gstate 'gstate-array))) (LET ((color (CADR (ELT ga foreground)))) (WHEN color (IF (STRINGP color) (SETF (gstate-value ,gstate :foreground) (LIST color (alloc-color (CAR (installed-colormaps ,view)) color))) color))) (LET ((color (CADR (ELT ga background)))) (WHEN color (IF (STRINGP color) (SETF (gstate-value ,gstate :background) (LIST color (alloc-color (CAR (installed-colormaps ,view)) color))) color))))) (DEFMACRO prepare-gcontext (view gstate gcontext) "set up the gcontext for drawing" `(LET ((ga (slot-value ,gstate 'gstate-array))) (WHEN (ELT ga foreground) (SETF (gcontext-foreground ,gcontext) (CADR (ELT ga foreground)))) (WHEN (ELT ga background) (SETF (gcontext-background ,gcontext) (CADR (ELT ga background)))) (WHEN (ELT ga line-style ) (SETF (gcontext-line-style ,gcontext) (ELT ga line-style))) (WHEN (ELT ga line-width) (SETF (gcontext-line-width ,gcontext) (floor (* (view-scale ,view)(ELT ga line-width))))) (when (elt ga function ) (SETF (gcontext-function ,gcontext) (elt ga function))) (when (elt ga ts-x ) (SETF (gcontext-ts-x ,gcontext) (elt ga ts-x))) (when (elt ga ts-y ) (SETF (gcontext-ts-y ,gcontext) (elt ga ts-y))) (when (elt ga arc-mode) (SETF (gcontext-arc-mode ,gcontext) (elt ga arc-mode))) (when (elt ga cap-style ) (SETF (gcontext-cap-style ,gcontext) (elt ga cap-style))) (IF (elt ga clip-mask ) (SETF (gcontext-clip-mask ,gcontext) (elt ga clip-mask)) (SETF (gcontext-clip-mask ,gcontext) :none)) (when (elt ga clip-x ) (SETF (gcontext-clip-x ,gcontext) (elt ga clip-x))) (when (elt ga clip-y ) (SETF (gcontext-clip-y ,gcontext) (elt ga clip-y))) (when (elt ga tile ) (SETF (gcontext-tile ,gcontext) (LET ((image (CADR (elt ga tile)))) (IF (= (image-depth image) 1) (contact-image-mask ,view image :foreground (OR (gstate-foreground gstate) 1) :background (OR (gstate-background gstate) 0)) (contact-image-pixmap ,view image))))) (when (elt ga dash-offset ) (SETF (gcontext-dash-offset ,gcontext) (elt ga dash-offset))) (when (elt ga dashes ) (SETF (gcontext-dashes ,gcontext) (elt ga dashes))) (when (elt ga fill-rule ) (SETF (gcontext-fill-rule ,gcontext) (elt ga fill-rule))) (when (elt ga fill-style ) (SETF (gcontext-fill-style ,gcontext) (elt ga fill-style))) (when (elt ga font ) (SETF (gcontext-font ,gcontext) (elt ga font))) (when (elt ga stipple-pix ) (setf (gcontext-stipple ,gcontext) (elt ga stipple-pix ))) (when (elt ga join-style ) (SETF (gcontext-join-style ,gcontext) (elt ga join-style))) (when (elt ga stipple ) (SETF (gcontext-stipple ,gcontext) (contact-image-mask ,view (CADR (elt ga stipple)) :foreground (OR (gstate-foreground gstate) 1) :background (OR (gstate-background gstate) 0)))) ) ) (defun working-gcontext ( view gstate) (with-gstate-value-place (prepare-gstate gstate view) (LET ((new-gcontext (search-for-gcontext gstate view))) (IF new-gcontext (LET ((ga (slot-value gstate 'gstate-array))) (WHEN (ELT ga line-width) (SETF (gcontext-line-width new-gcontext) (floor (* (ELT ga line-width) (view-scale view))))) (IF (elt ga clip-mask ) (SETF (gcontext-clip-mask new-gcontext) (elt ga clip-mask)) (SETF (gcontext-clip-mask new-gcontext) :none)) (WHEN (OR (elt ga stipple )(elt ga tile )(elt ga stipple-pix )) (when (elt ga ts-x ) (SETF (gcontext-ts-x new-gcontext) (elt ga ts-x))) (when (elt ga ts-y ) (SETF (gcontext-ts-y new-gcontext) (elt ga ts-y))))) (with-slots ( default-gcontext) view (SETF new-gcontext (create-gcontext :drawable view)) (copy-gcontext default-gcontext new-gcontext) (prepare-gcontext view gstate new-gcontext) (VECTOR-PUSH-EXTEND (LIST (gstate-copy gstate (make-gstate)) new-gcontext) (view-gcontext-cache view) ) ) ) new-gcontext ))) (defmethod view-draw-arc ((view view) x-min y-min width height angle1 angle2 &optional gstate) (declare (type wcoord x-min y-min width height)) (declare (type angle angle1 angle2)) (multiple-value-setq (x-min y-min) (transform-point view x-min y-min)) (multiple-value-setq (width height) (view-scale-point view width height)) (when (and (valid-xcoord x-min) (valid-xcoord y-min) (valid-xdistance width) (valid-xdistance height)) (draw-arc view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x-min (- y-min height) width height angle1 angle2))) (defmethod view-draw-filled-arc ((view view) x-min y-min width height angle1 angle2 &optional gstate) (declare (type wcoord x-min y-min width height)) (declare (type angle angle1 angle2)) (multiple-value-setq (x-min y-min) (transform-point view x-min y-min)) (multiple-value-setq (width height) (view-scale-point view width height)) (when (and (valid-xcoord x-min) (valid-xcoord y-min) (valid-xdistance width) (valid-xdistance height)) (draw-arc view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x-min (- y-min height) width height angle1 angle2 t))) (defmethod view-draw-line ((view view) start-x start-y end-x end-y &optional gstate) (declare (type wcoord start-x start-y end-x end-y)) (multiple-value-setq (start-x start-y) (transform-point view start-x start-y)) (multiple-value-setq (end-x end-y) (transform-point view end-x end-y)) (when (and (valid-xcoord start-x) (valid-xcoord start-y) (valid-xcoord end-x) (valid-xcoord end-y)) (draw-line view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) start-x start-y end-x end-y))) (defmethod view-draw-polypoint ((view view) point-sequence &optional gstate) (declare (type vector point-sequence)) (with-vector point-list (DOTIMES (i (LENGTH point-sequence)) (VECTOR-PUSH-EXTEND (AREF point-sequence i) point-list)) (draw-points view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) (view-transform-vector view point-list )) )) (defmethod view-draw-polyline ((view view) point-sequence &optional gstate) (declare (type vector point-sequence)) (with-vector point-list (DOTIMES (i (LENGTH point-sequence) ) (VECTOR-PUSH-EXTEND (AREF point-sequence i) point-list)) (draw-lines view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) (view-transform-vector view point-list)) )) (defmethod view-draw-polygon ((view view) point-sequence &optional gstate) (declare (type vector point-sequence)) (with-vector point-list (copy-to-vector point-sequence point-list) (insert-vertex point-list (vertex-x point-sequence 0) (vertex-y point-sequence 0) *large-number*) (draw-lines view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) (view-transform-vector view point-list )) )) (defmethod view-draw-filled-polygon ((view view) point-sequence &optional gstate) (declare (type vector point-sequence)) (with-vector point-list (copy-to-vector point-sequence point-list) (insert-vertex point-list (vertex-x point-sequence 0) (vertex-y point-sequence 0) *large-number*) (draw-lines view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) (view-transform-vector view point-list ) :fill-p t))) (defmethod view-draw-image ((view view) x-min y-min x-max y-max image &optional gstate) (declare (type wcoord x-min y-min)) (MULTIPLE-VALUE-SETQ (x-min y-min) (transform-point view x-min y-min )) (MULTIPLE-VALUE-SETQ (x-max y-max) (transform-point view x-max y-max )) (SETF (gstate-tile gstate) image) (WHEN (AND (valid-xcoord x-min) (valid-xcoord y-min)) (draw-rectangle view (working-gcontext view gstate) ; Draw it x-min y-max (ABS (- x-max x-min)) (ABS (- y-min y-max)) t))) (defmethod view-draw-rectangle ((view view) x-min y-min width height &optional gstate) (declare (type wcoord x-min y-min width height)) (multiple-value-setq (x-min y-min) ; Convert to view coordinates (transform-point view x-min y-min )) (multiple-value-setq (width height) (view-scale-point view width height )) (WHEN (AND (valid-xcoord x-min) ; Make sure rect is within the universe (valid-xcoord y-min) (valid-xdistance width) (valid-xdistance height)) (draw-rectangle view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) ; Draw it x-min (- y-min height) width height))) (defmethod view-draw-filled-rectangle ((view view) x-min y-min width height &optional gstate) (declare (type wcoord x-min y-min width height)) (multiple-value-setq (x-min y-min) ; Convert to view coordinates (transform-point view x-min y-min)) (multiple-value-setq (width height) (view-scale-point view width height)) (WHEN (AND (valid-xcoord x-min) ; Make sure rect is within the universe (valid-xcoord y-min) (valid-xdistance width) (valid-xdistance height)) (draw-rectangle view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) ; Draw it x-min (- y-min height) width height t))) (defmethod view-draw-text ((view view) x-origin y-origin text &optional gstate) (declare (type wcoord x-origin y-origin)) (declare (type string text)) (MULTIPLE-VALUE-BIND (x y) (transform-point view x-origin y-origin) (WHEN (AND (valid-xcoord x) (valid-xcoord y)) (draw-glyphs view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x y text)))) (defmethod view-draw-image-text ((view view) x-origin y-origin text &optional gstate) (declare (type wcoord x-origin y-origin)) (declare (type string text)) (MULTIPLE-VALUE-BIND (x y) (transform-point view x-origin y-origin) (WHEN (AND (valid-xcoord x) (valid-xcoord y)) (draw-image-glyphs view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x y text)))) (defmethod view-draw-char ((view view) x-origin y-origin text &optional gstate) (declare (type wcoord x-origin y-origin)) (declare (type string text)) (MULTIPLE-VALUE-BIND (x y) (transform-point view x-origin y-origin) (WHEN (AND (valid-xcoord x) (valid-xcoord y)) (draw-glyph view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x y text)))) (defmethod view-draw-image-char ((view view) x-origin y-origin text &optional gstate) (declare (type wcoord x-origin y-origin)) (declare (type string text)) (MULTIPLE-VALUE-BIND (x y) (transform-point view x-origin y-origin) (WHEN (AND (valid-xcoord x) (valid-xcoord y)) (draw-image-glyph view (if gstate (working-gcontext view gstate) (slot-value view 'default-gcontext)) x y text))))