Gauche-glを使ってウインドウを出すだけ

test_gauche_gl.scm

#! /usr/bin/env gosh

(use gl)
(use gl.glut)

;; Util Procedure
(define (assq-ref entry alist)
  (cdr (assq entry alist)))

(define (slot-list obj getter-list)
  (map (cut <> obj) getter-list))

;;; Classes ---------------------------------------------------
;; Color
;; Hue-Chroma-X model
(define-class <hcx> ()
  ((hue    :init-value 0 :init-keyword :hue    :accessor hue-of)
   (chroma :init-value 0 :init-keyword :chroma :accessor chroma-of)
   (x      :init-value 0 :init-keyword :x      :accessor x-of)))

(define-method x->list ((hcx <hcx>))
  (slot-list hcx (list hue-of chroma-of x-of)))

;; RGB
(define-class <rgb> ()
  ((red   :init-value 0 :init-keyword :r :accessor red-of)
   (green :init-value 0 :init-keyword :g :accessor green-of)
   (blue  :init-value 0 :init-keyword :b :accessor blue-of)))

(define-method hcx->rgb ((hcx <hcx>))
  (receive (h c x) (apply values (x->list hcx))
    (receive (r g b) (apply values (case (x->integer (floor h))
				     [(0)  (list c x 0)]
				     [(1)  (list x c 0)]
				     [(2)  (list 0 c x)]
				     [(3)  (list 0 x c)]
				     [(4)  (list x 0 c)]
				     [(5)  (list c 0 x)]
				     [else (list 0 0 0)]))
      (make <rgb> :r r :g g :b b))))

(define-method x->list ((rgb <rgb>))
  (slot-list rgb (list red-of green-of blue-of)))

(define-method modified-values ((rgb <rgb>) (proc <procedure>))
  (apply values (map proc (x->list rgb))))
				
(define-method +bright ((rgb <rgb>) (bright <number>))
  (receive (r g b) (modified-values rgb (cut + <> bright))
    (make <rgb> :r r :g g :b b)))

;; RGBA
(define-class <rgba> (<rgb>)
  ((alpha :init-value 0 :init-keyword :a :accessor alpha-of)))

(define-method add-alpha ((rgb <rgb>) (a <number>))
  (receive (r g b) (modified-values rgb identity)
    (make <rgba> :r r :g g :b b :a a)))

(define-method x->list ((rgba <rgba>))
  (slot-list rgba (list red-of green-of blue-of alpha-of)))

(define-method +bright ((rgba <rgba>) (bright <number>))
  (receive (r g b) (modified-values rgba (cut + <> bright))
    (make <rgba> :r r :g g :b b :a (alpha-of rgba))))

;; HSL
(define-class <hsl> ()
  ((hue :init-value 0 :init-keyword :h :accessor hue-of)
   (sat :init-value 0 :init-keyword :s :accessor sat-of)
   (lum :init-value 0 :init-keyword :l :accessor lum-of)))

(define-method x->list ((hsl <hsl>))
  (slot-list hsl (list hue-of sat-of lum-of)))

(define-method hsl->rgb ((hsl <hsl>))
  (receive (h s l) (apply values (x->list hsl))
    (let* ((c (if (<= l (/ 1 2)) (* 2 l s) (* 2 (- 1 l) s)))
	   (x (* c (- 1 (abs (- (mod h 2) 1)))))
	   (m (- l (/ c 2)))
	   (rgb (hcx->rgb (make <hcx> :hue h :chroma c :x x))))
      (+bright rgb m))))

;; HSLA
(define-class <hsla> (<hsl>)
  ((alpha :init-value 0 :init-keyword :a :accessor alpha-of)))

(define-method x->list ((hsla <hsla>))
  (slot-list hsla (list hue-of sat-of lum-of alpha-of)))

(define-method add-alpha ((hsl <hsl>) (a <number>))
  (receive (h s l) (apply values (x->list hsl))
    (make <hsla> :h h :s s :l l :a a)))


;;; Global Variables --------------------------------------
(define *bg-color* (make <rgb> :r 0.5 :g 0.5 :b 0.5 :a 1.0))

