1 ;;;; output-gnome.scm -- implement GNOME canvas output
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
7 ;;; HIP -- hack in progress
11 ;;; * guile-1.6.4 (NOT CVS)
12 ;;; * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4.
14 ;;; see also: guile-gtk-general@gnu.org
18 ;;; * If using GUILE CVS , then compile LilyPond with GUILE 1.6,
20 ;;; PATH=/usr/bin/:$PATH ./configure --enable-config=g16 ; make conf=g16
22 ;;; * Install gnome/gtk development stuff and g-wrap, guile-gnome
23 ;;; see buildscripts/guile-gnome.sh
25 ;;; * Use latin1 encoding for gnome backend, do
28 ./configure --prefix=$(pwd) --enable-config=g16
29 make -C mf conf=g16 clean
30 make -C mf conf=g16 ENCODING_FILE=$(kpsewhich cork.enc)
31 (cd mf/out-g16 && mkfontdir)
32 xset +fp $(pwd)/mf/out-g16
35 ;;; * Setup environment
37 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
38 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib
39 export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f'
41 ;;; * For GNOME point-and-click, add
42 ;;; #(ly:set-point-and-click 'line-column)
43 ;;; to your .ly; just click an object on the canvas.
47 lilypond-bin -fgnome input/simple-song.ly
52 ;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and
54 ;;; - wait for/help with pango 1.6
55 ;;; - convert feta to OpenType (CFF) or TrueType (fontforge?)
56 ;;; - hack feta20/feta20.pfa?:
57 ;;; * font, canvas, scaling?
58 ;;; * implement missing stencil functions
59 ;;; * implement missing commands
60 ;;; * user-interface, keybindings
61 ;;; * cleanups: (too many) global vars
62 ;;; * papersize, outputscale from book
65 ;;; SCRIPT moved to buildscripts/guile-gnome.sh
69 (debug-enable 'backtrace)
71 (define-module (scm output-gnome))
73 (define this-module (current-module))
81 (gnome gtk gdk-event))
83 ;; the name of the module will change to canvas rsn
84 (if (resolve-module '(gnome gw canvas))
85 (use-modules (gnome gw canvas))
86 (use-modules (gnome gw libgnomecanvas)))
88 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
90 (define-public (gnome-output-expression expr port)
91 (display (dispatch expr) port))
93 (define (dispatch expr)
95 (let ((keyword (car expr)))
97 ((eq? keyword 'some-func) "")
98 ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
100 (if (module-defined? this-module keyword)
101 (apply (eval keyword this-module) (cdr expr))
104 (string-append "undefined: " (symbol->string keyword) "\n"))
108 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
109 ;;; Lily output interface --- fix silly names and docme
111 The output interface has functions for
112 * formatting stencils, and
129 The Bare minimum interface for \score { \notes c } } should
132 INTERFACE-output-expression
137 and should intercept:
140 (define (dummy . foo) #f)
142 ;; minimal intercept list:
143 (define output-interface-intercept
148 (map (lambda (x) (module-define! this-module x dummy))
149 output-interface-intercept)
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
155 (define main-window #f)
156 (define main-scrolled #f)
157 (define main-canvas #f)
158 (define page-number 0)
160 (define page-stencils #f)
161 (define output-canvas #f)
163 (define system-origin '(0 . 0))
166 (define item-locations (make-hash-table 31))
169 (define button-height 25)
170 (define canvas-width 2000)
171 (define canvas-height 4000)
173 (define window-width 400)
174 (define window-height
175 (inexact->exact (round (* 1.42 window-width))))
177 (define font-paper #f)
179 ;;; output-scale and font-size fun
181 (define USED-TO-BE-OUTPUT-SCALE 2.83464566929134)
182 ;; However, it seems that we currently have:
183 (define 2.3.4-OUTPUT-SCALE 1.75729901757299)
184 ;; to go from ly-units to <MM/points/whatever?>
185 ;; Hmm, is this the source of font size problems wrt titling's right margin?
187 ;;(define pixels-per-unit 1.0)
188 ;;(define ARBITRARY-OUTPUT-SCALE 5)
190 ;; Anyway, for on-screen this does not matter: 2 * 2.5 looks fine
191 (define pixels-per-unit 2.0)
192 (define ARBITRARY-OUTPUT-SCALE 2.5)
194 ;;(define output-scale (* OUTPUT-SCALE pixels-per-unit))
195 (define output-scale (* ARBITRARY-OUTPUT-SCALE pixels-per-unit))
198 ;; helper functions -- sort this out
199 (define (stderr string . rest)
203 (apply format (cons (current-error-port) (cons string rest)))
204 (force-output (current-error-port)))))
208 ((< i #x80) (make-string 1 (integer->char i)))
209 ((< i #x800) (list->string
211 (list (+ #xc0 (quotient i #x40))
212 (+ #x80 (modulo i #x40))))))
214 (let ((x (quotient i #x1000))
215 (y (modulo i #x1000)))
219 (+ #x80 (quotient y #x40))
220 (+ #x80 (modulo y #x40)))))))
223 (define (custom-utf8 i)
226 (utf8 (+ #xee00 i))))
229 (define (draw-rectangle x1 y1 x2 y2 color width-units)
230 (make <gnome-canvas-rect>
231 #:parent (root main-canvas) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
232 #:fill-color color #:width-units width-units))
235 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
236 ;;;; stencil outputters
239 (define (char font i)
240 (text font (utf8 i)))
242 (define (placebox x y expr)
243 (stderr "item: ~S\n" expr)
246 ;; FIXME ugly hack to skip #unspecified ...
247 (if (and item (not (eq? item (if #f #f))))
250 (* output-scale (+ (car system-origin) x))
251 (* output-scale (- (car system-origin) y)))
252 (affine-relative item output-scale 0 0 output-scale 0 0)
254 (gtype-instance-signal-connect item 'event item-event)
256 (hashq-set! item-locations item location))
260 (define (round-filled-box breapth width depth height blot-diameter)
261 ;; FIXME: no rounded corners on rectangle...
263 (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
265 (define (pango-font-name font)
267 ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
268 "lilypond-feta, regular 32")
271 ;;(ly:font-name font))))
272 ;;(ly:font-filename font))))
274 (define (pango-font-size font)
275 (let* ((designsize (ly:font-design-size font))
276 (magnification (* (ly:font-magnification font)))
278 ;; experimental sizing:
279 ;; where does factor come from?
281 ;; 0.435 * (12 / 20) = 0.261
282 ;; 2.8346456692913/ 0.261 = 10.86071137659501915708
283 ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit)))
287 (scaling (* ops magnification designsize)))
288 (stderr "OPS:~S\n" ops)
289 (stderr "scaling:~S\n" scaling)
290 (stderr "magnification:~S\n" magnification)
291 (stderr "design:~S\n" designsize)
295 ;;font-name: "GNU-LilyPond-feta-20"
296 ;;font-filename: "feta20"
297 ;;pango-font-name: "lilypond-feta, regular 32"
299 ;;scaling:29.7046771653543
300 ;;magnification:0.569055118110236
303 (define (text font string)
304 (stderr "font-name: ~S\n" (ly:font-name font))
305 ;; TODO s/filename/file-name/
306 (stderr "font-filename: ~S\n" (ly:font-filename font))
308 (stderr "pango-font-name: ~S\n" (pango-font-name font))
309 (stderr "pango-font-size: ~S\n" (pango-font-size font))
313 (make <gnome-canvas-text>
314 #:parent (root main-canvas)
316 ;; experimental text placement corrections.
317 ;; UGHR? What happened to tex offsets? south-west?
318 ;; is pango doing something 'smart' wrt baseline ?
324 ;;#:x 0.015 #:y -3.71
326 #:font (pango-font-name font)
328 #:size-points (pango-font-size font)
332 ;;apparently no effect :-(
341 (define (filledbox a b c d)
342 (round-filled-box a b c d 0.001))
344 ;; WTF is this in every backend?
345 (define (horizontal-line x1 x2 thickness)
346 ;;(let ((thickness 2))
347 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
349 ;; origin -- bad name
350 (define (define-origin file line col)
351 ;; ughr, why is this not passed as [part of] stencil object
352 (set! location (if (procedure? point-and-click)
353 ;; duh, only silly string append
354 ;; (point-and-click line col file)
358 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
359 ;;;; gnome stuff --- move to framework-gnome
360 (define (dump-page number)
361 (if (or (not page-stencils)
363 (>= number (vector-length page-stencils)))
364 (stderr "No such page: ~S\n" (1+ number))
366 (let* ((old-canvas main-canvas)
367 (canvas (new-canvas)))
368 (set! page-number number)
370 ;; no destroy method for gnome-canvas-text?
371 ;;(map destroy (gtk-container-get-children main-canvas))
372 ;;(map destroy text-items)
375 ;;(set! main-canvas canvas)
376 (set! text-items '())
377 (ly:outputter-dump-stencil output-canvas
378 (vector-ref page-stencils page-number))
380 (if old-canvas (destroy old-canvas))
381 (add main-scrolled canvas)
385 (define (get-x-editor)
387 (set! x-editor (getenv "XEDITOR")))
393 (set! ifs (getenv "IFS")))
398 (define (spawn-editor location)
399 (let* ((line (car location))
400 (column (cadr location))
401 (file-name (caddr location))
402 (template (substring (get-x-editor) 0))
404 ;; Adhere to %l %c %f?
406 (regexp-substitute/global
407 #f "%l" (regexp-substitute/global
409 (regexp-substitute/global
410 #f "%f" template 'pre file-name 'post)
411 'pre (number->string column)
413 'pre (number->string line) 'post)))
415 (stderr "spawning: ~s\n" command)
416 (if (= (primitive-fork) 0)
417 (let ((command-list (string-split command #\ )));; (get-ifs))))
418 (apply execlp command-list)
421 (define location-callback spawn-editor)
423 (define (item-event item event . data)
424 (case (gdk-event:type event)
425 ((enter-notify) (gobject-set-property item 'fill-color "red"))
426 ((leave-notify) (gobject-set-property item 'fill-color "black"))
428 (let ((location (hashq-ref item-locations item #f)))
430 (location-callback location)
431 (stderr "no location\n"))))
432 ((2button-press) (gobject-set-property item 'fill-color "red")))
435 ;; TODO: one list per-page
436 (define text-items '())
437 (define (scale-canvas factor)
438 (set! pixels-per-unit (* pixels-per-unit factor))
439 (set-pixels-per-unit main-canvas pixels-per-unit)
442 (let ((scale (gobject-get-property x 'scale))
443 (points (gobject-get-property x 'size-points)))
444 ;;(gobject-set-property x 'scale pixels-per-unit)
445 (gobject-set-property x 'size-points (* points factor))))
448 (define (key-press-event item event . data)
449 (let ((keyval (gdk-event-key:keyval event))
450 (mods (gdk-event-key:modifiers event)))
451 (cond ((and (or (eq? keyval gdk:q)
453 (equal? mods '(control-mask modifier-mask)))
455 ((and #t ;;(null? mods)
456 (eq? keyval gdk:plus))
458 ((and #t ;; (null? mods)
459 (eq? keyval gdk:minus))
461 ((or (eq? keyval gdk:Page-Up)
462 (eq? keyval gdk:BackSpace))
463 (dump-page (1- page-number)))
464 ((or (eq? keyval gdk:Page-Down)
465 (eq? keyval gdk:space))
466 (dump-page (1+ page-number))))
469 (define (papersize window paper)
470 (let* ((hsize (ly:output-def-lookup paper 'hsize))
471 (vsize (ly:output-def-lookup paper 'vsize))
472 (width (inexact->exact (ceiling (* output-scale hsize))))
473 (height (inexact->exact (ceiling (* output-scale vsize))))
474 (max-width (gdk-screen-width))
475 (max-height (gdk-screen-height))
479 (set! max-height (- max-height 80))
481 (stderr "bookpaper-outputscale:~S\n" (ly:bookpaper-outputscale paper))
484 ;;(set! OUTPUT-SCALE (ly:bookpaper-outputscale paper))
485 ;;(set! output-scale (* OUTPUT-SCALE pixels-per-unit))
489 (set! window-width (min (+ scrollbar-size (* width 2)) max-width))
490 (set! window-height (min (+ button-height scrollbar-size (* height 2))
493 (set! canvas-width width)
494 (set! canvas-height height)))
498 (let* ((canvas (make <gnome-canvas>))
499 (root (root canvas)))
501 (set-size-request canvas window-width window-height)
502 (set-scroll-region canvas 0 0 canvas-width canvas-height)
504 (set-pixels-per-unit canvas pixels-per-unit)
506 (set! main-canvas canvas)
507 (draw-rectangle 0 0 canvas-width canvas-height "white" 0)
511 (define (main outputter bookpaper pages)
512 (let* ((window (make <gtk-window> #:type 'toplevel))
513 (button (make <gtk-button> #:label "Exit"))
514 (next (make <gtk-button> #:label "Next"))
515 (prev (make <gtk-button> #:label "Previous"))
516 (vbox (make <gtk-vbox> #:homogeneous #f))
517 (hbox (make <gtk-hbox> #:homogeneous #f))
518 (scrolled (make <gtk-scrolled-window>))
519 (canvas (new-canvas)))
521 (papersize window bookpaper)
522 (set-size-request window window-width window-height)
526 (add scrolled canvas)
529 (set-size-request hbox window-width button-height)
530 (set-child-packing vbox hbox #f #f 0 'end)
532 (set-child-packing hbox button #f #f 0 'end)
533 (set-size-request button (quotient window-width 2) button-height)
539 (gtype-instance-signal-connect button 'clicked
540 (lambda (b) (gtk-main-quit)))
541 (gtype-instance-signal-connect next 'clicked
542 (lambda (b) (dump-page (1+ page-number))))
543 (gtype-instance-signal-connect prev 'clicked
544 (lambda (b) (dump-page (1- page-number))))
546 (gtype-instance-signal-connect window 'key-press-event key-press-event)
549 ;; HMMM. Make some class for these vars?
550 (set! main-window window)
551 (set! main-scrolled scrolled)
552 (set! output-canvas outputter)
553 (set! page-stencils pages)