1 ;;;; output-gnome.scm -- implement GNOME canvas output
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004--2006 Jan Nieuwenhuizen <janneke@gnu.org>
9 ;;;; * .cff MUST NOT be in fc's fontpath.
10 ;;;; - workaround: remove mf/out from ~/.fonts.conf,
11 ;;;; instead add ~/.fonts and symlink all /mf/out/*otf there.
12 ;;;; - bug in fontconfig/freetype/pango?
14 ;;; * check: blot+scaling
15 ;;; * Figure out and fix font scaling and character placement
16 ;;; * EC font package: add missing X font directories and AFMs
17 ;;; * User-interface, keybindings
18 ;;; * Implement missing stencil functions
19 ;;; * Implement missing commands
20 ;;; * More information in stencils, e.g., location and grob tag.
22 ;;; - allow GnomeCanvas or `toplevel' GtkWindow to be created
23 ;;; outside of LilyPond
25 ;;; * Release schedule and packaging of dependencies.
26 ;;; - g-wrap-1.9.3 is already in incoming.
27 ;;; - guile-gnome-platform-2.8.0 will probably be packaged early 2005.
31 ;;; * Rotty's g-wrap >= 1.9.3
32 ;;; * guile-gnome-platform >= 2.7.97
35 ;;; See also: guile-gtk-general@gnu.org
39 ;;; * Install gnome/gtk and libffi development stuff
41 ;;; * Install [pango, g-wrap and] guile-gnome from source,
42 ;;; see buildscripts/guile-gnome.sh
44 ;;; * Build LilyPond with gui support: configure --enable-gui
46 ;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond,
47 ;;; tell fontconfig about the feta fonts dir and run fc-cache
49 cat > ~/.fonts.conf << EOF
51 <dir>~/cvs/savannah/lilypond/mf/out</dir>
52 <dir>/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced</dir>
57 ;;; or copy all your .pfa/.pfb's to ~/.fonts if your fontconfig
58 ;;; already looks there for fonts. Check if it works by doing:
60 fc-list | grep -i lily
63 ;;; * Setup environment
65 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
66 export LD_LIBRARY_PATH=$HOME/usr/pkg/pango/lib:$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
67 export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f'
69 ;;; * Also for GNOME point-and-click, you need to set XEDITOR and add
71 #(ly:set-point-and-click 'line-column)
77 lilypond -fgnome input/simple-song.ly
79 ;;; point-and-click: (mouse-1) click on a graphical object;
80 ;;; grob-property-list: (mouse-3) click on a graphical object.
82 (define-module (scm output-gnome))
83 (define this-module (current-module))
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96 ;;; set by framework-gnome.scm
97 (define canvas-root #f)
98 (define output-scale #f)
100 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 ((< i #x80) (list (integer->char i)))
106 ((< i #x800) (map integer->char
107 (list (+ #xc0 (quotient i #x40))
108 (+ #x80 (modulo i #x40)))))
110 (let ((x (quotient i #x1000))
111 (y (modulo i #x1000)))
114 (+ #x80 (quotient y #x40))
115 (+ #x80 (modulo y #x40))))))
116 (else (begin (stderr "programming-error: utf-8 too big:~x\n" i)
117 (list (integer->char 32))))))
119 (define (integer->utf-8-string integer)
120 (list->string (utf-8 integer)))
122 (define (char->utf-8-string char)
123 (list->string (utf-8 (char->integer char))))
125 (define (string->utf-8-string string)
128 (map (lambda (x) (char->utf-8-string x)) (string->list string))))
130 (define (music-font? font)
131 (let ((family (car (font-name-style font))))
132 (string=? (substring family 0 (min (string-length family) 10))
135 ;;; FONT may be font smob, or pango font string
136 (define (pango-font-name font)
138 (list font "Regular")
139 (apply format (append '(#f "~a, ~a") (font-name-style font)))))
141 ;;; FONT may be font smob, or pango font string
142 (define (canvas-font-size font)
147 (* output-scale (modified-font-metric-font-scaling font)))))
149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
150 ;;; Wrappers from guile-gnome TLA
151 ;;; guile-gnome-devel@gnu.org--2004
152 ;;; http://arch.gna.org/guile-gnome/archive-2004
154 ;;; janneke@gnu.org--2004-gnome
155 ;;; http://lilypond.org/~janneke/{arch}/2004-gnome
157 (if (not (defined? '<gnome-canvas-path-def>))
159 (define-class <gnome-canvas-path-def> (<gobject>)
160 (closure #:init-value (gnome-canvas-path-def-new)
161 #:init-keyword #:path-def
162 #:getter get-def #:setter set-def))
164 (define-method (moveto (this <gnome-canvas-path-def>) x y)
165 (gnome-canvas-path-def-moveto (get-def this) x y))
166 (define-method (curveto (this <gnome-canvas-path-def>) x1 y1 x2 y2 x3 y3)
167 (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3))
168 (define-method (lineto (this <gnome-canvas-path-def>) x y)
169 (gnome-canvas-path-def-lineto (get-def this) x y))
170 (define-method (closepath (this <gnome-canvas-path-def>))
171 (gnome-canvas-path-def-closepath (get-def this)))
172 (define-method (reset (this <gnome-canvas-path-def>))
173 (gnome-canvas-path-def-reset (get-def this)))
175 (define -set-path-def set-path-def)
176 (define -get-path-def get-path-def)
178 (define-method (set-path-def (this <gnome-canvas-shape>)
179 (def <gnome-canvas-path-def>))
180 (-set-path-def this (get-def def)))
182 (define-method (get-path-def (this <gnome-canvas-shape>))
183 (make <gnome-canvas-path-def> #:path-def (-get-path-def this)))))
185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186 ;;; stencil outputters
189 ;;; catch-all for missing stuff
190 ;;; comment this out to see find out what functions you miss :-)
191 (define (dummy . foo) #f)
192 (map (lambda (x) (module-define! this-module x dummy))
194 (ly:all-stencil-expressions)
195 (ly:all-output-backend-commands)))
198 (define (bezier-sandwich lst thick)
199 (let* ((def (make <gnome-canvas-path-def>))
200 (bezier (make <gnome-canvas-bpath>
201 #:parent (canvas-root)
203 #:outline-color "black"
205 #:join-style 'round)))
209 ;; FIXME: LST is pre-mangled for direct ps stack usage
213 (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
214 (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0)))
215 (car (list-ref lst 1)) (- (cdr (list-ref lst 1)))
216 (car (list-ref lst 2)) (- (cdr (list-ref lst 2))))
218 (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7))))
219 (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4)))
220 (car (list-ref lst 5)) (- (cdr (list-ref lst 5)))
221 (car (list-ref lst 6)) (- (cdr (list-ref lst 6))))
222 (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3))))
225 (set-path-def bezier def)
228 (define (char font i)
229 (text font (ly:font-index-to-charcode font i)))
231 (define (dashed-line thick on off dx dy)
232 (draw-line thick 0 0 dx dy))
234 (define (draw-line thick x1 y1 x2 y2)
235 (let* ((def (make <gnome-canvas-path-def>))
236 (props (make <gnome-canvas-bpath>
237 #:parent (canvas-root)
239 #:outline-color "black"
240 #:width-units thick)))
242 (moveto def x1 (- y1))
243 (lineto def x2 (- y2))
244 (set-path-def props def)
248 ;; FIXME: the framework-gnome backend needs to see every item that
249 ;; gets created. All items created here must should be put in a group
250 ;; that gets returned.
251 (define (glyph-string font postscript-font-name w-x-y-named-glyphs)
255 ;; UGR, glyph names not found
256 (stderr "GLYPH:~S\n" (caddr x))
257 (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x)))
258 (placebox (cadr x) (caddr x)
259 (make <gnome-canvas-text>
260 #:parent (canvas-root)
261 ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69)
264 #:font (pango-font-name font)
265 #:size-points (canvas-font-size font)
268 (integer->utf-8-string
269 (ly:font-glyph-name-to-charcode font (cadddr x))))))
272 (define (grob-cause offset grob)
276 (define (named-glyph font name)
277 (text font (ly:font-glyph-name-to-charcode font name)))
279 (define (placebox x y expr)
282 ;; FIXME ugly hack to skip #unspecified ...
283 (if (and item (not (eq? item (if #f #f))))
285 (move item (* output-scale x) (* output-scale (- y)))
286 (affine-relative item output-scale 0 0 output-scale 0 0)
290 (define (polygon coords blot-diameter)
291 (let* ((def (make <gnome-canvas-path-def>))
292 (props (make <gnome-canvas-bpath>
293 #:parent (canvas-root)
295 #:outline-color "black"
297 #:width-units blot-diameter)
298 (points (ly:list->offsets '() coords))
299 (last-point (car (last-pair points))))
302 (moveto def (car last-point) (cdr last-point))
303 (for-each (lambda (x) (lineto def (car x) (cdr x))) points)
305 (set-path-def props def)
308 (define (round-filled-box breapth width depth height blot-diameter)
309 (let ((r (/ blot-diameter 2)))
310 (make <gnome-canvas-rect>
311 #:parent (canvas-root)
312 #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height)
314 #:outline-color "black"
315 #:width-units blot-diameter
316 #:join-style 'round)))
318 (define (text font s)
319 (make <gnome-canvas-text>
320 #:parent (canvas-root)
322 #:x 0.0 #:y (if (music-font? font) 0.15 0.69)
323 #:anchor (if (music-font? font) 'west 'south-west)
324 #:font (pango-font-name font)
325 #:size-points (canvas-font-size font)
327 #:text (if (integer? s)
328 (integer->utf-8-string s)
329 (string->utf-8-string s))))
331 (define (utf-8-string pango-font-description string)
332 (make <gnome-canvas-text>
333 #:parent (canvas-root)
336 #:font pango-font-description
337 #:size-points (canvas-font-size pango-font-description)