/[cello]/cello/cello-ftgl.lisp
ViewVC logotype

Contents of /cello/cello-ftgl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Fri Apr 11 09:22:46 2008 UTC (6 years ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +4 -6 lines
*** empty log message ***
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
2 #|
3
4 Copyright (C) 2004 by Kenneth William Tilton
5
6 This library is free software; you can redistribute it and/or
7 modify it under the terms of the Lisp Lesser GNU Public License
8 (http://opensource.franz.com/preamble.html), known as the LLGPL.
9
10 This library is distributed WITHOUT ANY WARRANTY; without even
11 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
12
13 See the Lisp Lesser GNU Public License for more details.
14
15 |#
16
17 (in-package :cello)
18
19 (defmethod font-height ((font ftgl))
20 (+ (abs (font-ascent font))
21 (abs (font-descent font))))
22
23 (defmethod font-ascent ((font ftgl))
24 (trc nil "ascender" (ftgl-get-ascender font))
25 (scr2log (ftgl-get-ascender font)))
26
27 (defmethod font-descent ((font ftgl))
28 "Returns a negative measure of display below font origin"
29 (trc nil "descender" (ftgl-get-descender font))
30 (scr2log (ftgl-get-descender font)))
31
32 (defmethod font-string-length ((font ftgl) string &optional start end)
33 (when start
34 (unless end
35 (setf end (length string))))
36 (ftgl::dbgftgl :font-string-length
37 (ftgl-string-length font (if (or start end)
38 (subseq string start end)
39 string))))
40
41 (defun font-ftgl-ensure (mode face size) ;; ///sorry about the silly naming
42 (trc nil "font-ftgl-ensure requesting" mode face size)
43 (ftgl-font-ensure mode face size (cs-target-res)))
44
45 (defmodel font-id (ct-toggle ix-text)
46 ((font-pathname :initarg :font-pathname :accessor font-pathname))
47 (:default-initargs
48 :style nil
49 :pre-layer (with-layers
50 (:rgba (if (^value) +red+ +black+)))
51 :text-font (c? (font-ftgl-ensure :texture
52 (intern (^font-pathname)) 14))
53 :text$ (c? (string-capitalize
54 (or (^font-pathname) ;; ever not?
55 "Blank")))))
56
57 (defobserver mouse-over? ((self font-id))
58 (when new-value
59 (setf (value (fm-other :ftgl-test)) (^font-pathname))))
60
61 (export! gui-style-ftgl)
62
63 (defclass gui-style-ftgl (gui-style gui-style-sizable)
64 ((mode :initarg :mode :accessor mode :initform :texture)))
65
66 (defmethod make-style-font (style)
67 (break "no font for style ~a" style))
68
69 (defmethod make-style-font ((style gui-style-ftgl))
70 (font-ftgl-ensure (mode style) (face style) (gui-style-size style)))
71
72 (defun ftgl-debug ()
73 (let (*tkw*)
74 (with-styles (
75 (make-instance 'gui-style-ftgl
76 :id :button
77 :face *gui-style-button-face*
78 :sizes '(12 12 12 12 12)
79 :text-color +white+)
80 (make-instance 'gui-style-ftgl
81 :id :label
82 :face *gui-style-button-face*
83 :sizes '(14 14 14 14 14)
84 :text-color +white+)
85 (make-instance 'gui-style-ftgl
86 :id :unique
87 :face *gui-style-button-face*
88 :sizes '(24 24 24 24 24)
89 :text-color +white+)
90 (make-instance 'gui-style-ftgl
91 :id :unique2
92 :face *gui-style-button-face*
93 :sizes '(18 18 18 18 18)
94 :text-color +white+)
95 (make-instance 'gui-style-ftgl
96 :id :default
97 :mode :texture
98 :face *gui-style-button-face*
99 :sizes '(14 9 14 14 14)
100 :text-color +green+))
101 (run-cello-window 'ftgl-window
102 (lambda ()
103 ;;; -- not sure how much of this new reset stuff is necessary ---
104 (kt-opengl-init)
105 (cl-ftgl-reset)
106 (cl-ftgl-init))))))
107
108 (defmodel ftgl-window (cello-window)
109 ()
110 (:default-initargs
111 :ll 0 :lt 0
112 :lr (c-in (scr2log 900))
113 :lb (c-in (scr2log -900))
114 :md-name :ftgl-w
115 :title$ "Hello, ftgl"
116 :skin nil
117 :lighting :off
118 :pre-layer (c? (with-layers +blue+ :off))
119 :clipped nil
120 :kids (c? (the-kids
121 (a-stack (:md-name :ftgl-debug :spacing (upts 10) :px 0 :py (downs (uin 1))
122 :justify :left
123 :outset (u8ths 1))
124 (loop for s in (list "hell" ;;"hlwr" ;;"hlwr 1212"
125 "hi2"
126 "hello, world 222" "1212"
127 )
128 for n upfrom 0
129 collecting (mk-part :sample (ix-text)
130 :lighting :off
131 :text$ s
132 :style-id :unique
133 :fm-parent *parent*
134 :pre-layer (c? (with-layers (:rgba (if (^mouse-over?)
135 +red+ +blue+)))))))))))
136 #+(or)
137 (ftgl-test)
138
139 #+vestigial?
140 (defun ftgl-test ()
141 (cl-ftgl-init)
142 (let ((fns (mapcar (lambda (p)
143 (pathname-name p))
144 (butlast (directory *font-directory-path*) 0)))
145 (cols 8))
146 (flet ((mk-font-show (col-no row-no)
147 (when (nth (+ (* cols row-no) col-no) fns)
148 (mk-part :ftest (font-id)
149 :font-pathname (c? (let ((row-no (kid-no self)))
150 (eko (nil "font show")
151 (elt fns (+ (* cols row-no) col-no)))))))))
152 (a-stack (:md-name :ftgl-test :spacing (upts 10) :px 0 :py (uin 1)
153 :value (c-in (car fns))
154 :justify :left
155 :outset (u8ths 1))
156 (a-stack (:lb (downs (upts 64))
157 :justify :center
158 :outset (upts 8)
159 :pre-layer (c? (when (value (fm-other :ftgl-test))
160 (with-layers
161 :on +gray+ (:frame-3d :edge-sunken
162 :thickness (u96ths 4))
163 :off +white+ :fill +black+))))
164 (loop for line below 2
165 collect (mk-part :sample (ix-text)
166 :lighting :off
167 :text$ (nth line
168 (list "Ah, would that the Gods had this gift to gie us,"
169 "to see ourselves as others see us"))
170 :style nil
171 :pre-layer (with-layers +black+)
172 :text-font (c? (font-ftgl-ensure
173 (car (value (fm-other :mode)))
174 (intern (value (fm-other :ftgl-test)))
175 18 ;; (* 12 (1+ (mod x 4)))
176 )))))
177 (mk-part :mode (ct-radio-row)
178 :spacing (upts 4)
179 :value (c-in (list :texture))
180 :clipped nil
181 :kids (c? (loop for mode in '(:bitmap :pixmap :texture :outline :polygon :extruded)
182 collect (mk-part :rb (ct-radio-labeled)
183 :associated-value mode
184 :title$ (string-capitalize
185 (format nil "~d" mode))))))
186 (mk-part :ftgrow (ix-row)
187 :pre-layer (with-layers +white+ :fill)
188 :kids (c? (the-kids
189 (loop repeat cols
190 collecting
191 (mk-part :fstk (ix-inline)
192 :orientation :vertical
193 :kids (c? (let ((col-no (kid-no self)))
194 (loop for row-no below (ceiling (length fns) cols)
195 when (mk-font-show col-no row-no)
196 collect it))))))))))))
197
198
199 (defmethod ix-align-text (self (font ftgl-pixmap))
200 (ecase (justify-hz self)
201 (:left)
202 (:center
203 (ogl-pen-move (round (- (l-width self) (^text-width)) 2) 0))
204 (:right
205 (ogl-pen-move (- (l-width self) (v2-h (inset self)) (^text-width)) 0))))
206
207 (defmethod ix-align-text (self (font ftgl-bitmap))
208 (ecase (justify-hz self)
209 (:left)
210 (:center
211 (ogl-pen-move (round (- (l-width self) (^text-width)) 2) 0))
212 (:right
213 (ogl-pen-move (- (l-width self) (v2-h (inset self)) (^text-width)) 0))))
214
215 (defmethod ix-render-in-font :around ((font ftgl) self)
216 (bwhen (t$ (display-text$ self))
217 (ix-align-text self font)
218
219 (if (ogl-get-boolean gl_current_raster_position_valid)
220 (call-next-method)
221 (trc "rasterpos offscreen" self :g-offset (g-offset self)))))
222
223 (defmethod ix-render-in-font ((font ftgl) self)
224 (count-it :render-in-font)
225 (ftgl-render font (display-text$ self)))
226
227 (defmethod ix-render-in-font ((font ftgl-outline) self)
228 (with-attrib (gl_enable_bit gl_hint_bit gl_line_bit gl_color_buffer_bit)
229 (gl-disable gl_texture_2d)
230 (gl-enable gl_line_smooth)
231 (gl-hint gl_line_smooth_hint gl_dont_care)
232 (gl-enable gl_blend)
233 (gl-blend-func gl_src_alpha gl_one_minus_src_alpha)
234 (ftgl-render font (display-text$ self))))
235
236 (defmethod ix-render-in-font ((font ftgl-texture) self)
237 (let* ((t$ (display-text$ self)))
238 (trc nil "ix-render-in-font ftgl-texture" :pxy (pxy self) (l-rect self) t$)
239
240 #+youarehere
241 (let ((ll (^ll))(lr (^lr))(lt (^lt))(lb (^lb))) ;; keep outside gl-begun since can kick off FTGL glyph build
242 ;(gl-color3f 0 0 0)
243 (gl-line-width 1)
244 (with-gl-begun (gl_lines)
245 (gl-vertex3f 0 0 0)(gl-vertex3f ll 0 0)
246 (gl-vertex3f 0 0 0)(gl-vertex3f lr 0 0)
247 (gl-vertex3f 0 0 0)(gl-vertex3f 0 lt 0)
248 (gl-vertex3f 0 0 0)(gl-vertex3f 0 lb 0)
249 ))
250
251 (gl-enable gl_texture_2d)
252 (trc nil "(gl-is-enabled gl_texture_2d)!!!!!!!" (gl-is-enabled gl_texture_2d)
253 (ogl-get-boolean gl_texture_2d))
254 ;;(assert (ogl-get-boolean gl_texture_2d))
255 (gl-disable gl_lighting)
256 (gl-enable gl_blend)
257 (gl-blend-func gl_src_alpha gl_one_minus_src_alpha)
258 (gl-polygon-mode gl_front_and_back gl_fill)
259
260
261
262 (when (zoom self)
263 (apply 'gl-scalef (zoom self)))
264
265 (when (rotation self)
266 (apply 'gl-rotatef (rotation self)))
267
268 (ftgl-render font t$)))
269
270 ;;;(defmethod not-to-be :after ((w window))
271 ;;; (loop for font-entry in (w-fonts w)
272 ;;; for ff = (cdr font-entry)
273 ;;; do (bwhen (cfont (ftgl-ifont ff))
274 ;;; (trc nil "freeing ff" ff cfont)
275 ;;; (fgc-free cfont))))
276

  ViewVC Help
Powered by ViewVC 1.1.5