(define (rated-value value range)
  (if (>= value range) 1.0 (/. value range)))

(define (rated-values value-range-pair-list)
  (apply values (map (pa$ apply rated-value) value-range-pair-list)))

(define (rgba-color-convert r-r g-r b-r a-r)
  (lambda (r g b a)
    (let1 r-g-b-a-list (list `(,r ,r-r) `(,g ,g-r) `(,b ,b-r) `(,a ,a-r))
      (receive (red green blue alpha) (rated-values r-g-b-a-list)
	(make <rgba> :r red :g green :b blue :a alpha)))))

(define (hsla-color-convert h-r s-r l-r a-r)
  (lambda (h s l a)
    (let* ((hue-conv (lambda (r) (if (>= r 360) (mod r 360) r)))
	   (hue (/ (hue-conv (* 360 (/ h h-r))) 60))
	   (s-l-a-list (list `(,s ,s-r) `(,l ,l-r) `(,a ,a-r))))
      (receive (sat lum alpha) (rated-values s-l-a-list)
	(add-alpha (hsl->rgb (make <hsl> :h hue :s sat :l lum)) alpha)))))

(define *color-changer*
  `((RGBA . ,rgba-color-convert)
    (HSLA . ,hsla-color-convert)))

(define *current-color-changer* '())
(define *current-alpha-range* 1.0)

(define *title* "")

(define *key-code*
  '((8 . BS) (9 . Tab) (13 . Return) (16 . Shift) (17 . Ctrl)
    (27 . ESC) (37 . Left) (38 . Up) (39 . Right) (40 . Down)
    (46 . Del)))


;; Accessor of Global Variables
(define (name-of key) 
  (assq-ref key *key-code*))

(define (color-mode mode v1-r v2-r v3-r a-r)
  (set! *current-color-changer* 
	((assq-ref mode *color-changer*) v1-r v2-r v3-r a-r))
  (set! *current-alpha-range* a-r)
  #t)

;; default Color Space Model
(color-mode 'RGBA 100 100 100 100)

(define (color v . vs)
  (let ((conv *current-color-changer*)
	(alpha *current-alpha-range*))
    (case (length vs)
      [(0)  (conv v v v alpha)]
      [(1)  (apply conv v v v vs)]
      [(2)  (apply conv v (append vs `(,alpha)))]
      [else (apply conv v vs)])))

(define (background v . vs) (set! *bg-color* (apply color v vs)))

;;; Basic Process ----------------------------------------------
(define (rendering)
  (apply gl-clear-color (to-list *bg-color*))
  (print (to-list *bg-color*))
  (gl-clear GL_COLOR_BUFFER_BIT)
  (draw)
  (gl-flush)
  )

(define (key-event) '())

(define (size w h)
  (glut-init-display-mode (logior GLUT_SINGLE GLUT_RGBA))
  (glut-init-window-size w h)
  (glut-init-window-position 0 0)
  )

(define (init args)
  (glut-init args)
  (setup)
  (gl-matrix-mode GL_PROJECTION)
  (gl-load-identity)
  (gl-ortho 0.0 1.0 0.0 1.0 -1.0 1.0)
  (glut-display-func rendering)
  (glut-keyboard-func key-pressed)
  (glut-create-window *title*))

(define (main args)
  (set! *title* (car args))
  (init args)
  (glut-main-loop)
  0)

;;; User Sketch Program -------------------------------------

(define (setup)
  (size 400 400)
  (background 0.0 0.0 0.0)
  ;; write something setup procedure
  )

(define (draw)
  ;; write something drawing procedure
  )

(define (key-pressed key-code x y)
  (let* ((key (name-of key-code))
	 (print-key-info (lambda () (print #`"key :: ,|key|"))))
    (case key
      ((ESC) (begin (print-key-info)
		    (exit 0)))
      ;; write something key event procedure
      (else (print-key-info)))))

HSL -> RGB 色空間変換 だけサポートして，ユーザのプログラムがより Processing Like になるように書き直した