;;; -*- Mode: Common-Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Written 05/25/89 18:03:59 by MARKY,
;;; Reason: Corrected color to gray-scale mapping in :draw-point
;;; method of w:graphic-mixin.
;;; while running on LIBRA from band LODA
;;; With SYSTEM 6.2, VIRTUAL-MEMORY 6.0, EH 6.0, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.0, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.0, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.0, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.1, TV 6.5, DATALINK 6.0, CHAOSNET 6.0, GC 6.0, MEMORY-AUX 6.0, NVRAM 6.0,
;;;  SYSLOG 6.0, STREAMER-TAPE 6.0, UCL 6.0, INPUT-EDITOR 6.0, METER 6.0, ZWEI 6.0,
;;;  DEBUG-TOOLS 6.0, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.0, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.0, SERIAL 6.0, PRINTER 6.0, MAC-PRINTER-TYPES 6.0, PRINTER-TYPES 6.0,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.0, TI-CLOS 6.2, CLEH 6.0, IP 3.45,
;;;  Experimental BUG 11.5, CLX 6.0, CLUE 6.0, X11M 6.0,  microcode 429, Band Name: Release 6.0 + SLE 5/22 

#!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.#"



;; may 05/25/89 Corrected color to gray-scale mapping.
;; 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)
	    (color (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.
In a monochrome window the COLOR is mapped to a gray scale in TEXTURE
and TEXTURE defaults to w:b&w-table.
In a color window COLOR is used and TEXTURE defaults to w:100%-black.
If the TEXTURE array is 1-bit then color expansion is performed which 
converts a 0 array value to the sheet's background color and
converts a 1 array value to the sheet's foreground color.
The COLOR arg is ignored when using an 8-bit texture which is
just treated as a source of colors."
  
  (UNLESS (NULL color) ;; do not error off if nil for 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) color 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 taken from w:draw-clipped-solid-triangle
		(cond ((color-sheet-p self)
		       (SETQ color (range-check color))
		       (UNLESS texture (SETQ texture 100%-black))) ;; ucode si:%draw-shaded-triangle does similiar thing
		      (t
		       (SETQ color (mod color (ARRAY-ACTIVE-LENGTH b&w-table)))	   ; use MOD not REM to handle negative numbers
		       (UNLESS texture (SETQ texture (AREF b&w-table color)))))		      
		(LET ((ary-value (aref texture
				       (mod y (array-dimension texture 0))
				       (mod x (array-dimension texture 1)))))
		  (if (color-sheet-p self)
		      (if (TYPEP texture '(array bit))
			  ;; for every 1 in texture - use COLOR. For every 0 in texture use background
			  ;; - this is color expansion
			  (if (zerop ary-value)
			      (setq color background-color)
			      ;; else color is already foreground-color from defaulted arg in arglist
			      )
			  ;; else is array is 8-bit just use the color in the texture array
			  (SETQ color ary-value))
		      ;; In monochrome system, color is mapped to a gray-scale using b&w-table
		      (setq color ary-value)
		      ))
		;; 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.
		;; a little cosmetic fix up here.  PMH 4/6/88
		(SETF (AREF screen-array y x)
		      (COND
			((= alu tv:alu-back)   background)
			((= alu tv:alu-transp) color)
			((= alu tv:alu-add)    (MOD (+ color current) 256))
			((= alu tv:alu-sub)    (MOD (- current color) 256))
			((= alu tv:alu-max)    (MAX color current))
			((= alu tv:alu-min)    (MIN color current))
			((= alu tv:alu-avg)    (TRUNCATE (+ color current) 2))
			((= alu tv:alu-adds)   (MIN (+ color current) (tv:color-map-saturate color-map)))
			((= alu tv:alu-subc)   (MAX (- current color) (tv:color-map-clamp color-map)))
			(t                     (BOOLE alu color current))
			))
		))))))

))