;;; wheel.sc -- a beautiful color wheel that rotates slowly
;;;             "for better effect" ;-) Hakan Huss, KTH and Johan Ihren, KTH

;;; $Header: /nfs/deneb/src0/johani/scix-0.95/demo/RCS/wheel.sc,v 1.3 90/03/20 23:37:09 johani Exp $

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

;;; pix-container -- used to implement a circular structure of pixel values.
;;;                  NB: This version doesn't actually use a circular list,
;;;                      it uses a vector and modulo-operations for efficiency.
;;;                  Usage: First fill the list using 'add-pixel!, then
;;;                         circularize the list by 'make-circular!. Pixels
;;;                         can now be accessed by using 'pixel-ref with
;;;                         argument n. 'rotate! is used to rotate the list,
;;;                         so that pixel-ref returns a different pixel.
(define-lw-class (pix-container)
  (locals (pixels '()) (len 0) (start 0))
  (methods
   (add-pixel! (lambda (pix)
		 (set! pixels (append pixels (list pix))) ))
   (make-circular! (lambda ()
		     (set! pixels (list->vector pixels))
		     (set! len (vector-length pixels)) ))
   (pixel-ref (lambda (n)
		(vector-ref pixels (modulo (+ n start) len)) ))
   (rotate! (lambda () (set! start (modulo (+ start 1) len)))) ))

;;; my-color -- a sub-class to color and pix-container, used to reference
;;;             pixels from a list contained in the latter.
(define-class (my-color n pix-list color)
  (inherit pix-list color)
  (methods
   (pixel (lambda () (me 'pixel-ref n))) )
  (init
   (me 'add-pixel! (me '(color pixel))) ))

(define (demo-wheel size scr)
  (let* ((cmap (scr 'default-colormap))
	 (w    (make-window size size (scr 'root-depth) 0 0 (scr 'root)
			    0 'CopyFromParent 'CopyFromParent scr))
	 (gc (make-gc (make-gc-value-mask `(foreground ,(scr 'whitepixel)))
		      (scr 'root)))
	 (colors '())
	 (radius (inexact->exact (round (/ size 2))))
	 (terminate? #f)
	 (the-pixels (make-pix-container)) )

    (format #t "Allocating colors... ") (flush-buffer)
    (set! colors (allocate-all-colors cmap the-pixels))
    (if (> (length colors) 2)		; It is POSSIBLE to get by with 3.
	(begin
	  (format #t "done.") (flush-buffer)
	  (format #t " Using ~a colors.~%" (length colors))
	  (flush-buffer)
	  (w 'createwindow (make-window-value-mask
			    `(background-pixel ,(scr 'blackpixel))
			    `(event-mask ,(make-event-mask 'ButtonPress)) ))
	  
	  (w 'add-callback!
	     'ButtonPress
	     (lambda (event window)
	       (cmap 'freecolors (map (lambda (color)
					(color 'pixel))
				      colors)
		     0)
	       (gc 'freegc)
	       (w 'destroywindow)
	       (scr 'flush!)
	       (set! terminate? #t) ))

	  (w 'changeproperty 'replace 'wm_name 'string 8 "SCIX Color Wheel")
	  (w 'mapwindow)
	  (scr 'flush!)
	  (the-pixels 'make-circular!)
	  (format #t "Loading colors... ") (flush-buffer)
	  (load-hls-wheel colors cmap)
	  (format #t "done.~%") (flush-buffer)
	  (format #t "Drawing the wheel... ") (flush-buffer)
	  (draw-wheel w gc colors radius)
	  (scr 'flush!)
	  (format #t "done.~%") (flush-buffer)
	  
	  (msg-handler 'mainloop
		       #f
		       (list scr)
		       (lambda (handle-events)
			 (let loop ()
			   (the-pixels 'rotate!)
			   (cmap 'storecolors colors)
			   (scr 'flush!)
			   (handle-events)
			   (if (not terminate?)
			       (loop) )))))
	(begin
	  (format #t "Could not allocate enough colors.~%")
	  #f))))

;;; allocate-all-colors -- returns a list with as many color objects as it was
;;;                        possible to allocate r/w. We start by grabbing them
;;;                        15 at a time, but the last ones are allocated one at
;;;                        a time. Note that the allocated colors will only
;;;                        have the pixel-values set correctly, the rgb values
;;;                        will be undefined.
(define (allocate-all-colors cmap pixels)
  (define (create-colors reply)
    (if (pair? reply)
	(map (lambda (pixel)
	       (let ((c (make-color 0 0 0)))
		 (c 'set-pixel! pixel)
		 (c 'set-colormap! cmap)
		 c))
	     (caddr reply) )
	reply))

  (let ((colors '()))
    (let loop ((colors-at-a-time 15)
	       (c (create-colors (cmap 'alloccolorcells #f 15 0))) )
      (if (pair? c)			; A list of new color objects
	  (begin
	    (set! colors
		  (append colors
			  (let iloop ((n (length colors))
				      (col-list c)
				      (result '()))
			    (if (null? col-list)
				result
				(iloop
				 (+ n 1)
				 (cdr col-list)
				 (append result
					 (list
					  (make-my-color
					   n
					   pixels
					   (car col-list) ))))))))
	    (loop colors-at-a-time
		  (create-colors
		   (cmap 'alloccolorcells #f colors-at-a-time 0) )))
	  (if (not (= 1 colors-at-a-time))              ; Try to get a few more
	      (loop 1 (create-colors (cmap 'alloccolorcells #f 1 0)) ))))
    colors))
    
;;; load-hls-wheel -- loads a HLS wheel into the color objects.
;;;
;;; Note: As I am not really into the definitions of the HLS system I just
;;;       borrowed these algorithms from another program.
(define (load-hls-wheel colors cmap)
  (let ((denom (+ (length colors) 1)) (rgb #f))
    (let loop ((i 0) (color (car colors)) (colors (cdr colors)))
      (set! rgb (hls->rgb (list (/ (* i 360) denom)
				0.5
				0.5)))
      (color 'set-red! (* 65535 (car rgb)))
      (color 'set-green! (* 65535 (cadr rgb)))
      (color 'set-blue! (* 65535 (caddr rgb)))
      (if (pair? colors)
	  (loop (+ i 1) (car colors) (cdr colors))
	  (cmap 'storecolors colors) ))))

;;; hls->rgb -- returns a RGB triplet from the input HLS ditto.
(define (hls->rgb hls)
  (let ((h (car hls)) (l (cadr hls)) (s (caddr hls)))
    (let* ((m2 (if (< l 0.5)
		   (* l (+ 1 s))
		   (- (+ l s) (* l s)) ))
	   (m1 (- (* 2 l) m2)) )

      (define (hls-value n1 n2 hue)
	(let ((hue (if (< hue 0)
		       (+ hue 360)
		       (if (> hue 360)
			   (- hue 360)
			   hue))))
	  (cond ((< hue 60)
		 (+ n1 (/ (* (- n2 n1) hue) 60)) )
		((< hue 180)
		 n2)
		((< hue 240)
		 (+ n1 (/ (* (- n2 n1) (- 240 hue)) 60)) )
		(else n1) )))

      (list (hls-value m1 m2 (+ h 120))
	    (hls-value m1 m2 h)
	    (hls-value m1 m2 (- h 120)) ))))

;;; draw-wheel -- draw a wheel made up of as many triangles as there are colors
;;;               available and fill each triangle with one color. It is 
;;;               possible to write this without using set!, but will be
;;;               harder to read then.
(define (draw-wheel w gc colors radius)
  ;;(format #t "draw-wheel~%") (flush-buffer)
  (let ((tri #f) (dphi (/ (* (/ 360 (length colors)) 3.141592) 180))
		 (center (list radius radius)) (pt1 #f) (pt2 #f) )
    (let loop ((phi 0) (colors colors))
      (if (not (null? colors))
	  (begin
	    (set! pt1 (list (float->fixed (+ radius (* radius (cos phi))))
			    (float->fixed (+ radius
					     (* radius (sin phi)))) ))
	    (set! pt2 (list (float->fixed
			     (+ radius (* radius (cos (+ phi dphi)))) )
			    (float->fixed
			     (+ radius (* radius (sin (+ phi dphi)))) )))
	    (set! tri (make-fillpoly 'convex 'origin `(,center ,pt1 ,pt2)))
	    (draw-with-color w gc (list tri) (car colors))
	    (loop (+ phi dphi) (cdr colors)) )))))

;;; draw-with-color -- changes the foreground-color of gc to color before
;;;                    drawing the graphic objects in graphic-l
(define (draw-with-color w gc graphic-l color)
  ((gc 'mask) 'set! `(foreground ,color))
  (gc 'changegc (gc 'mask))
  (w 'draw graphic-l gc) )