pkg://xscm-2.01.tar.gz:106160/xscm-2.01/examples/xcolormap.scm  downloads

;;; $Id: xcolormap.scm,v 1.2 1995/07/29 04:09:13 skimu Exp $
;;; * Author: C version.
;;;	John L. Cwikla
;;; 	cwikla@uimrl7.mrl.uiuc.edu
;;; * Translated into xscm by Shigenobu Kimura.

(require 'x11)
(require 'xt)
(require 'xaw)

(define app-name "XColormap")

(define width  10)
(define height 10)
(define margin 2)

(define x:clear-window
  (lambda (d w)
    (x:clear-area d w 0 0 0 0 #f)))

(define draw-square
  (lambda (d i)
    (let ((row (quotient i x-color))
	  (col (modulo i x-color)))
      (let ((x (+ margin (* col (+ width margin))))
	    (y (+ margin (* row (+ height margin)))))
	(x:set-foreground the-display the-gc i)
	(x:fill-rectangle the-display d the-gc x y width height)))))

(define redraw-window
  (lambda (d)
    (do ((i 0 (+ i 1)))
	((>= i num-colors))
      (draw-square d i))))

(define redraw
  (lambda (w e)
    (redraw-window (xt:window w))))

(define resize
  (lambda (wid e)
    (let ((w (xt:get-value wid xt:n-width xt:short))
	  (h (xt:get-value wid xt:n-height xt:short)))
      (set! width  (- (quotient (- w margin) x-color) margin))
      (set! height (- (quotient (- h margin) x-color) margin))
      (x:clear-window the-display (xt:window wid))
      (redraw wid e))))

(define quit-it
  (lambda (w e)
    (display "Have a nice day.")
    (newline)
    (quit)))

(define colorwidget  (xt:app-initialize "XScmTest" app-name))
(define the-display  (xt:display colorwidget))
(define the-screen-no 0)
(define num-colors   (x:display-cells the-display the-screen-no))
(define x-color      (inexact->exact (sqrt num-colors)))
(define y-color      (quotient num-colors x-color))

(define top-level
  (xt:create-managed-widget "TopLevel" xt:core colorwidget
		  xt:n-width  (+ margin (* x-color (+ width margin)))
		  xt:n-height (+ margin (* y-color (+ height margin)))))
(xt:realize-widget colorwidget)
(xt:add-event-handler top-level x:button-press-mask 0  quit-it)
(xt:add-event-handler top-level x:exposure-mask     0  redraw)
(xt:add-event-handler top-level x:structure-notify-mask   0  resize)
(define the-gc (x:create-gc the-display (xt:window top-level)
			    x:gc-foreground 0))
(xt:app-main-loop)