; Simple color editor that only requires one extra color (useful for
; wimpy little PeeCee based systems, like mine, with only 16 colors)
;
; Author: Larry Campbell (campbell@redsox.bsw.com)
;
(require (in-vicinity (library-vicinity) "x11.scm"))
(require (in-vicinity (library-vicinity) "xt.scm"))
(require (in-vicinity (library-vicinity) "xm.scm"))
(require (in-vicinity (library-vicinity) "xmsubs.scm"))
(require (in-vicinity (library-vicinity) "xevent.scm"))

(require 'format)

(define top-level
  (if (defined? vs:top-level)
      (xt:app-create-shell "xcolorfrob" "XColorfrob"
			   xt:application-shell
			   (xt:display vs:top-level))
      (xt:initialize "xcolorfrob" "XColorfrob")))

(define xdisplay (xt:display top-level))
(define cmap (x:default-colormap xdisplay 0))
(define planes-n-colors (x:alloc-color-cells xdisplay cmap #f 0 1))

(if (not planes-n-colors)
    (error "failed to allocate required color cell"))

(define pixel (caadr planes-n-colors))
(x:store-color xdisplay cmap pixel 0 0 0)

(define panel (xt:create-managed-widget "panel" xm:row-column top-level))

(define button-panel
  (xt:create-managed-widget "button-panel" xm:row-column panel))

(define color-panel
  (xt:create-managed-widget "color-panel" xm:row-column panel))

(define (frob w)
  (x:store-color xdisplay cmap pixel (red 'get) (green 'get) (blue 'get)))

(define (make-color name parent)
  (let* ((widget
	  (xt:create-managed-widget
	   name xm:scale parent
	   xm:n-orientation xm:horizontal
	   xm:n-minimum 0
	   xm:n-maximum 65535
	   xm:n-value 0
	   xm:n-decimal-points 0
	   xm:n-show-value #t
	   xm:n-scale-width 150
	   xm:n-title-string (xm:string-create name))))
    (xt:add-callback
     widget xm:n-drag-callback frob)
    (lambda (selector . args)		; args not (yet) used
      (case selector
	((get) (xt:get-value widget xm:n-value xt:integer))
	((set) (xt:set-values widget xm:n-value (car args)))
	(else (error "invalid origin method" selector))))))

(define (pixel-truncate p)
  (inexact->exact (truncate (* 4 (/ p 1024)))))

(define (emit port)
  (let ((r (pixel-truncate (red 'get)))
	(g (pixel-truncate (green 'get)))
	(b (pixel-truncate (blue 'get))))
    (format port "#~2,48X~2,48X~2,48X" r g b)))

(make-button "Set root" button-panel
	     (lambda (w)
	       (system (format #f "xsetroot -solid \"~A\"" (emit #f))))
	     '()
	     xm:n-alignment xm:alignment-center)

(make-button "Emit" button-panel
	     (lambda (w)
	       (emit #t)
	       (newline))
	     '()
	     xm:n-alignment xm:alignment-center)

(make-button "Quit" button-panel
	     (lambda (w)
	       (emit #t)
	       (newline)
	       (quit))
	     '()
	     xm:n-alignment xm:alignment-center)

(define red   (make-color "red"   color-panel))
(define green (make-color "green" color-panel))
(define blue  (make-color "blue"  color-panel))

(define box
  (xt:create-managed-widget "box" xm:drawing-area color-panel
			    xm:n-height 60))

(xt:add-event-handler
 box x:exposure-mask 0
 (lambda (widget e)
   (let ((x (x:get-event-field e x:expose-event:x))
	 (y (x:get-event-field e x:expose-event:y))
	 (w (x:get-event-field e x:expose-event:width))
	 (h (x:get-event-field e x:expose-event:height)))
     (x:fill-rectangle xdisplay (xt:window widget)
		       xgc x y w h))))

(define xgc
  (x:create-gc xdisplay '() x:gc-background pixel x:gc-foreground pixel))

(xt:realize-widget top-level)
(x:clear-area xdisplay (xt:window box) 0 0 0 0 #t)

(if (not (defined? vs:top-level))
    (xt:main-loop))

