;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; SCIX colormap object.

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/cmap-object.sc,v 1.5 90/04/01 13:49:50 johani Exp $

(module colormap (top-level make-colormap))

(include "../include/requests.sch")
(include "../include/masks.sch")
(include "../include/util.sch")
(include "../include/lw-objects.sch")

(include "../macros/extend-syntax.sc")
(include "../macros/define-class.sc")

(define-external x-reply? msghandler)

(eval-when (compile eval load)
  (define-class (colormap scr &optional id)
    (locals
     (write-enabled '())       ; List of write-enabled pixels
     (cached-visual #f)        ; When a Colormap is created this should
                               ; be set to the corresponding visual object.
     (cache! (lambda (pixel)
	       (letrec ((cache! (lambda (pixel l)
				  (if (or (null? l)
					  (< pixel (car l)))
				      (begin
					(set! l (cons pixel l))
					l)
				      (if (> pixel (car l))
					  (begin
					    (set-cdr! l (cache! pixel (cdr l)))
					    l)
					  l)))))
		 (set! write-enabled
		       (cache! pixel write-enabled)))))
     (create-masks (lambda (mask)
		     (let loop ((val 1) (mask mask) (acc '(0)))
		       (if (zero? mask)
			   acc
			   (loop (* 2 val) (quotient mask 2)
				 (if (odd? mask)
				     (append acc (map (lambda (v)
							(+ val v)) acc))
				     acc))))))
     (create-pixels (lambda (pixels mask)
		      (let ((masks (create-masks mask)))
			(flatmap (lambda (pixel)
				   (map (lambda (m) (+ pixel m)) masks))
				 pixels))))
     (multi-cache! (lambda (pixels mask)
		     (let ((cp (create-pixels pixels mask)))
		       (for-each cache! cp)
		       cp)))
     
     (multi-remove! (lambda (pixels mask)
		      (let ((rem-pixels
			     (create-pixels pixels mask)))
			(let loop ((l write-enabled)
				   (p rem-pixels))
			  (if (null? p)
			      (begin
				(set! write-enabled l)
				rem-pixels)
			      (loop
			       (remv (car p) l)
			       (cdr p)))))))
     )
    (inherit (resource scr (if (null? id)	; if we are top-level
			       #f		; then the resource isn't
			       (car id))))      ; otherwise it is
    (methods
     (screen (lambda () scr))
     (visual (lambda () cached-visual))
     (write-enabled (lambda () write-enabled))
     (set-visual! (lambda (v) (set! cached-visual v)))
     (clear-write-enabled! (lambda () (set! write-enabled '())))
     
     (createcolormap (lambda (alloc visual . rest)   ; #78: CreateColormap
		       (set! cached-visual visual)
		       (set! write-enabled '())
		       (send-createcolormap alloc me visual scr rest) ))
     (freecolormap (lambda rest                      ; #79: FreeColormap
		     (set! cached-visual #f)
		     (set! write-enabled '())
		     (me 'scix-denounce-id!)
		     (send-freecolormap me scr rest) ))
     (copycolormapandfree (lambda (old-cmap . rest)  ; #80: CopyColormapAndFree
			    (set! cached-visual (old-cmap 'visual))
			    (set! write-enabled
				  (old-cmap 'write-enabled))
			    (old-cmap 'clear-write-enabled!)
			    (send-copycolormapandfree me old-cmap scr rest)) )
     (installcolormap (lambda rest                   ; #81: InstallColormap
			(send-installcolormap me scr rest) ))
     (uninstallcolormap (lambda rest                 ; #82: UninstallColormap
			  (send-uninstallcolormap me scr rest) ))

     ;; Allocation
     (alloccolor (lambda (r g b . rest)		     ; #84: AllocColor
		   (let* ((reply (send-alloccolor me r g b scr rest))
			  (pixel (reply 'pixel)))
		     (if (x-reply? reply)
			 (let ((c (make-color r g b)))
			   (c 'set-visual-red! (reply 'red))
			   (c 'set-visual-green! (reply 'green))
			   (c 'set-visual-blue! (reply 'blue))
			   (c 'set-pixel! pixel)
			   (c 'set-colormap! me)
			   c)
			 #f)) ))
     (allocnamedcolor (lambda (name . rest)    	     ; #85: AllocNamedColor
			(let ((r (send-allocnamedcolor me name scr rest)))
			  (if (x-reply? r)
			      (let ((c (make-color (r 'exact-red)
						   (r 'exact-green)
						   (r 'exact-blue)))
				    (pixel (r 'pixel)))
				(c 'set-visual-red! (r 'visual-red))
				(c 'set-visual-green! (r 'visual-green))
				(c 'set-visual-blue! (r 'visual-blue))
				(c 'set-name! name)
				(c 'set-pixel! pixel)
				(c 'set-colormap! me)
				c)
			      #f)) ))     

     ;; #86: AllocColorCells -- returns a list (PIXELS MASKS ALL-PIXELS)
     ;; where PIXELS are the returned pixels MASKS are the returned masks
     ;; and ALL-PIXELS are all allocated PIXELS. The write enable cache is
     ;; also updated. 
     (alloccolorcells (lambda (cont ncolors nplanes . rest)
			(let ((reply (send-alloccolorcells cont me ncolors
							   nplanes scr rest)))
			  (if (x-reply? reply)
			      (let ((pixels (reply 'pixels))
				    (masks (reply 'masks)))
				(list pixels masks
				      (multi-cache! pixels (apply + masks))))
			      reply)) ))
     
     ;; #87: AllocColorPlanes -- returns a list (PIXELS MASKS ALL-PIXELS)
     ;; where PIXELS are the returned pixels and MASKS a list of the returned
     ;; three masks (R, G, B) and ALL-PIXELS are all allocated PIXELS.
     ;; The write enable cache is also updated.
     (alloccolorplanes (lambda (cont ncolors reds greens blues . rest)
			 (let ((reply (send-alloccolorplanes cont me ncolors
							     reds greens
							     blues scr rest)))
			   (if (x-reply? reply)
			       (let ((pixels (reply 'pixels))
				     (red-mask (reply 'red-mask))
				     (green-mask (reply 'green-mask))
				     (blue-mask (reply 'blue-mask)))
				 (list pixels (list red-mask green-mask
						    blue-mask)
				       (multi-cache!
					pixels (+ red-mask green-mask 
						  blue-mask)) ))
			       reply)) ))
     
     (freecolors (lambda (pixels plane-mask . rest)      ; #88: FreeColors
		   (multi-remove! pixels plane-mask)
		   (send-freecolors me plane-mask pixels scr rest) ))
     
     ;; StoreColors -- colors are color objects. Return value is unspecified
     ;; Obs! Filtered by the cache.
     (storecolors (lambda (colors . rest)                ; #89: StoreColors
		    (send-storecolors me (filter
					  (lambda (c)
					    (memv (c 'pixel)
						  write-enabled))
					  colors) scr rest) ))
     
     ;; StoreNamedColor -- the supplied color is used to get the pixel and
     ;;                    do-mask. The rgb-values are not returned to the
     ;;                    color object, however. It is necessary to do a
     ;;                    QueryColors for that. The pixel must be in the
     ;;                    cache.
     (storenamedcolor (lambda (color name . rest) ; #90: StoreNamedColor
			(if (memv (color 'pixel) write-enabled)
			    (begin
			      (color 'set-name! name)
			      (send-storenamedcolor me color name scr rest)))))
     
     ;; QueryColors -- inserts the rgb-values supplied by the server into the
     ;;                color objects.
     (querycolors (lambda (colors . rest)               ; #91: QueryColors
		    (let ((reply (send-querycolors me colors scr rest)))
		      (if (x-reply? reply)
			  (begin
			    (for-each (lambda (c rgb-l)
					(c 'set-visual-red! (car rgb-l))
					(c 'set-visual-green! (cadr rgb-l))
					(c 'set-visual-blue! (caddr rgb-l)) )
				      colors
				      (reply 'colors) )
			    colors)
			  reply)) )) )
    
    ;; The init routine
    (init (if (or (null? id)		; i e top-level 
		  (number? (car id)) )	; i e id given by server
	      (me 'scix-announce-id! me) ))
    )
  ) ;; End of eval-when