1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
|
;;
;; Simple bitmap font rendering example.
;;
;; Ported from examples/font.c,
;; written by Naofumi Yasufuku <naofumi@users.sourceforge.net>
;;
(use gauche.collection)
(use gauche.uvector)
(use gtk)
(use gtk.gtkgl)
(use gl)
(define *font-string* "courier 12")
(define *font-list-base* 0)
(define *font-height* 0)
(define-syntax prval
(syntax-rules ()
((_ expr) (format #f "~s = ~a" 'expr expr))))
(define-syntax prattr
(syntax-rules ()
((_ glconfig name bool?)
(receive (status value) (gdk-gl-config-get-attrib glconfig name)
(if status
(format #f "~s = ~s" 'name
(if bool?
(not (zero? value))
value))
(format #f "~s : failed to get attribute value" 'name))))))
(define (examine-gl-config-attrib glconfig)
(print "\nOpenGL visual configurations :\n")
(print (prval (gdk-gl-config-is-rgba glconfig)))
(print (prval (gdk-gl-config-is-double-buffered glconfig)))
(print (prval (gdk-gl-config-is-stereo glconfig)))
(print (prval (gdk-gl-config-has-alpha glconfig)))
(print (prval (gdk-gl-config-has-depth-buffer glconfig)))
(print (prval (gdk-gl-config-has-accum-buffer glconfig)))
(print)
(print (prattr glconfig GDK_GL_USE_GL #t))
(print (prattr glconfig GDK_GL_BUFFER_SIZE #f))
(print (prattr glconfig GDK_GL_LEVEL #f))
(print (prattr glconfig GDK_GL_RGBA #t))
(print (prattr glconfig GDK_GL_DOUBLEBUFFER #t))
(print (prattr glconfig GDK_GL_STEREO #t))
(print (prattr glconfig GDK_GL_AUX_BUFFERS #f))
(print (prattr glconfig GDK_GL_RED_SIZE #f))
(print (prattr glconfig GDK_GL_GREEN_SIZE #f))
(print (prattr glconfig GDK_GL_BLUE_SIZE #f))
(print (prattr glconfig GDK_GL_ALPHA_SIZE #f))
(print (prattr glconfig GDK_GL_DEPTH_SIZE #f))
(print (prattr glconfig GDK_GL_STENCIL_SIZE #f))
(print (prattr glconfig GDK_GL_ACCUM_RED_SIZE #f))
(print (prattr glconfig GDK_GL_ACCUM_GREEN_SIZE #f))
(print (prattr glconfig GDK_GL_ACCUM_BLUE_SIZE #f))
(print (prattr glconfig GDK_GL_ACCUM_ALPHA_SIZE #f))
(print)
)
(define (init widget)
(let ((glcontext (gtk-widget-get-gl-context widget))
(gldrawable (gtk-widget-get-gl-drawable widget))
(wsize (ref widget 'allocation)))
(when (gdk-gl-drawable-gl-begin gldrawable glcontext)
(let* ((font-list-base (gl-gen-lists 128))
(font-desc (pango-font-description-from-string *font-string*))
(font (gdk-gl-font-use-pango-font font-desc 0 128 font-list-base)))
(unless font
(errorf "*** Can't load font '~s'" *font-string*))
(set! *font-list-base* font-list-base)
(let1 font-metrics (pango-font-get-metrics font #f)
(set! *font-height*
(pango-pixels
(+ (pango-font-metrics-get-ascent font-metrics)
(pango-font-metrics-get-descent font-metrics))))))
(gl-clear-color 1.0 1.0 1.0 1.0)
(gl-clear-depth 1.0)
(gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height))
(gl-matrix-mode GL_PROJECTION)
(gl-load-identity)
(gl-ortho 0.0 (ref wsize 'width) 0.0 (ref wsize 'height) -1.0 1.0)
(gl-matrix-mode GL_MODELVIEW)
(gl-load-identity)
(gdk-gl-drawable-gl-end gldrawable))
;;*** OpenGL END ***
))
(define (reshape widget . _)
(let ((glcontext (gtk-widget-get-gl-context widget))
(gldrawable (gtk-widget-get-gl-drawable widget))
(wsize (ref widget 'allocation)))
;;*** OpenGL BEGIN ***
(when (gdk-gl-drawable-gl-begin gldrawable glcontext)
(gl-viewport 0 0 (ref wsize 'width) (ref wsize 'height))
(gl-matrix-mode GL_PROJECTION)
(gl-load-identity)
(gl-ortho 0.0 (ref wsize 'width) 0.0 (ref wsize 'height) -1.0 1.0)
(gl-matrix-mode GL_MODELVIEW)
(gl-load-identity)
(gdk-gl-drawable-gl-end gldrawable))
;;*** OpenGL END ***
#t))
;; this should be in Gauche core ...
(define (string->u8vector string)
(with-builder (<u8vector> put! get :size (string-size string))
(with-input-from-string string
(lambda () (port-for-each put! read-byte)))
(get)))
(define (display widget . _)
(let ((glcontext (gtk-widget-get-gl-context widget))
(gldrawable (gtk-widget-get-gl-drawable widget)))
;;*** OpenGL BEGIN ***
(when (gdk-gl-drawable-gl-begin gldrawable glcontext)
(gl-clear (logior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
(gl-color 0.0 0.0 0.0)
(do ((i 2 (- i 1)))
((< i -2))
(gl-raster-pos 10.0
(+ (* 0.5 (ref (ref widget 'allocation) 'height))
(* i *font-height*)))
(do ((j (char->integer #\space) (+ j 1)))
((> j (char->integer #\Z)))
(gl-call-list (+ *font-list-base* j))))
(gl-color 1.0 0.0 0.0)
(gl-raster-pos 10.0 10.0)
(gl-list-base *font-list-base*)
(let1 array (string->u8vector *font-string*) ;;ugh...
(gl-call-lists array))
(if (gdk-gl-drawable-is-double-buffered gldrawable)
(gdk-gl-drawable-swap-buffers gldrawable)
(gl-flush))
(gdk-gl-drawable-gl-end gldrawable)
;;*** OpenGL END ***
)
#t))
(define (main args)
(gtk-init args)
(unless (gdk-gl-query-extension)
(error "*** OpenGL is not suppotred.***"))
(call-with-values gdk-gl-query-version
(cut format #t "OpenGL is supported - version ~*~a.~a\n" <> <> <>))
(let1 glconfig (or (gdk-gl-config-new-by-mode (logior GDK_GL_MODE_RGB
GDK_GL_MODE_DOUBLE))
(begin
(warn "*** Cannot find the double-buffered visual.\n*** Trying single-buffered visual.\n")
(gdk-gl-config-new-by-mode GDK_GL_MODE_RGB))
(error "*** No appropriate OpenGL-capable visual found.\n")
)
(examine-gl-config-attrib glconfig)
(let1 window (gtk-window-new GTK_WINDOW_TOPLEVEL)
(gtk-window-set-title window "font")
(g-signal-connect window "delete_event" (lambda _ (gtk-main-quit)) #f)
(let1 vbox (gtk-vbox-new #f 0)
(gtk-container-add window vbox)
(gtk-widget-show vbox)
(let1 drawing-area (gtk-drawing-area-new)
(gtk-widget-set-size-request drawing-area 640 240)
(gtk-widget-set-gl-capability drawing-area glconfig #f #t
GDK_GL_RGBA_TYPE)
(gtk-box-pack-start vbox drawing-area #t #t 0)
(gtk-widget-set-events drawing-area
(logior GDK_EXPOSURE_MASK GDK_BUTTON_PRESS_MASK))
(g-signal-connect drawing-area "realize" init)
(g-signal-connect drawing-area "configure_event" reshape)
(g-signal-connect drawing-area "expose_event" display)
(gtk-widget-show drawing-area))
(let1 button (gtk-button-new-with-label "Quit")
(gtk-box-pack-start vbox button #f #f 0)
(g-signal-connect button "clicked" (lambda _ (gtk-main-quit)) #f)
(gtk-widget-show button))
)
(gtk-widget-show window)
))
(gtk-main)
0)
|
