;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*- ;;; Written 06/16/89 13:57:52 by MARKY, ;;; Reason: Changed :draw-polyline to handle endpoint args. ;;; while running on MX5 from band NB22 ;;; With SYSTEM 5.19, GC 5.3, VIRTUAL-MEMORY 5.5, MICRONET 5.5, MICRONET-COMM 5.13, ;;; DISK-IO 5.9, BASIC-PATHNAME 5.2, MAC-PATHNAME 5.0, NETWORK-SUPPORT-COLD 5.1, ;;; BASIC-NAMESPACE 5.6, BASIC-FILE 5.3, RPC 5.4, NFS 5.10, EH 5.3, MAKE-SYSTEM 5.2, ;;; MEMORY-AUX 5.1, MACTOOLBOX 1.25, COMPILER 5.1, TV 5.21, NVRAM 5.1, UCL 5.0, INPUT-EDITOR 5.0, ;;; METER 5.0, ZWEI 5.9, DEBUG-TOOLS 5.1, WINDOW-MX 5.28, PRINTER 5.11, MAC-PRINTER-TYPES 5.4, ;;; NETWORK-PATHNAME 5.0, NETWORK-NAMESPACE 5.0, DATALINK 5.7, CHAOSNET 5.6, NETWORK-SUPPORT 5.0, ;;; NETWORK-SERVICE 5.0, DATALINK-DISPLAYS 5.0, NAMESPACE-EDITOR 5.1, IP 3.33, NFS-SERVER 5.3, ;;; PRINTER-TYPES 5.2, IMAGEN 5.1, MAIL-DAEMON 5.1, MAIL-READER 5.3, TELNET 5.1, ;;; VT100 5.0, STREAMER-TAPE 5.6, DECNET 1.45, VISIDOC 5.4, PROFILE 5.1, DISK-LABEL 5.1, ;;; Experimental BUG 11.9, microcode 128, Band Name: microExplorer Network (11/22) ;;; SPR 9447 #!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-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 06/16/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)))) )))))) ))