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
67 (debug-enable 'backtrace)
69 ;;(define-module (scm output-gnome))
70 (define-module (scm output-gnome)
83 (define this-module (current-module))
93 ;; Hmm, <gnome-outputter> is not imported -- but trying this breaks
94 ;; framework-gnome in a weird way.
95 ;;(scm framework-gnome))
98 ;; the name of the module will change to canvas rsn
99 (if (resolve-module '(gnome gw canvas))
100 (use-modules (gnome gw canvas))
101 (use-modules (gnome gw libgnomecanvas)))
103 ;; ughughughughu ughr huh?? -- defined in framework-gnome
104 (define PIXELS-PER-UNIT 2)
105 (define-class <gnome-outputter> ()
106 (page-stencils ;;#:init-value '#()
107 #:init-keyword #:page-stencils #:accessor page-stencils)
108 (window #:init-value (make <gtk-window> #:type 'toplevel) #:accessor window)
109 (scrolled #:init-value (make <gtk-scrolled-window>) #:accessor scrolled)
110 (canvas #:init-value #f #:accessor canvas)
111 (page-number #:init-value 0 #:accessor page-number)
112 (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit)
113 (text-items #:init-value '() #:accessor text-items)
114 (location #:init-value #:f #:accessor location)
115 (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
116 (window-width #:init-keyword #:window-width #:accessor window-width)
117 (window-height #:init-keyword #:window-height #:accessor window-height)
118 (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width)
119 (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
122 (define (dummy . foo) #f)
124 ;; minimal intercept list:
125 (define output-interface-intercept
130 (map (lambda (x) (module-define! this-module x dummy))
131 output-interface-intercept)
133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
135 ;;; output-scale and font-size fun
137 (define USED-TO-BE-OUTPUT-SCALE 2.83464566929134)
138 ;; However, it seems that we currently have:
139 (define 2.3.4-OUTPUT-SCALE 1.75729901757299)
140 ;; to go from ly-units to <MM/points/whatever?>
141 ;; Hmm, is this the source of font size problems wrt titling's right margin?
143 ;;(define pixels-per-unit 1.0)
144 ;;(define ARBITRARY-OUTPUT-SCALE 5)
146 ;; Anyway, for on-screen this does not matter: 2 * 2.5 looks fine
147 (define pixels-per-unit 2.0)
148 (define ARBITRARY-OUTPUT-SCALE 2.5)
150 ;;(define output-scale (* OUTPUT-SCALE pixels-per-unit))
151 (define output-scale (* ARBITRARY-OUTPUT-SCALE pixels-per-unit))
155 ;; helper functions -- sort this out
156 (define (stderr string . rest)
160 (apply format (cons (current-error-port) (cons string rest)))
161 (force-output (current-error-port)))))
165 ((< i #x80) (make-string 1 (integer->char i)))
166 ((< i #x800) (list->string
168 (list (+ #xc0 (quotient i #x40))
169 (+ #x80 (modulo i #x40))))))
171 (let ((x (quotient i #x1000))
172 (y (modulo i #x1000)))
176 (+ #x80 (quotient y #x40))
177 (+ #x80 (modulo y #x40)))))))
180 (define (custom-utf8 i)
183 (utf8 (+ #xee00 i))))
185 (define (draw-rectangle x1 y1 x2 y2 color width-units)
186 (make <gnome-canvas-rect>
187 #:parent (root (canvas global-go)) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
188 #:fill-color color #:width-units width-units))
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
192 ;;;; stencil outputters
195 (define (char font i)
196 (text font (utf8 i)))
198 (define system-origin '(0 . 0))
199 (define (placebox x y expr)
200 (stderr "item: ~S\n" expr)
203 ;; FIXME ugly hack to skip #unspecified ...
204 (if (and item (not (eq? item (if #f #f))))
207 (* output-scale (+ (car system-origin) x))
208 (* output-scale (- (car system-origin) y)))
209 (affine-relative item output-scale 0 0 output-scale 0 0)
211 (gtype-instance-signal-connect item 'event item-event)
212 (if (location global-go)
213 (hashq-set! (item-locations global-go) item (location global-go)))
217 (define (round-filled-box breapth width depth height blot-diameter)
218 ;; FIXME: no rounded corners on rectangle...
220 (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
222 (define (pango-font-name font)
224 ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
225 "lilypond-feta, regular 32")
228 ;;(ly:font-name font))))
229 ;;(ly:font-filename font))))
231 (define (pango-font-size font)
232 (let* ((designsize (ly:font-design-size font))
233 (magnification (* (ly:font-magnification font)))
235 ;; experimental sizing:
236 ;; where does factor come from?
238 ;; 0.435 * (12 / 20) = 0.261
239 ;; 2.8346456692913/ 0.261 = 10.86071137659501915708
240 ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit)))
244 (scaling (* ops magnification designsize)))
245 (stderr "OPS:~S\n" ops)
246 (stderr "scaling:~S\n" scaling)
247 (stderr "magnification:~S\n" magnification)
248 (stderr "design:~S\n" designsize)
252 ;;font-name: "GNU-LilyPond-feta-20"
253 ;;font-filename: "feta20"
254 ;;pango-font-name: "lilypond-feta, regular 32"
256 ;;scaling:29.7046771653543
257 ;;magnification:0.569055118110236
260 (define (text font string)
261 (stderr "font-name: ~S\n" (ly:font-name font))
262 ;; TODO s/filename/file-name/
263 (stderr "font-filename: ~S\n" (ly:font-filename font))
265 (stderr "pango-font-name: ~S\n" (pango-font-name font))
266 (stderr "pango-font-size: ~S\n" (pango-font-size font))
268 (make <gnome-canvas-text>
269 #:parent (root (canvas global-go))
271 ;; experimental text placement corrections.
272 ;; UGHR? What happened to tex offsets? south-west?
273 ;; is pango doing something 'smart' wrt baseline ?
279 ;;#:x 0.015 #:y -3.71
281 #:font (pango-font-name font)
283 #:size-points (pango-font-size font)
287 ;;apparently no effect :-(
293 (set! (text-items global-go) (cons item (text-items global-go)))
296 (define (filledbox a b c d)
297 (round-filled-box a b c d 0.001))
299 ;; WTF is this in every backend?
300 (define (horizontal-line x1 x2 thickness)
301 ;;(let ((thickness 2))
302 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
304 ;; origin -- bad name
305 (define (define-origin file line col)
306 ;; ughr, why is this not passed as [part of] stencil object
307 (set! (location global-go) (if (procedure? point-and-click)
308 ;; duh, only silly string append
309 ;; (point-and-click line col file)
316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
317 ;;;; gnome stuff --- move to framework-gnome
318 ;;(define (dump-page (go <gnome-outputter>) number)
322 (define SCROLLBAR-SIZE 20)
323 (define BUTTON-HEIGHT 25)
324 (define PANELS-HEIGHT 80)
326 (define PIXELS-PER-UNIT 2)
327 (define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
329 ;; helper functions -- sort this out
330 (define (stderr string . rest)
334 (apply format (cons (current-error-port) (cons string rest)))
335 (force-output (current-error-port)))))
338 ;; Hmm, actually, the only vars really needed by output-gnome are
339 ;; * (root (canvas go))
345 ;; so this class could be split in two parts / records?
346 (define-class <gnome-outputter> ()
347 (page-stencils ;;#:init-value '#()
348 #:init-keyword #:page-stencils #:accessor page-stencils)
349 (window #:init-value (make <gtk-window> #:type 'toplevel) #:accessor window)
350 (scrolled #:init-value (make <gtk-scrolled-window>) #:accessor scrolled)
351 (canvas #:init-value #f #:accessor canvas)
352 (page-number #:init-value 0 #:accessor page-number)
353 (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit)
354 (text-items #:init-value '() #:accessor text-items)
355 (location #:init-value #:f #:accessor location)
356 (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
357 (window-width #:init-keyword #:window-width #:accessor window-width)
358 (window-height #:init-keyword #:window-height #:accessor window-height)
359 (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width)
360 (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
362 ;;(define-method (initialize (go <gnome-outputter>))
366 (define (gnome-main book)
367 (let* ((book-paper (ly:paper-book-book-paper book))
368 (hsize (ly:output-def-lookup book-paper 'hsize))
369 (vsize (ly:output-def-lookup book-paper 'vsize))
370 (page-width (inexact->exact (ceiling (* OUTPUT-SCALE hsize))))
371 (page-height (inexact->exact (ceiling (* OUTPUT-SCALE vsize))))
372 ;;(page-width (inexact->exact (ceiling hsize)))
373 ;;(page-height (inexact->exact (ceiling vsize)))
375 (screen-width (gdk-screen-width))
376 (screen-height (gdk-screen-height))
377 (desktop-height (- screen-height PANELS-HEIGHT))
379 (go (make <gnome-outputter>
380 #:page-stencils (list->vector (ly:paper-book-pages book))
381 #:canvas-width page-width
382 #:canvas-height page-height
384 ;; huh, *2 -- pixels-per-unit?
385 (min (+ SCROLLBAR-SIZE (* page-width 2)) screen-width)
387 (min (+ BUTTON-HEIGHT SCROLLBAR-SIZE (* page-height 2))
395 (let* ((button (make <gtk-button> #:label "Exit"))
396 (next (make <gtk-button> #:label "Next"))
397 (prev (make <gtk-button> #:label "Previous"))
398 (vbox (make <gtk-vbox> #:homogeneous #f))
399 (hbox (make <gtk-hbox> #:homogeneous #f)))
401 (set-size-request (window go) (window-width go) (window-height go))
405 (add (window go) vbox)
406 (add vbox (scrolled go))
408 (add (scrolled go) (canvas go))
412 (set-size-request hbox (window-width go) BUTTON-HEIGHT)
415 ;;(set-child-packing vbox hbox #f #f 0 'end)
416 ;;(set-child-packing hbox button #f #f 0 'end)
418 (set-size-request button (quotient (window-width go) 2) BUTTON-HEIGHT)
424 (gtype-instance-signal-connect
425 button 'clicked (lambda (b) (gtk-main-quit)))
426 (gtype-instance-signal-connect
427 next 'clicked (lambda (b) (dump-page go (1+ (page-number go)))))
428 (gtype-instance-signal-connect
429 prev 'clicked (lambda (b) (dump-page go (1- (page-number go)))))
430 (gtype-instance-signal-connect
431 (window go) 'key-press-event key-press-event)
433 (show-all (window go))))
435 (define (dump-page go number)
436 (if (or (not (page-stencils go))
438 (>= number (vector-length (page-stencils go))))
439 (stderr "No such page: ~S\n" (1+ number))
441 (let ((old-canvas (canvas go)))
443 (set! (page-number go) number)
445 ;; no destroy method for gnome-canvas-text?
446 ;;(map destroy (gtk-container-get-children main-canvas))
447 ;;(map destroy text-items)
450 ;;(set! main-canvas canvas)
451 (set! (text-items go) '())
452 ;;(ly:outputter-dump-stencil (outputter go)
453 ;; (vector-ref page-stencils page-number))
455 (stderr "page-stencil ~S: ~S\n"
457 (vector-ref (page-stencils go) (page-number go)))
459 (ly:interpret-stencil-expression
460 ;; ;;(vector-ref (page-stencils go) (page-number go))
461 (ly:stencil-expr (vector-ref (page-stencils go) (page-number go)))
462 gnome-output-expression go '(0 . 0))
463 ;; ;;(lambda (x) (gnome-output-expression go x)) '(0 . 0))
465 (if old-canvas (destroy old-canvas))
466 (add (scrolled go) (canvas go))
467 (show (canvas go)))))
470 (define (get-x-editor)
472 (set! x-editor (getenv "XEDITOR")))
478 (set! ifs (getenv "IFS")))
483 (define (spawn-editor location)
484 (let* ((line (car location))
485 (column (cadr location))
486 (file-name (caddr location))
487 (template (substring (get-x-editor) 0))
489 ;; Adhere to %l %c %f?
491 (regexp-substitute/global
492 #f "%l" (regexp-substitute/global
494 (regexp-substitute/global
495 #f "%f" template 'pre file-name 'post)
496 'pre (number->string column)
498 'pre (number->string line) 'post)))
500 (stderr "spawning: ~s\n" command)
501 (if (= (primitive-fork) 0)
502 (let ((command-list (string-split command #\ )));; (get-ifs))))
503 (apply execlp command-list)
506 (define location-callback spawn-editor)
508 (define (item-event item event . data)
509 (case (gdk-event:type event)
510 ((enter-notify) (gobject-set-property item 'fill-color "red"))
511 ((leave-notify) (gobject-set-property item 'fill-color "black"))
513 (let ((location (hashq-ref item-locations item #f)))
515 (location-callback location)
516 (stderr "no location\n"))))
517 ((2button-press) (gobject-set-property item 'fill-color "red")))
520 (define (scale-canvas factor)
521 (set! pixels-per-unit (* pixels-per-unit factor))
522 (set-pixels-per-unit main-canvas pixels-per-unit)
525 (let ((scale (gobject-get-property x 'scale))
526 (points (gobject-get-property x 'size-points)))
527 ;;(gobject-set-property x 'scale pixels-per-unit)
528 (gobject-set-property x 'size-points (* points factor))))
531 (define (key-press-event item event . data)
532 (let ((keyval (gdk-event-key:keyval event))
533 (mods (gdk-event-key:modifiers event)))
534 (cond ((and (or (eq? keyval gdk:q)
536 (equal? mods '(control-mask modifier-mask)))
538 ((and #t ;;(null? mods)
539 (eq? keyval gdk:plus))
541 ((and #t ;; (null? mods)
542 (eq? keyval gdk:minus))
544 ((or (eq? keyval gdk:Page-Up)
545 (eq? keyval gdk:BackSpace))
546 (dump-page (1- page-number)))
547 ((or (eq? keyval gdk:Page-Down)
548 (eq? keyval gdk:space))
549 (dump-page (1+ page-number))))
552 ;;(define (new-canvas go <gnome-outputter>)
553 (define (new-canvas go)
554 (set! (canvas go) (make <gnome-canvas>))
555 (set-size-request (canvas go) (window-width go) (window-height go))
556 (set-scroll-region (canvas go) 0 0 (canvas-width go) (canvas-height go))
557 (set-pixels-per-unit (canvas go) (pixels-per-unit go))
558 (make <gnome-canvas-rect>
559 #:parent (root (canvas go))
560 #:x2 (canvas-width go) #:y2 (canvas-height go)
561 #:fill-color "white"))
564 ;;(define output-gnome-module
565 ;; ;;(make-module 1021 (list (resolve-interface '(scm output-gnome)))))
568 (define global-go #f)
570 (define-public (gnome-output-expression go expr)
573 (eval expr this-module))