Gauche Scheme

[JRS]

I discovered Gauche Scheme interpreter today and compiled it under Ubuntu 64 bit. I also compiled the OpenGL extension module. Here is a Mandelbrot example. (it displayed almost instantly) What is really unique (to me) is if I resize the window, the image is redrawn instantly.

Gauche Project Site

Note: This was the Scheme used on the Coding Ground (CompileOnLine.com) site.

Code: Scheme

1. ;;
2. ;; Calculate and show Mandelbrot set.
3. ;;
4.  
5. (use gauche.uvector)
6. (use gl)
7. (use gl.glut)
8. (use math.const)
9.  
10. (define *size*  256)
11. (define *image* (make-u8vector (* *size* *size* 3) 0))
12. (define *tex* #f)
13.  
14. (define *speed-phi* 0)
15. (define *xrot* 0)
16. (define *yrot* 0)
17.  
18. (define (fill-image)
19.   (dotimes (y *size*)
20.     (dotimes (x *size*)
21.       (let ((i (* (+ (* y *size*) x) 3))
22.             (z (make-rectangular (- (* 3 (/ x *size*)) 2)
23.                                  (- (* 3 (/ y *size*)) 1.5))))
24.         (letrec ((rank (lambda (zn n)
25.                          (cond ((>= n 16) 0)
26.                                ((>= (magnitude zn) 2) n)
27.                                (else (rank (+ (* zn zn) z) (+ n 1)))))))
28.           (let ((r (rank z 0)))
29.             (u8vector-set! *image* i       (ash (logand r #xc) 4))
30.             (u8vector-set! *image* (+ i 1) (ash (logand r #x2) 6))
31.             (u8vector-set! *image* (+ i 2) (ash (logand r #x1) 7))
32.             ))))))
33.  
34. (define (init)
35.   (fill-image)
36.   (gl-clear-color 0.0 0.0 0.0 0.0)
37.   (gl-shade-model GL_FLAT)
38.   (set! *tex* (u32vector-ref (gl-gen-textures 1) 0))
39.   (gl-bind-texture GL_TEXTURE_2D *tex*)
40.   (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT)
41.   (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT)
42.   (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST)
43.   (gl-tex-parameter GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST)
44.   (gl-tex-image-2d GL_TEXTURE_2D 0 GL_RGB *size* *size* 0
45.                    GL_RGB GL_UNSIGNED_BYTE *image*)
46.   )
47.  
48. (define (disp)
49.   (gl-clear GL_COLOR_BUFFER_BIT)
50.   (gl-enable GL_TEXTURE_2D)
51.   (gl-tex-env GL_TEXTURE_ENV GL_TEXTURE_ENV_MODE GL_REPLACE)
52.   (gl-bind-texture GL_TEXTURE_2D *tex*)
53.   (gl-push-matrix)
54.   (gl-load-identity)
55.   (gl-translate 0.5 0.5 0.0)
56.   (gl-rotate *xrot* 1.0 0.0 0.0)
57.   (gl-rotate *yrot* 0.0 1.0 0.0)
58.   (gl-translate -0.5 -0.5 0.0)
59.   (gl-begin GL_QUADS)
60.   (gl-tex-coord '#f32(0.0 0.0)) (gl-vertex '#f32(0.0 0.0))
61.   (gl-tex-coord '#f32(0.0 1.0)) (gl-vertex '#f32(0.0 1.0))
62.   (gl-tex-coord '#f32(1.0 1.0)) (gl-vertex '#f32(1.0 1.0))
63.   (gl-tex-coord '#f32(1.0 0.0)) (gl-vertex '#f32(1.0 0.0))
64.   (gl-end)
65.   (gl-pop-matrix)
66.   (glut-swap-buffers)
67.   (gl-disable GL_TEXTURE_2D)
68.   (animate)
69.   )
70.  
71. (define (reshape w h)
72.   (gl-viewport 0 0 w h)
73.   (gl-matrix-mode GL_PROJECTION)
74.   (gl-load-identity)
75.   (glu-ortho-2d 0 1 0 1)
76.   (gl-matrix-mode GL_MODELVIEW)
77.   (gl-load-identity)
78.   )
79.  
80. (define (animate)
81.   (let1 speed (abs (sin (* *speed-phi* pi/180)))
82.     (set! *xrot* (fmod (+ *xrot* (/ speed 172.0)) 360.0))
83.     (set! *yrot* (fmod (+ *yrot* (/ speed 334.0)) 360.0))
84.     (set! *speed-phi* (fmod (+ *speed-phi* 0.003) 360.0)))
85.   (glut-post-redisplay)
86.   )
87.  
88. (define (main args)
89.   (glut-init args)
90.   (glut-init-display-mode (logior GLUT_DOUBLE GLUT_RGB))
91.   (glut-init-window-size 256 256)
92.   (glut-create-window "mandelbrot")
93.   (init)
94. ;  (glut-idle-func animate)
95.   (glut-reshape-func reshape)
96.   (glut-display-func disp)
97.   (glut-main-loop)
98.   0
99.   )
100.  

.

[RobbeK]

Hi John,

rather fast , made in Japan it seems , full numeric tower and takes some interesting ideas from Common Lisp (dotimes , incf , decf etc ...)
also installs SLIB  !!!

testing : splitting 10,000,000 numbers (0...  ..999)  in even and odd

Setting up gauche (0.9.3.3-8ubuntu1) ...
Setting up slib (3b1-3.1) ...
Processing triggers for libc-bin (2.19-0ubuntu6.4) ...
gerd@gerd-HP-Pavilion-dv4000-EK987EA-UUG:~$ gosh
gosh> (define (tst)
       (let ((a 0) (b 0))
        (dotimes (i 10000000 (list a b))
         (if (even? i) (inc! a) (inc! b)))))
tst
gosh> (tst)
(5000000 5000000)
gosh> (time (tst))
;(time (tst))
; real   1.942
; user   1.810
; sys    0.000
(5000000 5000000)

faster than NewLISP (which is fast)

newLISP v.10.6.0 32-bit on Linux IPv4/6 libffi, options: newlisp -h

>
(lambda ()
 (let ((a 0) (b 0))
  (dotimes (i 10000000)
   (if (even? i)
    (++ a)
    (++ b)))
  (list a b)))
> (time (tst))
2775.392


> compare with Austin Kyoto CL (interpreted and compiled)

GCL (GNU Common Lisp)  2.6.10 CLtL1    Apr  2 2014 14:19:37
Source License: LGPL(gcl,gmp), GPL(unexec,bfd,xgcl)
Binary License:  GPL due to GPL'ed components: (XGCL READLINE UNEXEC)
Modifications of this banner must retain notice of a compatible license
Dedicated to the memory of W. Schelter

Use (help) to get some basic information on how to use GCL.
Temporary directory for compiler files set to /tmp/

>(defun tst ()
  (let ((a 0) (b 0))
   (dotimes (i 10000000 (list a b))
    (if (evenp i) (incf a) (incf b)))))

TST

>(time (tst))

real time

      :      3.779 secs
run-gbc time    :      3.099 secs
child run time  :      0.000 secs
gbc time        :      0.109 secs
(5000000 5000000)

>(compile 'tst)

Compiling /tmp/gazonk_4102_0.lsp.
End of Pass 1. 
End of Pass 2. 
OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3
Finished compiling /tmp/gazonk_4102_0.lsp.
Loading /tmp/gazonk_4102_0.o
start address -T 0x8a36d0 Finished loading /tmp/gazonk_4102_0.o
#<compiled-function TST>
NIL
NIL

>(time (tst))

real time       :      0.059 secs
run-gbc time    :      0.039 secs
child run time  :      0.000 secs
gbc time        :      0.000 secs
(5000000 5000000)

>
best, Rob

[RobbeK]

Hi John,

http://www.koguro.net/prog/dyncomp/index.html

Starting to like Gauche very much 

best, Rob

[JRS]

Rob,

That is great news! I'm glad you found a Scheme language you like. Are your running Gauche under Linux or Windows?

John

[RobbeK]

Hi John,

Under Linux for the moment , but the editor under Wine (LispIDE  -- has Scheme syntax highlighting and parens matching ), but on another computer I have it both for Win and Linux (I always had Ubuntu on it - mainly for the web, mobile network (tethering etc..)  and repair windows files hit by malware , the Libre Office , export to PDF , reading PS and deja-vu files, edit PDF's  etc ..  )  I do my very best not to use pirated software (which is imo the success of windows --  I mean the high amount of pirate copies makes it popular - everyone has a PhotoShop these days ,  99 out of 100 an illegal copy      (and furthermore used by people who simply do not need such complicated programs  --it's amazing what I get in my mailbox sometimes -- invitations made on a spread sheet etc ...    it's very sad ...  if they had to buy legal copies , Linux would be much more popular (though i'm somewhat worried about the increasing fragmentation at this moment)

best, Rob 

[JRS]

it's very sad ...  if they had to buy legal copies , Linux would be much more popular (though i'm somewhat worried about the increasing fragmentation at this moment)

Actually bootleg software helps more than it hurts. Think about it. People buy software they plan to use. Most users have been burnt and spent money on crap the vendor did a great marketing effort on. Most bootleg software installs go in one of two directions. The pirate likes the software and ends up buying it for the support and upgrade aspect. The other direction is it's used once or twice and then deleted for the next item on the plate.

Linux and open source eliminates those steps and mess that goes along with it. The idea behind open source is to use existing code and make whatever your doing better.
 

[JRS]

but the editor under Wine (LispIDE  -- has Scheme syntax highlighting and parens matching )

I use UltraEdit under Linux and Windows. The license covers up to three instances of whatever OS it supports. This example is using the Scheme syntax highlighting definition file. They are easy to expand on and the options are extensive. The other cool thing about UE is it's scripting engine is JavaScript.





.

[JRS]

Rob,

I built the Gauche GtkGLExt and GD (with PangoFT2 support) which should finally wean you off the JAPI tit. 

301 in 5.010643 seconds = 60.07213046309625 FPS

Code: Scheme

1. ;;
2. ;; 3-D gear wheels.  This program is in the public domain.
3. ;;
4. ;; Brian Paul
5. ;;
6. ;; Conversion to GLUT by Mark J. Kilgard
7. ;; Conversion to GtkGLExt by Naofumi Yasufuku
8. ;; Port to Scheme by Shiro Kawai
9.  
10. (use math.const)
11. (use gtk)
12. (use gtk.gtkgl)
13. (use gl)
14.  
15. ;; Draw a gear wheel.  You'll probably want to call this function when
16. ;; building a display list since we do a lot of trig here.
17. ;;
18. ;; Input:  inner_radius - radius of hole at center
19. ;; outer_radius - radius at center of teeth
20. ;; width - width of gear
21. ;; teeth - number of teeth
22. ;; tooth_depth - depth of tooth
23.  
24. (define (gear inner-radius outer-radius width teeth tooth-depth)
25.   (let ((r0 inner-radius)
26.         (r1 (- outer-radius (/ tooth-depth 2.0)))
27.         (r2 (+ outer-radius (/ tooth-depth 2.0)))
28.         (da (* 2.0 (/ pi teeth 4.0))))
29.     (gl-shade-model GL_FLAT)
30.     (gl-normal 0.0 0.0 1.0)
31.  
32.     ;; draw front face
33.     (gl-begin GL_QUAD_STRIP)
34.     (dotimes (i (+ teeth 1))
35.       (let1 angle (* i 2.0 (/ pi teeth))
36.         (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
37.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
38.         (when (< i teeth)
39.           (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))
40.           (gl-vertex (* r1 (cos (+ angle (* 3 da))))
41.                      (* r1 (sin (+ angle (* 3 da))))
42.                      (* width 0.5)))))
43.     (gl-end)
44.  
45.     ;; draw front sides of teeth
46.     (gl-begin GL_QUADS)
47.     (dotimes (i teeth)
48.       (let1 angle (* i 2.0 (/ pi teeth))
49.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
50.         (gl-vertex (* r2 (cos (+ angle da)))
51.                    (* r2 (sin (+ angle da)))
52.                    (* width 0.5))
53.         (gl-vertex (* r2 (cos (+ angle (* 2 da))))
54.                    (* r2 (sin (+ angle (* 2 da))))
55.                    (* width 0.5))
56.         (gl-vertex (* r1 (cos (+ angle (* 3 da))))
57.                    (* r1 (sin (+ angle (* 3 da))))
58.                    (* width 0.5))))
59.     (gl-end)
60.  
61.     (gl-normal 0.0 0.0 -1.0)
62.  
63.     ;; draw back face
64.     (gl-begin GL_QUAD_STRIP)
65.     (dotimes (i (+ teeth 1))
66.       (let1 angle (* i 2.0 (/ pi teeth))
67.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
68.         (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
69.         (when (< i teeth)
70.           (gl-vertex (* r1 (cos (+ angle (* 3 da))))
71.                      (* r1 (sin (+ angle (* 3 da))))
72.                      (* width -0.5))
73.           (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5)))))
74.     (gl-end)
75.  
76.     ;; draw back sides of teeth
77.     (gl-begin GL_QUADS)
78.     (dotimes (i teeth)
79.       (let1 angle (* i 2.0 (/ pi teeth))
80.         (gl-vertex (* r1 (cos (+ angle (* 3 da))))
81.                    (* r1 (sin (+ angle (* 3 da))))
82.                    (* width -0.5))
83.         (gl-vertex (* r2 (cos (+ angle (* 2 da))))
84.                    (* r2 (sin (+ angle (* 2 da))))
85.                    (* width -0.5))
86.         (gl-vertex (* r2 (cos (+ angle da)))
87.                    (* r2 (sin (+ angle da)))
88.                    (* width -0.5))
89.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))))
90.     (gl-end)
91.  
92.     ;; draw outward faces of teeth
93.     (gl-begin GL_QUAD_STRIP)
94.     (dotimes (i teeth)
95.       (let* ((angle (* i 2.0 (/ pi teeth)))
96.              (u (- (* r2 (cos (+ angle da))) (* r1 (cos angle))))
97.              (v (- (* r2 (sin (+ angle da))) (* r1 (sin angle))))
98.              (len (sqrt (+ (* u u) (* v v))))
99.              (uu (/ u len))
100.              (vv (/ v len)))
101.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width 0.5))
102.         (gl-vertex (* r1 (cos angle)) (* r1 (sin angle)) (* width -0.5))
103.         (gl-normal v (- u) 0.0)
104.         (gl-vertex (* r2 (cos (+ angle da)))
105.                    (* r2 (sin (+ angle da)))
106.                    (* width 0.5))
107.         (gl-vertex (* r2 (cos (+ angle da)))
108.                    (* r2 (sin (+ angle da)))
109.                    (* width -0.5))
110.         (gl-normal (cos angle) (sin angle) 0.0)
111.         (gl-vertex (* r2 (cos (+ angle da da)))
112.                    (* r2 (sin (+ angle da da)))
113.                    (* width 0.5))
114.         (gl-vertex (* r2 (cos (+ angle da da)))
115.                    (* r2 (sin (+ angle da da)))
116.                    (* width -0.5))
117.         (gl-normal (- (* r1 (sin (+ angle da da da)))
118.                       (* r2 (sin (+ angle da da))))
119.                    (- (- (* r1 (cos (+ angle da da da)))
120.                       (* r2 (cos (+ angle da da)))))
121.                    0.0)
122.         (gl-vertex (* r1 (cos (+ angle da da da)))
123.                    (* r1 (sin (+ angle da da da)))
124.                    (* width 0.5))
125.         (gl-vertex (* r1 (cos (+ angle da da da)))
126.                    (* r1 (sin (+ angle da da da)))
127.                    (* width -0.5))
128.         (gl-normal (cos angle) (sin angle) 0.0)))
129.     (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width 0.5))
130.     (gl-vertex (* r1 (cos 0)) (* r1 (sin 0)) (* width -0.5))
131.     (gl-end)
132.  
133.     (gl-shade-model GL_SMOOTH)
134.     ;; draw inside radius cylinder
135.     (gl-begin GL_QUAD_STRIP)
136.     (dotimes (i (+ teeth 1))
137.       (let1 angle (* i 2.0 (/ pi teeth))
138.         (gl-normal (- (cos angle)) (- (sin angle)) 0.0)
139.         (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width -0.5))
140.         (gl-vertex (* r0 (cos angle)) (* r0 (sin angle)) (* width 0.5))))
141.     (gl-end)
142.     ))
143.  
144. (define *view-rotx* 20.0)
145. (define *view-roty* 30.0)
146. (define *view-rotz* 0.0)
147. (define *gear1* 0)
148. (define *gear2* 0)
149. (define *gear3* 0)
150. (define *angle* 0.0)
151. (define *timer* #f)
152. (define *frames* 0)
153.  
154. (define (draw widget . _)
155.   (let ((glcontext (gtk-widget-get-gl-context widget))
156.         (gldrawable (gtk-widget-get-gl-drawable widget)))
157.     ;;*** OpenGL BEGIN ***
158.     (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
159.       (gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
160.       (begin
161.         (gl-push-matrix)
162.         (gl-rotate *view-rotx* 1.0 0.0 0.0)
163.         (gl-rotate *view-roty* 0.0 1.0 0.0)
164.         (gl-rotate *view-rotz* 0.0 0.0 1.0)
165.         (begin
166.           (gl-push-matrix)
167.           (gl-translate -3.0 -2.0 0.0)
168.           (gl-rotate *angle* 0.0 0.0 1.0)
169.           (gl-call-list *gear1*)
170.           (gl-pop-matrix))
171.         (begin
172.           (gl-push-matrix)
173.           (gl-translate 3.1 -2.0 0.0)
174.           (gl-rotate (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0)
175.           (gl-call-list *gear2*)
176.           (gl-pop-matrix))
177.         (begin
178.           (gl-push-matrix)
179.           (gl-translate -3.1 4.2 0.0)
180.           (gl-rotate (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0)
181.           (gl-call-list *gear3*)
182.           (gl-pop-matrix))
183.         (gl-pop-matrix))
184.       (if (gdk-gl-drawable-is-double-buffered gldrawable)
185.           (gdk-gl-drawable-swap-buffers gldrawable)
186.           (gl-flush))
187.       (gdk-gl-drawable-gl-end gldrawable))
188.    
189.     (inc! *frames*)
190.     (let1 seconds (g-timer-elapsed *timer*)
191.       (when (>= seconds 5.0)
192.         (print #`",*frames* in ,seconds seconds = ,(/ *frames* seconds) FPS")
193.         (g-timer-reset *timer*)
194.         (set! *frames* 0)))
195.     #t))
196.  
197. ;; new window size or exposure
198. (define (reshape widget . _)
199.   (let* ((glcontext (gtk-widget-get-gl-context widget))
200.          (gldrawable (gtk-widget-get-gl-drawable widget))
201.          (wsize (ref widget 'allocation))
202.          (h (/ (ref wsize 'height) (ref wsize 'width))))
203.     ;;*** OpenGL BEGIN ***
204.     (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
205.       (gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height))
206.       (gl-matrix-mode GL_PROJECTION)
207.       (gl-load-identity)
208.       (gl-frustum -1.0 1.0 (- h) h 5.0 60.0)
209.       (gl-matrix-mode GL_MODELVIEW)
210.       (gl-load-identity)
211.       (gl-translate 0.0 0.0 -40.0)
212.       (gdk-gl-drawable-gl-end gldrawable))
213.     ;;*** OpenGL END ***
214.     #t))
215.  
216. (define (init widget)
217.   (let ((glcontext (gtk-widget-get-gl-context widget))
218.         (gldrawable (gtk-widget-get-gl-drawable widget)))
219.     ;;*** OpenGL BEGIN ***
220.     (when (gdk-gl-drawable-gl-begin gldrawable glcontext)
221.       (gl-light GL_LIGHT0 GL_POSITION '#f32(5.0 5.0 10.0 0.0))
222.       (gl-enable GL_CULL_FACE)
223.       (gl-enable GL_LIGHTING)
224.       (gl-enable GL_LIGHT0)
225.       (gl-enable GL_DEPTH_TEST)
226.  
227.       ;; make the gears
228.       (set! *gear1* (gl-gen-lists 1))
229.       (gl-new-list *gear1* GL_COMPILE)
230.       (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.8 0.1 0.0 1.0))
231.       (gear 1.0 4.0 1.0 20 0.7)
232.       (gl-end-list)
233.  
234.       (set! *gear2* (gl-gen-lists 1))
235.       (gl-new-list *gear2* GL_COMPILE)
236.       (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.0 0.8 0.2 1.0))
237.       (gear 0.5 2.0 2.0 10 0.7)
238.       (gl-end-list)
239.  
240.       (set! *gear3* (gl-gen-lists 1))
241.       (gl-new-list *gear3* GL_COMPILE)
242.       (gl-material GL_FRONT GL_AMBIENT_AND_DIFFUSE '#f32(0.2 0.2 1.0 1.0))
243.       (gear 1.3 2.0 0.5 10 0.7)
244.       (gl-end-list)
245.      
246.       (gl-enable GL_NORMALIZE)
247.  
248.       (print)
249.       (print #`"GL_RENDERER   = ,(gl-get-string GL_RENDERER)")
250.       (print #`"GL_VERSION    = ,(gl-get-string GL_VERSION)")
251.       (print #`"GL_VENDOR     = ,(gl-get-string GL_VENDOR)")
252.       (print #`"GL_EXTENSIONS = ,(gl-get-string GL_EXTENSIONS)")
253.       (print)
254.  
255.       (gdk-gl-drawable-gl-end gldrawable))
256.     ;;*** OpenGL END ***
257.  
258.     ;; create timer
259.     (unless *timer* (set! *timer* (g-timer-new)))
260.     (g-timer-start *timer*)
261.     ))
262.  
263. (define (idle widget)
264.   (inc! *angle* 0.5)
265.   (if (> *angle* 360) (set! *angle* (fmod *angle* 360)))
266.   (gtk-widget-queue-draw widget)
267.   #t)
268.  
269. (define *idle-id* 0)
270.  
271. (define (map widget . _)
272.   (when (zero? *idle-id*)
273.     (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW
274.                                            (lambda _ (idle widget)))))
275.   #t)
276.  
277. (define (unmap widget . _)
278.   (unless (zero? *idle-id*)
279.     (gtk-idle-remove *idle-id*)
280.     (set! *idle-id* 0))
281.   #t)
282.  
283. (define (visible widget event)
284.   (if (= (ref event 'state) GDK_VISIBILITY_FULLY_OBSCURED)
285.       (unless (zero? *idle-id*)
286.               (gtk-idle-remove *idle-id*)
287.               (set! *idle-id* 0))
288.       (when (zero? *idle-id*)
289.         (set! *idle-id* (gtk-idle-add-priority GDK_PRIORITY_REDRAW
290.                                                (lambda _ (idle widget))))))
291.   #t)
292.  
293. ;; change view angle, exit upon ESC
294. (define (key widget event)
295.   (let ((kv (ref event 'keyval))
296.         (q  (lambda () (gtk-widget-queue-draw widget))))
297.     (cond
298.      ((= kv GDK_KEY_z)      (set! *view-rotz* (fmod (+ *view-rotz* 5.0) 360)) (q))
299.      ((= kv GDK_KEY_Z)      (set! *view-rotz* (fmod (- *view-rotz* 5.0) 360)) (q))
300.      ((= kv GDK_KEY_Up)     (set! *view-rotx* (fmod (+ *view-rotx* 5.0) 360)) (q))
301.      ((= kv GDK_KEY_Down)   (set! *view-rotx* (fmod (- *view-rotx* 5.0) 360)) (q))
302.      ((= kv GDK_KEY_Left)   (set! *view-roty* (fmod (+ *view-roty* 5.0) 360)) (q))
303.      ((= kv GDK_KEY_Right)  (set! *view-roty* (fmod (- *view-roty* 5.0) 360)) (q))
304.      ((= kv GDK_KEY_Escape) (gtk-main-quit))))
305.   #t)
306.  
307. (define (main args)
308.   (gtk-init args)
309.   (unless (gdk-gl-query-extension)
310.     (error "*** OpenGL is not supported."))
311.  
312.   ;;
313.   ;; Configure OpenGL-capable visual.
314.   ;;
315.   (let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB
316.                                                         GDK_GL_MODE_DEPTH
317.                                                         GDK_GL_MODE_DOUBLE))
318.                      (begin
319.                        (warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n")
320.                        (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB
321.                                                           GDK_GL_MODE_DEPTH)))
322.                      (error "*** No appropriate OpenGL-capable visual found.")
323.                      )
324.     ;;
325.     ;; Top-level window.
326.     ;;
327.     (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL)
328.       (gtk-window-set-title window "gears")
329.       (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)))
330.       (g-signal-connect window "key_press_event" key)
331.       (g-signal-connect window "unmap_event" unmap)
332.       (let1 vbox (gtk-vbox-new #f 0)
333.         (gtk-container-add window vbox)
334.         (gtk-widget-show vbox)
335.         ;;
336.         ;; Drawing area for drawing OpenGL scene.
337.         ;;
338.         (let1 drawing-area (gtk-drawing-area-new)
339.           (gtk-widget-set-size-request drawing-area 300 300)
340.           ;; Set OpenGL-capability to the widget.
341.           (gtk-widget-set-gl-capability drawing-area glconfig #f #t
342.                                         GDK_GL_RGBA_TYPE)
343.           (gtk-box-pack-start vbox drawing-area #t #t 0)
344.           (gtk-widget-set-events drawing-area
345.                                  (logior GDK_EXPOSURE_MASK
346.                                          GDK_BUTTON_PRESS_MASK
347.                                          GDK_VISIBILITY_NOTIFY_MASK))
348.           (g-signal-connect drawing-area "realize" init)
349.           (g-signal-connect drawing-area "configure_event" reshape)
350.           (g-signal-connect drawing-area "expose_event" draw)
351.           (g-signal-connect drawing-area "map_event" map)
352.           (g-signal-connect drawing-area "unmap_event" unmap)
353.           (g-signal-connect drawing-area "visibility_notify_event" visible)
354.           (gtk-widget-show drawing-area))
355.         ;;
356.         ;; Simple quit button.
357.         ;;
358.         (let1 button (gtk-button-new-with-label "Quit")
359.           (gtk-box-pack-start vbox button #f #f 0)
360.           (g-signal-connect button "clicked" (lambda _ (gtk-main-quit)))
361.           (gtk-widget-show button))
362.         );vbox
363.       (gtk-widget-show window)
364.       )
365.     (gtk-main)
366.     0))
367.  

.

[JRS]

Here is the Gtk GL GD example. As you mouse over the window client area, the color of the buttons change.

Code: Scheme

1. ;;
2. ;; like "simple", but using higher-level <gtk-graph-area> widget.
3. ;; $Id: simple2.scm,v 1.2 2007/01/13 01:36:30 maruska Exp $
4. ;;
5.  
6. (use gtk)
7. (use gtk.gtkgl)
8. (use gtk.glgd)
9.  
10. (define *attr-geometry* 0)
11. (define *attr-skeleton* 1)
12. (define *attr-current* GLGD_ATTR_FORCEVISIBLE)
13.  
14. (define (main args)
15.   (gtk-init args)
16.   (unless (gdk-gl-query-extension)
17.     (error "*** OpenGL is not supported."))
18.  
19.   (let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL)
20.     (gtk-window-set-title window "objview")
21.     (g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)))
22.     (let1 vbox (gtk-vbox-new #f 0)
23.       (gtk-container-add window vbox)
24.       (gtk-widget-show vbox)
25.       ;;
26.       ;; Drawing area for drawing OpenGL scene.
27.       ;;
28.       (let1 graph-area (make <gtk-graph-area>)
29.         (gtk-widget-set-size-request graph-area 640 480)
30.         (gtk-box-pack-start vbox graph-area #t #t 0)
31.         (graph-build-simple (ref graph-area 'graph))
32.         (gtk-widget-show graph-area))
33.       ;;
34.       ;; Simple quit button.
35.       ;;
36.       (let1 button (gtk-button-new-with-label "Quit")
37.         (gtk-box-pack-start vbox button #f #f 0)
38.         (g-signal-connect button "clicked" (lambda _ (gtk-main-quit)))
39.         (gtk-widget-show button))
40.       )
41.     (gtk-widget-show window)
42.     (gtk-main)
43.     0))
44.  
45. ;; create a simple graph
46. (define (graph-build-simple graph)
47.   (glgd-graph-init graph)
48.   (let* ((model (glgd-node-create))
49.          (geometry (glgd-node-create))
50.          (torso (glgd-node-create))
51.          (arms (glgd-node-create))
52.          (legs (glgd-node-create))
53.          (skeleton (glgd-node-create))
54.          (hip (glgd-node-create))
55.          (thighLeft (glgd-node-create))
56.          (thighRight (glgd-node-create)))
57.     (glgd-node-info-set model "model" 0)
58.     (glgd-node-attribute-set model *attr-geometry*)
59.     (glgd-node-info-set geometry "geometry" 1)
60.     (glgd-node-attribute-set geometry *attr-geometry*)
61.     (glgd-node-info-set skeleton "skeleton" 2)
62.     (glgd-node-attribute-set skeleton *attr-skeleton*)
63.     (glgd-node-info-set torso "torso" 3)
64.     (glgd-node-attribute-set torso *attr-geometry*)
65.     (glgd-node-info-set arms "arms" 4)
66.     (glgd-node-attribute-set arms *attr-geometry*)
67.     (glgd-node-info-set legs "legs" 5)
68.     (glgd-node-attribute-set legs *attr-geometry*)
69.     (glgd-node-info-set hip "hip" 6)
70.     (glgd-node-attribute-set hip *attr-skeleton*)
71.     (glgd-node-info-set thighLeft "thighLeft" 7)
72.     (glgd-node-attribute-set thighLeft *attr-skeleton*)
73.     (glgd-node-info-set thighRight "thighRight" 8)
74.     (glgd-node-attribute-set thighRight *attr-skeleton*)
75.     (glgd-graph-node-add graph model)
76.     (glgd-graph-node-add graph geometry)
77.     (glgd-graph-node-add graph skeleton)
78.     (glgd-graph-node-add graph torso)
79.     (glgd-graph-node-add graph arms)
80.     (glgd-graph-node-add graph legs)
81.     (glgd-graph-node-add graph hip)
82.     (glgd-graph-node-add graph thighLeft)
83.     (glgd-graph-node-add graph thighRight)
84.     (let* ((list (glgd-link-list-create))
85.            (m2g (glgd-link-create))
86.            (g2t (glgd-link-create))
87.            (g2a (glgd-link-create))
88.            (g2l (glgd-link-create))
89.            (m2s (glgd-link-create))
90.            (s2h (glgd-link-create))
91.            (h2tl (glgd-link-create))
92.            (h2tr (glgd-link-create))
93.            (tr2h (glgd-link-create))
94.            (tr2s (glgd-link-create)))
95.       (glgd-link-set m2g model geometry)
96.       (glgd-link-set g2t geometry torso)
97.       (glgd-link-set g2a geometry arms)
98.       (glgd-link-set g2l geometry legs)
99.       (glgd-link-set m2s model skeleton)
100.       (glgd-link-set s2h skeleton hip)
101.       (glgd-link-set h2tl hip thighLeft)
102.       (glgd-link-set h2tr hip thighRight)
103.       (glgd-link-set tr2h thighRight hip)
104.       (glgd-link-set tr2s thighRight skeleton)
105.       (glgd-graph-link-add graph list m2g)
106.       (glgd-graph-link-add graph list m2s)
107.       (glgd-graph-link-add graph list g2t)
108.       (glgd-graph-link-add graph list g2a)
109.       (glgd-graph-link-add graph list g2l)
110.       (glgd-graph-link-add graph list s2h)
111.       (glgd-graph-link-add graph list h2tl)
112.       (glgd-graph-link-add graph list h2tr)
113.       (glgd-graph-link-add graph list tr2h)
114.       (glgd-graph-link-add graph list tr2s)
115.       (glgd-graph-link-list-add graph list)))
116.   (glgd-graph-attribute-set graph *attr-current*)
117.   (glgd-graph-auto-organize graph 0.0 0.0)
118.   (glgd-graph-link-list-dump graph)
119.   #t)
120.  

.

[Mike Lobanovsky]

Despite the apparent complexity, the gears example isn't very representative of software throughput.

Below is a snapshot of gears example running in Fabrice Bellard's (he's the author of Tiny C Compiler, the engine behind FBSL Dynamic C) TinyGL software renderer under KolibriOS within the VMware Player virtual machine.

TinyGL is a tiny subset of OpenGL-like API reimplemented with the aid of pure GDI calls. KolibriOS is an absolutely tiny open-source non-Linux indie graphical operating system written in pure assembly; its basic distro w/o the game set fits on a 1.44MB floppy disk! KolibriOS's graphics doesn't enjoy any hardware acceleration either.

Yet watch the absolutely amazing FPS rate of this example in a KolibryOS TinyGL window.

.

[RobbeK]

Thanks, John Mike for all this interesting stuff !!

John - up to date with your specs now -- (some small problems with the libutils (seems to be libutils-gold that I needed ).
Great, I can "mouse wheel" into the widgets.
Can't get DynLoad package working , but the C-Wrapper is working

gosh> (use c-wrapper)
#<undef>
gosh> (c-load "stdio.h")
#<undef>
gosh> (printf "Hello \n")
Hello
7
gosh>     -- great stuff,

thanks !!

[JRS]

I'm glad we both found something we like and can work together on.

Let me know what the issues are and I'll take a shot and finding a solution. Worse case we can beg Mike to help. 

[Mike Lobanovsky]

Mike bad, Mike angry, Mike eat little kids for supper!

[JRS]

No!

You translated that incorrectly.

[RobbeK]

John , all ,

tk/tcl is very easy to set up on Gauche and newLISP  ( http://www.tcl.tk/ ).  Linux already comes with it (be it a somewhat older version) , easy to install under Win and Mac.  There's a package for the CL compilers CLISP , Clozure , Steel Bank , CMUCL , ECL , Mankay etc..
In newLISP and Gauche there's even no need to compile anything , just setting up the pipes :

(map set '(myin tcout) (pipe))
(map set '(tcin myout) (pipe))
(process "/usr/bin/wish" tcin tcout)

;; passing the commands
(define (tk)
  (write-line myout (append "if { [catch { puts ["
              (apply string (args)) "] }] } { "
              [text] tk_messageBox -message $errorInfo; exit }
    [/text]))

and the listener :
(while (read-line myin)
    (eval-string (current-line)))

tk data can be read p.e.

(tk "set A_tcl_variable something")
and caught by newLisp
(setq a-newlisp-variable (tk "puts $A_tcl_variable"))
................   complete interactive, both scripts (lisp+tcl)  can be mixed in the code !!

p.e.     (tk (append "..............  tcl code .................. " (string (.............. lisp code ..............)) ....   etc ...........  ))

any number of call-backs can be set up easily

I also could set up OpenGL , glut under newLISP - a newLISP standalone exec should be less than 300 Kb + characters of the code 
(working on standalone Gauche distro's , but they are a lot fatter , more later )

best Rob

attached 2x newLISP
- swarm ,  tk + newLISP  (no widgets here, but those are easy to set up)
- gprimes ,  Gaussprimes , OpenGL + newLISP
Linux only / you will probably have to set the permissions before running.

addendum : added wineswarm.exe -- same code, bundled under Wine for Win -- however it expects the  exact c:\tcl\bin\wish.exe location  (the standard installation of tk/tcl under Win).  -- (infact the code can be written in a universal way where the code reads the OS and sets the respec. definition ).

for the OpenGL , libGL.so , libglut.so should be in your /usr/lib

.