;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Reason: W:graphoc-mixin changes to correct several bugs and allow user to ;;; determine wheter or not rectangles are drawn as usual or 1-pixel ;;; less if scaling factors are 1:1. See w:*adjust-rectangles* . ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Patch file for TV version 6.5 ;;; Written 05/22/89 15:42:11 by MARKY, ;;; while running on LIBRA from band LODA ;;; With Experimental REL6H 6.18, SYSTEM 6.2, Experimental VIRTUAL-MEMORY 6.0, Experimental EH 6.0, ;;; Experimental MAKE-SYSTEM 6.0, Experimental MICRONET 6.0, Experimental LOCAL-FILE 6.0, ;;; Experimental BASIC-PATHNAME 6.0, Experimental NETWORK-SUPPORT-COLD 6.0, Experimental BASIC-NAMESPACE 6.0, ;;; Experimental NETWORK-NAMESPACE 6.0, Experimental DISK-IO 6.0, Experimental DISK-LABEL 6.0, ;;; Experimental BASIC-FILE 6.0, Experimental MAC-PATHNAME 6.0, Experimental NETWORK-PATHNAME 6.0, ;;; COMPILER 6.1, TV 6.4, Experimental DATALINK 6.0, Experimental CHAOSNET 6.0, Experimental GC 6.0, ;;; Experimental MEMORY-AUX 6.0, Experimental NVRAM 6.0, Experimental SYSLOG 6.0, ;;; Experimental STREAMER-TAPE 6.0, Experimental CLEH 1.0, Experimental UCL 6.0, ;;; Experimental INPUT-EDITOR 6.0, Experimental METER 6.0, Experimental ZWEI 6.0, ;;; Experimental DEBUG-TOOLS 6.0, Experimental NETWORK-SUPPORT 6.0, Experimental NETWORK-SERVICE 6.0, ;;; DATALINK-DISPLAYS 6.0, Experimental FONT-EDITOR 6.0, Experimental SERIAL 6.0, ;;; Experimental PRINTER 6.0, Experimental MAC-PRINTER-TYPES 6.0, Experimental PRINTER-TYPES 6.0, ;;; Experimental IMAGEN 6.0, Experimental SUGGESTIONS 6.0, MAIL-DAEMON 6.2, Experimental MAIL-READER 6.0, ;;; Experimental TELNET 6.0, Experimental VT100 6.0, Experimental NAMESPACE-EDITOR 6.0, ;;; PROFILE 6.1, VISIDOC 6.0, Experimental TI-CLOS 17.6, Experimental CLX 5.0, Experimental CLUE 20.0, ;;; Experimental X11M 3.0, RPC 6.0, Experimental NFS 6.0, Experimental BUG 11.5, ;;; IP 3.45, MMON 1.0, microcode 419, Band Name: 6.0 sle 5/3 mmon ;;; 05/22/89 MAY Reverted 05/08/89 changes in :draw-filled-circle. Changed :draw-polyline to fix ;;; single point case and MAC side for spr's 9693 abd 9447 respectively. ;;; Added texture arg to :draw-point for SPR 9693 :draw-filled-circle bug. ;;; Added (graphics-mixin :adjust) and *adjust-rectangles*. ;;; Changed :draw-rectangle and :draw-filled-rectangle to trap cases where rectangle ;;; is so small it really is a point or a filled rectangle. ;;; Backed out patch 4-121 to :draw-filled-polygon. ;;; 05/22/89 MAY Backed out change to draw-clipped-solid-triangle - was not satisfactory. #!C ; From file GRAPHICS.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; GRAPHICS.#" (defmethod (graphics-mixin :draw-filled-circle) (x-center y-center radius &optional (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (num-points 29) (draw-edge t) (texture *default-texture*)) "This method draws a solid, filled in circle." (unless (null color) (IF (mac-window-p self) (MULTIPLE-VALUE-BIND (x-radius) (SEND self :transform-point (+ x-center radius) 0) (MULTIPLE-VALUE-BIND (x-center y-center) (SEND self :transform-point x-center y-center) (send-DrawCircle (ROUND x-center) (ROUND y-center) (ROUND (- x-radius x-center)) color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) num-points draw-edge self))) ;; else... (prepare-sheet (self) (let* ((delta-angle (quotient two-pi num-points)) (cos-delta (coerce (cos delta-angle) 'short-float)) (sin-delta (coerce (sin delta-angle) 'short-float)) (dx radius) (dy 0.0) (x-start (+ dx x-center)) (y-start (+ dy y-center)) x2 y2) (do ((i 1 (1+ i)) (x1 x-start x2) (y1 y-start y2)) ((>= i num-points) (draw-clipped-solid-triangle x-center y-center x-start y-start x1 y1 self color alu nil draw-edge t texture)) (psetq dx (- (* dx cos-delta) (* dy sin-delta)) dy (+ (* dx sin-delta) (* dy cos-delta))) (setq x2 (+ x-center dx) y2 (+ y-center dy)) (draw-clipped-solid-triangle x-center y-center x2 y2 x1 y1 self color alu nil draw-edge t texture))) ;; draw the center point (SEND self :draw-filled-rectangle x-center y-center 0 0 color alu t texture) )))) ;; may 05/22/89 ;; 1. fixes for spr 9447 (on MAC) - Now mac side does same as explorer and handles end-point clipping. ;; 2. Trapped single-point case since ucode does not handle it. SPR 9693, :draw-cubic-spline bug. ;; 3. added half-thickness var for code clarity. ;; 4. Backed out incorrect fixes to adjust polyline centering. (DEFMETHOD (graphics-mixin :draw-polyline) (x-points y-points &optional (thickness 1) (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (num-points (MIN (LENGTH x-points) (LENGTH y-points))) (alu normal) (draw-end-point t) ;; pc (texture *default-texture*) &aux half-thickness ;; may 05/16/89 (closed ;; pc (AND (> num-points 0) (= (AREF x-points 0) (AREF x-points (1- num-points))) (= (AREF y-points 0) (AREF y-points (1- num-points)))))) "this method draws a polyline with a thickness. this is actually a sequence of lines which are connected together." (UNLESS (NULL color) (MULTIPLE-VALUE-BIND (dx dy) (SEND self :transform-deltas thickness thickness) (IF (AND (>= 1.3 dx) (>= 1.3 dy)) ;; polyline is only 1 pixel thick - even after scaling (prepare-sheet (self) (DO ((i 0 (1+ i)) (n ( 1- num-points)) (line-alu (IF (color-system-p self) alu ;;;else (IF (SEND self :reverse-video-p) (reverse-alu alu) alu))) x1 y1 x2 y2 ) ((>= i num-points)) (SETQ x2 (AREF x-points i) y2 (AREF y-points i)) (MULTIPLE-VALUE-SETQ (x2 y2) (SEND self :transform-point x2 y2)) (UNLESS (NULL x1) (IF (mac-window-p self) (PROGN (send-draw-line (ROUND x1) (ROUND y1) (ROUND x2) (ROUND y2) line-alu draw-end-point self t 1 color) (UNLESS (AND (= i n) draw-end-point) ; Turn off end point. (send-draw-point (ROUND x2) (ROUND y2) w:alu-xor color self))) ;; else... ;; may 05/22/89 Start patch ... ;; filter out case of single point since ucode does NOT handle it correctly ;; fixes :draw-cubic-spline problem of SPR 9693. (let* ((dx (abs (- x1 x2))) (dy (abs (- y1 y2))) (draw-end-point-arg (IF (AND (NOT closed) ;; pc (= i (1- num-points))) draw-end-point nil))) (IF (and (null draw-end-point-arg) (< (+ (abs dx) (abs dy)) 2)) ;; only 1 of 2 points to draw (send self :draw-point x1 y1 line-alu color texture) (draw-clipped-line x1 y1 x2 y2 line-alu draw-end-point-arg ;; may 05/16/89 ... end patch self color texture))))) (SETQ x1 x2 y1 y2)) ) (PROGN (SETQ half-thickness (/ (MAX 0 thickness) 2.0)) ;; ( not part of patch ) (prepare-sheet (self) (DO ((i 1 (1+ i)) (i-1 0 (1+ i-1)) (n ( 1- num-points)) (n-1 (- num-points 2)) (dx) (dy) (x1) (y1) (x2) (y2) (x3) (y3) (px1) (py1) (px2) (py2) (px3) (py3) (px4) (py4)) ((>= i num-points)) (SETQ x1 (AREF x-points i-1) y1 (AREF y-points i-1) x2 (AREF x-points i) y2 (AREF y-points i)) (OR x1 y1 x2 y2 (RETURN ())) (IF (AND (mac-window-p self) (> (ABS (- x1 x2)) 1500)) (CERROR "continue" "cannot draw a ~d pixel thick line from (~d,~d) to (~d,~d) -- too long." thickness ;;(FLOOR (* 2 thickness)) ;; may 04/13/89 x1 y1 x2 y2) ;; else... (COND ((= i 1) (COND (closed (SETQ x3 (AREF x-points n-1) y3 (AREF y-points n-1))) (t (SETQ x3 x1 y3 y1))) (MULTIPLE-VALUE-SETQ (dx dy) (line-deltas x3 y3 x1 y1 x2 y2 half-thickness)) ;; may 04/13/89 (SETQ px1 (- x1 dx) px2 (+ x1 dx)) (SETQ py1 (- y1 dy) py2 (+ y1 dy))) (t (SETQ px1 px3 py1 py3 px2 px4 py2 py4))) (COND ((= i n) (COND (closed (SETQ x3 (AREF x-points 1) y3 (AREF y-points 1))) (t (SETQ x3 x2 y3 y2)))) (t (SETQ x3 (AREF x-points (1+ i)) y3 (AREF y-points (1+ i))))) (OR x3 y3 (RETURN ())) (MULTIPLE-VALUE-SETQ (dx dy) (line-deltas x1 y1 x2 y2 x3 y3 half-thickness)) ;; may 04/13/8 (SETQ px3 (- x2 dx) px4 (+ x2 dx)) (SETQ py3 (- y2 dy) py4 (+ y2 dy)) ;; may 05/22/89 ;; Endpoints are NOT drawn and line widths are wrong by 1 for odd widths. ;; Textures are also not supported. ;;; (IF (mac-window-p self) ;;; (WITH-STACK-LIST (x-coords PX1 PX2 PX4 PX3) ;;; (WITH-STACK-LIST (y-coords PY1 PY2 PY4 PY3) ;;; (send-draw-filled-polygon x-coords y-coords ;;; (IF (SEND self :reverse-video-p) ;;; (reverse-alu alu) alu) color self t))) ;;; ;; else... (IF (AND (NOT draw-end-point) (= i n)) (draw-clipped-solid-triangle px1 py1 px3 py3 px4 py4 self color alu nil nil t texture) (draw-clipped-solid-triangle px1 py1 px3 py3 px4 py4 self color alu nil t t texture)) (IF (AND (NOT closed) (ZEROP i-1)) (draw-clipped-solid-triangle px1 py1 px4 py4 px2 py2 self color alu t t t texture) (draw-clipped-solid-triangle px1 py1 px4 py4 px2 py2 self color alu nil t t texture)))) )))))) ;; The purpose for *adjust-rectangles* and (graphics-mixin :adjust) is ;; to allow a window with w:graphics-mixin to draw simple rectangles and filled rectangles ;; WITHOUT being off by 1 pixel. Using these, many simple drawing jobs can be done without ;; accuracy errors. The problem is with scaling, which does NOT scale the end points as you may expect. ;; Example : (send l :draw-line 100 100 103 100) should draw 4 pixels if scales = 1:1 ;; but when scales = 2:1, the x-coords 100 and 103 get transformed to 200 & 206 which ;; defines 7 pixels not 8 which is expected. If we drew up to but not including the end ;; point and didn't "adjust" for rectangles, then scaling would do the right thing, ;; but we don't and if we did, triangles would not work right. Another problem with scaled ;; rectangles is due to the way a polyline draws "about" a line when the thickness is > 1. ;; Using a polyline for a curve or spline is ok but to draw a rectangle causes the dimensions ;; to be off by a pixel. Drawing a polyline down and to the right of a specified point will correct ;; :draw-rectangle but is probably not the right thing to do for a curve or an arbitrary line. ;; (DEFVAR *adjust-rectangles* t "If t then :draw-filled-rectangle and :draw-rectangle will draw exact widths and heights ( if no scaling in window is present ) else the drawing will be as usual.") ;; may 05/22/89 Added method for :draw-rectangle and :draw-filled-rectangle (DEFMETHOD (graphics-mixin :adjust) () "Returns an adjustment value for some w:graphics-mixin drawing methods. Returns 0 if no adjustments are desired. See *adjust-rectangles* documentation. If NIL, no adjustments are done." (IF (AND *adjust-rectangles* identity?) -1 ;; adjust rectangles 1 smaller ( to be exactly what was requested ) 0 ;; no adjustments are to be done )) (defmethod (graphics-mixin :draw-rectangle) (left top r-width r-height &optional (thickness 1) (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (texture *default-texture*) (adjust (send self :adjust)) ;; may 05/16/89 Added ) "this method draws a hollow rectangle whose lines have a thickness. the sides of the rectangle are always orthogonal to the window edges." ;; may 05/22/89 Start patch to trap very small rectangles (multiple-value-bind (pixel-width-x pixel-width-y) (send self :get-scaling-factors) (let ((scaled-rect-width (* r-width pixel-width-x)) (scaled-rect-height (* r-height pixel-width-y))) (cond ;; may 05/22/89 not part of patch ... ((null color)) ;; may 05/22/89 not part of patch ... ((and (<= scaled-rect-width 1) ;; 0 or 1 pixel when scaled (<= scaled-rect-height 1)) (send self :draw-point left top alu color texture)) ;; We need not try to draw a hollow rectangle if we don't have enough room for the interior ((<= (* scaled-rect-width scaled-rect-height) (* pixel-width-x pixel-width-y)) ;; too small to have an interior (send self :draw-filled-rectangle left top r-width r-height color alu t texture)) (t ;; may 05/22/89 ... end patch (IF (mac-window-p self) (MULTIPLE-VALUE-BIND (right bottom) (SEND self :transform-point (+ left r-width) (+ top r-height)) (MULTIPLE-VALUE-BIND (left top) (SEND self :transform-point left top) ;;KED 3/14/88, Line weight=0 means thickness=1 (LET ((thickness (MAX 1 (ROUND (send self :transform-deltas thickness thickness))))) (send-DrawHollowRectangle (ROUND left) (ROUND top) (ROUND (- right left)) (ROUND (- bottom top)) thickness color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) self)))) ;;; else... (let* ((right (+ left r-width adjust)) ;; may 05/16/89 (bottom (+ top r-height adjust)) ;; may 05/16/89 (x (make-array 5)) (y (make-array 5))) (setf (aref x 0) left) (setf (aref y 0) top) (setf (aref x 1) right) (setf (aref y 1) top) (setf (aref x 2) right) (setf (aref y 2) bottom) (setf (aref x 3) left) (setf (aref y 3) bottom) (setf (aref x 4) left) (setf (aref y 4) top) (send self :draw-polyline x y thickness color 5 alu t texture )))) )))) ;; may 05/22/89 Backed out change of patch-4-121 (defmethod (graphics-mixin :draw-filled-polygon) (x-center y-center x-points y-points &optional (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (num-points (length x-points)) (alu normal) (texture *default-texture*)) "this method draws a solid, filled in convex polygon. this is a polygon which has no inward pointing vertices and which is solid from the center point to the edges between the vertices." (unless (null color) (prepare-sheet (self) (do ((i 1 (1+ i)) (x1) (y1) (x2) (y2)) ((>= i num-points)) (cond ((= i 1) (setq x1 (aref x-points 0) y1 (aref y-points 0)) (or x1 y1 (return ()))) (t (setq x1 x2 y1 y2))) (setq x2 (aref x-points i) y2 (aref y-points i)) (or x2 y2 (return ())) ;;; added texture argument (draw-clipped-solid-triangle x1 y1 x2 y2 x-center y-center self color alu () t t texture))))) (defmethod (graphics-mixin :draw-filled-rectangle) (left top r-width r-height &optional (color (if (color-system-p self) (tv:sheet-foreground-color self) black)) (alu normal) (draw-edge t) (texture *default-texture*) (adjust (send self :adjust)) ;; may 05/17/89 ) "this method draws a solid, filled in rectangle. the sides of the rectangle are always orthogonal to the coordinate axes." ;; may 05/22/89 Start patch to trap single pixel case (multiple-value-bind (pixel-width-x pixel-width-y) (send self :get-scaling-factors) (cond ((null color)) ;; may 05/22/89 not part of patch ... ((and (<= (* r-width pixel-width-x) 1) (<= (* r-height pixel-width-y) 1)) ;; 0 or 1 pixel when scaled (send self :draw-point left top alu color texture)) (t ;; may 05/22/89 ... end patch (IF (mac-window-p self) (MULTIPLE-VALUE-BIND (right bottom) (SEND self :transform-point (+ left r-width) (+ top r-height)) (MULTIPLE-VALUE-BIND (left top) (SEND self :transform-point left top) (send-draw-rectangle (ROUND (- right left)) (ROUND (- bottom top)) (ROUND left) (ROUND top) color (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) self t))) ;; else... (let ((bottom (+ top r-height adjust)) ;; may 05/22/89 (right (+ left r-width adjust))) ;; may 05/22/89 (prepare-sheet (self) (draw-clipped-solid-triangle left top left bottom right bottom self color alu () draw-edge draw-edge texture) (draw-clipped-solid-triangle left top right top right bottom self color alu t draw-edge draw-edge texture)) )))))) ;; may 05/22/89 Added TEXTURE arg - straight out of window manual p. 19-19. (defmethod (graphics-mixin :draw-point) (x y &optional (alu char-aluf) (value (IF (color-system-p self) (tv:sheet-foreground-color self) -1 )) (texture *default-texture*)) ;; may 05/09/89 "this method draws a pixel at the window location that corresponds to the world coordinates specified by x and y. The new value is combined with the existing value, based on the alu. The monochrome default -1 is a pixel with its bits set to 1. The color default is the window's foreground color. If the texture arg is nil then VALUE is used else the VALUE is used only if the texture array value is 1. If the texture array value is 0, then the background color ( 0 for monochrome ) is used instead of value." (declare (special 100%-black)) ;; may 05/22/89 (UNLESS (NULL value) ;; do not error off if nil for value (color); do like other primitives 12/1/87 KJF (multiple-value-setq (x y) (send self :transform-point x y)) (IF (mac-window-p self) (send-draw-point x y (IF (SEND self :reverse-video-p) (reverse-alu alu) alu) value self) ;; else... (or (< x (sheet-inside-left)) (>= x (sheet-inside-right)) (< y (sheet-inside-top)) (>= y (sheet-inside-bottom)) (prepare-sheet (self) (LET* ((current (AREF screen-array y x)) (color-map (tv:sheet-color-map self)) (background (tv:sheet-background-color self))) ;; may 05/22/89 Start patch to add texture argument (cond ((null texture) (setq texture 100%-black)) ((arrayp texture)) ;; ok (t (ferror nil "Texture ~s is not an array"))) (if (color-sheet-p self) ;; for every 1 in texture - use VALUE. For every 0 in texture use background (if (zerop (aref texture (mod y (array-dimension texture 0)) (mod x (array-dimension texture 1)))) (setq value background-color)) ;; foreground-color is defaulted arg in arglist ;; in monochrome system, texture is used and color is ignored (setq value (aref texture (mod y (array-dimension texture 0)) (mod x (array-dimension texture 1))))) ;; may 05/22/89 end patch ;; note - new alus are added for color. Since these alus are not understood ;; by the boole function, they must be separated out and handled properly. (SETF (AREF screen-array y x) (COND ((= alu tv:alu-back) background) ((= alu tv:alu-transp) value) ((= alu tv:alu-add) (MOD (+ value current) 256)) ((= alu tv:alu-sub) (MOD (- current value) 256)) ((= alu tv:alu-max) (MAX value current)) ((= alu tv:alu-min) (MIN value current)) ((= alu tv:alu-avg) (TRUNCATE (+ value current) 2)) ((= alu tv:alu-adds) (MIN (+ value current) (tv:color-map-saturate color-map))) ((= alu tv:alu-subc) (MAX (- current value) (tv:color-map-clamp color-map))) (t (BOOLE alu value current)) )) )))))) )) #!C ; From file PRIMITIVES.LISP#> WINDOW; SYS: #10R W#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "W")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: WINDOW; PRIMITIVES.#" (defun draw-clipped-solid-triangle (x1 y1 x2 y2 x3 y3 window &optional (color (tv:sheet-foreground-color window)) (alu normal) (draw-third-edge t) (draw-second-edge t) (draw-first-edge t) (color-array *default-texture*) ) "This function draws a colored, filled in, triangle. The triangle vertices are converted from world to screen coordinates." ;; ;; Convert endpoints from world to screen coordinates if the window handles transformation. ;; (cond ((send window :operation-handled-p :transform-point) (multiple-value-setq (x1 y1) (send window :transform-point x1 y1)) (multiple-value-setq (x2 y2) (send window :transform-point x2 y2)) (multiple-value-setq (x3 y3) (send window :transform-point x3 y3))) (t (setq x1 (g-round x1) y1 (g-round y1) x2 (g-round x2) y2 (g-round y2) x3 (g-round x3) y3 (g-round y3)))) ;; ;; Make sure that the specified color is in the range of available colors. ;; (IF (color-system-p window) (setq color (range-check color)) ;;; >>> changed to range-check ;;; else (progn (setq color (rem color (array-active-length b&w-table))) ; sure color is in range for gray shades JEB (unless color-array (SETQ color-array (AREF b&w-table color))) ) ) ; if color-system (WHEN (AND (send window :reverse-video-p) (NULL (color-system-p window))) (setq alu (reverse-alu alu)) ) (let* ((array (sheet-screen-array window)) (bottom (sheet-inside-bottom window)) (left (sheet-inside-left window)) (right (sheet-inside-right window)) (top (sheet-inside-top window))) ;; ;; If the triangle is gigantic and covers the whole window, then don't bother drawing it. Instead we just fill ;; the entire window with the appropriate color. ;; (prepare-color-register (window color) (cond ((and (< (min x1 x2 x3) -5000) (> (max x1 x2 x3) 5000) (< (min y1 y2 y3) -5000) (> (max y1 y2 y3) 5000)) ;;;; <<< here is the fix - if color-array is nil we want to blt 100%-black >>>> (bitblt alu (- right left) (- bottom top) (OR color-array 100%-black) 0 0 array left top)) ;; ;; Now draw the triangle but limit the coordinates to reasonable values to keep the drawing speed in ;; the acceptable range. ;; (t (setq x1 (min (max x1 -5000) 5000) y1 (min (max y1 -5000) 5000) x2 (min (max x2 -5000) 5000) y2 (min (max y2 -5000) 5000) x3 (min (max x3 -5000) 5000) y3 (min (max y3 -5000) 5000)) (tv:with-clipping-rectangle (left top right bottom) ;; sys:%draw-shaded-triangle ALWAYS returns t since ucode began to handle lines! may 8-30-88 ;; the UNLESS body is no longer necessary. (unless (OR (sys:%draw-shaded-triangle x1 y1 x2 y2 x3 y3 alu draw-first-edge draw-second-edge draw-third-edge color-array window) (not draw-third-edge)) (if (and (= x1 x2) (= y1 y2) (neq x1 x3) (neq y1 y3)) ;; p1 = p2  p3 (draw-clipped-line x1 y1 x3 y3 alu t window color color-array) (if (and (neq x1 x2) (neq y1 y2)) ;; p1  p2 (draw-clipped-line x1 y1 x2 y2 alu t window color color-array))) ))))))) ))