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>
8 ;;; HIP -- hack in progress
12 ;;; * guile-1.6.4 (NOT CVS)
13 ;;; * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4.
14 ;;; * lilypond branch: lilypond_2_3_2b; the framework-* backend
15 ;;; loads output-gnome.scm at startup, which seems to break g-wrapped
18 ;;; see also: guile-gtk-general@gnu.org
22 ;;; * Install g-wrap, guile-gnome (see script below)
24 ;;; * Use latin1 encoding for gnome backend, do
26 ;;; make -C mf ENCODING_FILE=$(kpsewhich cork.enc)
27 ;;; (cd mf/out && mkfontdir)
28 ;;; xset +fp $(pwd)/mf/out
33 # do not use guile CVS:
34 export PATH=/usr/bin/:$PATH
35 # use g-wrap and guile-gnome from usr/pkg
36 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
37 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib
40 ;;; * Set XEDITOR and add
41 ;;; #(ly:set-point-and-click 'line-column)
42 ;;; to your .ly to get point-and-click
44 ;;; * Run lily: lilypond-bin -fgnome input/simple-song.ly
47 ;;; todo: hmm --output-base broken?
48 ;;; ### cd mf && mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf && mv feta20.pfa out
51 ;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and
53 ;;; - wait for/help with pango 1.6
54 ;;; - convert feta to OpenType (CFF) or TrueType (fontforge?)
55 ;;; - hack feta20/feta20.pfa?:
56 ;;; * font, canvas, scaling?
57 ;;; * implement missing stencil functions
58 ;;; * implement missing commands
59 ;;; * user-interface, keybindings
60 ;;; * cleanups: (too many) global vars
61 ;;; * papersize, outputscale from book
63 ;;; Note: this install information is volatile
64 ;;; you'll probably want to pull all from
65 ;;; from guile-gnome-devel@gnu.org--2004 soon
74 export PATH=/usr/bin/:$PATH
76 if [ -d $HOME/usr/pkg/libffi/ ] ; then
77 export LDFLAGS=-L$HOME/usr/pkg/libffi/lib/
78 export CPPFLAGS=-I$HOME/usr/pkg/libffi/include
81 export AUTOMAKE=automake-1.8
82 export AUTOCONF=autoconf2.50
88 ## 1. install gnome-devel (Debian/unstable: apt-get install gnome-devel)
90 ## 2. *** NOTE: use guile-1.6 for g-wrap and guile-gnome ***
91 ##### using GUILE CVS g-wrap/guile-gnome is experimental (read: segfaults)
96 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
99 ## tla get a.rottmann@gmx.at--2004-main/g-wrap--tng g-wrap
100 ## pull latest g-wrap from janneke -- this step is probably no longer
101 ## necessary when you read this
102 tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
103 tla get janneke@gnu.org--2004-gnome/g-wrap--janneke g-wrap
106 rm -rf $HOME/usr/pkg/g-wrap
107 sh autogen.sh --noconfigure
110 ../configure --prefix=$HOME/usr/pkg/g-wrap
113 # cp srfi-34.scm from CVS head ? --hwn
114 (cd $HOME/usr/pkg/g-wrap/share/guile/site
115 mv srfi-34.scm srfi-34.scm-g-wrap
116 cp $HOME/usr/pkg/guile/share/guile-1.7/srfi/srfi-34.scm .)
120 ## 4. get guile-gnome
121 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
123 tla get guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
125 tla build-config -r configs/gnu.org/dev
128 ## 5. get the gnome canvas module
129 tla get guile-gnome-devel@gnu.org--2004/libgnomecanvas--dev libgnomecanvas
131 ## pull latest defs from janneke -- this step is probably no longer
132 ## necessary when you read this
133 ## tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true
135 ## tla get janneke@gnu.org--2004-gnome/defs--janneke defs
137 rm -rf $HOME/usr/pkg/guile-gnome
138 sh autogen.sh --noconfigure
142 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
143 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
144 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
146 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
149 # requires 800mb RAM with -O2
150 (cd libgnomecanvas/gnome/gw; perl -i~ -pe 's/-O2//g' Makefile)
152 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
154 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
155 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
156 guile -s ../src/libgnomecanvas/examples/canvas.scm
160 guile -s ../src/libgnomecanvas/examples/canvas.scm
164 (debug-enable 'backtrace)
166 (define-module (scm output-gnome))
168 (define this-module (current-module))
176 (gnome gtk gdk-event)
177 ;; the name of the module will change to canvas rsn
178 ;;(gnome gw libgnomecanvas))
182 ;;; Lily output interface --- fix silly names and docme
185 The output interface has functions for
186 * formatting stencils, and
202 The Bare minimum interface for \score { \notes c } } should
205 INTERFACE-output-expression
210 and should intercept:
213 (define (dummy . foo) #f)
215 ;; minimal intercept list:
216 (define output-interface-intercept
230 (map (lambda (x) (module-define! this-module x dummy))
231 output-interface-intercept)
233 (define-public (gnome-output-expression expr port)
234 (display (dispatch expr) port))
236 (define (dispatch expr)
238 (let ((keyword (car expr)))
240 ((eq? keyword 'some-func) "")
241 ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
243 (if (module-defined? this-module keyword)
244 (apply (eval keyword this-module) (cdr expr))
247 (string-append "undefined: " (symbol->string keyword) "\n"))
252 (define main-window #f)
253 (define main-scrolled #f)
254 (define main-canvas #f)
255 (define page-number 0)
257 (define page-stencils #f)
258 (define output-canvas #f)
260 (define system-origin '(0 . 0))
263 (define item-locations (make-hash-table 31))
266 (define button-height 25)
267 (define canvas-width 2000)
268 (define canvas-height 4000)
270 (define window-width 400)
271 (define window-height
272 (inexact->exact (round (* 1.42 window-width))))
274 (define font-paper #f)
276 ;;(define pixels-per-unit 1.0)
277 (define pixels-per-unit 2.0)
279 ;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions?
280 ;;(define output-scale (* 2 2.83464566929134))
281 ;;(define output-scale 2.83464566929134)
282 (define OUTPUT-SCALE 2.83464566929134)
283 (define output-scale (* OUTPUT-SCALE pixels-per-unit))
284 ;;(define output-scale 1)
286 ;; helper functions -- sort this out
287 (define (stderr string . rest)
291 (apply format (cons (current-error-port) (cons string rest)))
292 (force-output (current-error-port)))))
296 ((< i #x80) (make-string 1 (integer->char i)))
297 ((< i #x800) (list->string
299 (list (+ #xc0 (quotient i #x40))
300 (+ #x80 (modulo i #x40))))))
302 (let ((x (quotient i #x1000))
303 (y (modulo i #x1000)))
307 (+ #x80 (quotient y #x40))
308 (+ #x80 (modulo y #x40)))))))
311 (define (custom-utf8 i)
314 (utf8 (+ #xee00 i))))
317 (define (get-x-editor)
319 (set! x-editor (getenv "XEDITOR")))
325 (set! ifs (getenv "IFS")))
330 (define (spawn-editor location)
331 (let* ((line (car location))
332 (column (cadr location))
333 (file-name (caddr location))
334 (template (substring (get-x-editor) 0))
336 ;; Adhere to %l %c %f?
338 (regexp-substitute/global
339 #f "%l" (regexp-substitute/global
341 (regexp-substitute/global
342 #f "%f" template 'pre file-name 'post)
343 'pre (number->string column)
345 'pre (number->string line) 'post)))
347 (stderr "spawning: ~s\n" command)
348 (if (= (primitive-fork) 0)
349 (let ((command-list (string-split command #\ )));; (get-ifs))))
350 (apply execlp command-list)
353 (define location-callback spawn-editor)
355 (define (item-event item event . data)
356 (case (gdk-event:type event)
357 ((enter-notify) (gobject-set-property item 'fill-color "red"))
358 ((leave-notify) (gobject-set-property item 'fill-color "black"))
360 (let ((location (hashq-ref item-locations item #f)))
362 (location-callback location)
363 (stderr "no location\n"))))
364 ((2button-press) (gobject-set-property item 'fill-color "red")))
367 ;; TODO: one list per-page
368 (define text-items '())
369 (define (scale-canvas factor)
370 (set! pixels-per-unit (* pixels-per-unit factor))
371 (set-pixels-per-unit main-canvas pixels-per-unit)
374 (let ((scale (gobject-get-property x 'scale))
375 (points (gobject-get-property x 'size-points)))
376 ;;(gobject-set-property x 'scale pixels-per-unit)
377 (gobject-set-property x 'size-points (* points factor))))
380 (define (key-press-event item event . data)
381 (let ((keyval (gdk-event-key:keyval event))
382 (mods (gdk-event-key:modifiers event)))
383 (cond ((and (or (eq? keyval gdk:q)
385 (equal? mods '(control-mask modifier-mask)))
387 ((and #t ;;(null? mods)
388 (eq? keyval gdk:plus))
390 ((and #t ;; (null? mods)
391 (eq? keyval gdk:minus))
393 ((or (eq? keyval gdk:Page-Up)
394 (eq? keyval gdk:BackSpace))
395 (dump-page (1- page-number)))
396 ((or (eq? keyval gdk:Page-Down)
397 (eq? keyval gdk:space))
398 (dump-page (1+ page-number))))
401 (define (char font i)
402 (text font (utf8 i)))
404 (define (placebox x y expr)
405 (stderr "item: ~S\n" expr)
408 ;; FIXME ugly hack to skip #unspecified ...
409 (if (and item (not (eq? item (if #f #f))))
412 (* output-scale (+ (car system-origin) x))
413 (* output-scale (- (car system-origin) y)))
414 (affine-relative item output-scale 0 0 output-scale 0 0)
416 (gtype-instance-signal-connect item 'event item-event)
418 (hashq-set! item-locations item location))
422 (define (round-filled-box breapth width depth height blot-diameter)
423 ;; FIXME: no rounded corners on rectangle...
425 (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
427 (define (pango-font-name font)
429 ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
430 "lilypond-feta, regular 32")
432 (ly:font-filename font))))
434 (define (pango-font-size font)
435 (let* ((designsize (ly:font-design-size font))
436 (magnification (* (ly:font-magnification font)))
437 ;;(ops (ly:paper-lookup paper 'outputscale))
438 ;;(ops (* pixels-per-unit OUTPUT-SCALE))
439 ;;(ops (* pixels-per-unit pixels-per-unit))
440 (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit)))
441 (scaling (* ops magnification designsize)))
444 (define (text font string)
445 (stderr "font-name: ~S\n" (ly:font-name font))
446 ;; TODO s/filename/file-name/
447 (stderr "font-filename: ~S\n" (ly:font-filename font))
449 (stderr "pango-font-name: ~S\n" (pango-font-name font))
450 (stderr "pango-font-size: ~S\n" (pango-font-size font))
454 (make <gnome-canvas-text>
455 #:parent (root main-canvas)
457 ;; #:font "new century schoolbook, i bold 20"
458 #:font (pango-font-name font)
460 #:size-points (pango-font-size font)
461 ;;#:size (pango-font-size font)
464 ;;apparently no effect :-(
474 (define (filledbox a b c d)
475 (round-filled-box a b c d 0.001))
477 ;; WTF is this in every backend?
478 (define (horizontal-line x1 x2 thickness)
479 ;;(let ((thickness 2))
480 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
482 (define (start-system origin . rest)
483 (set! system-origin origin))
485 ;; origin -- bad name
486 (define (define-origin file line col)
487 ;; ughr, why is this not passed as [part of] stencil object
488 (set! location (if (procedure? point-and-click)
489 ;; duh, only silly string append
490 ;; (point-and-click line col file)
496 ;;;;;;;;;;;;;;;; gnome stuff
498 (define (dump-page number)
499 (if (or (not page-stencils)
501 (>= number (vector-length page-stencils)))
502 (stderr "No such page: ~S\n" (1+ number))
504 (let* ((old-canvas main-canvas)
505 (canvas (new-canvas)))
506 (set! page-number number)
508 ;; no destroy method for gnome-canvas-text?
509 ;;(map destroy (gtk-container-get-children main-canvas))
510 ;;(map destroy text-items)
513 ;;(set! main-canvas canvas)
514 (set! text-items '())
515 (ly:outputter-dump-stencil output-canvas
516 (vector-ref page-stencils page-number))
518 (if old-canvas (destroy old-canvas))
519 (add main-scrolled canvas)
524 (define (papersize window paper)
525 (let* ((hsize (ly:output-def-lookup paper 'hsize))
526 (vsize (ly:output-def-lookup paper 'vsize))
528 (width (inexact->exact (ceiling (* output-scale 2 hsize))))
529 (height (inexact->exact (ceiling (* output-scale 2 vsize))))
530 (max-width (gdk-screen-width))
531 (max-height (gdk-screen-height)))
534 (set! max-height (- max-height 80))
536 (set! window-width (min width max-width))
537 (set! window-height (min height max-height))
539 (set! canvas-width width)
540 (set! canvas-height height)))
544 (let* ((canvas (make <gnome-canvas>))
545 (root (root canvas)))
547 (set-size-request canvas window-width window-height)
548 (set-scroll-region canvas 0 0 canvas-width canvas-height)
550 (set-pixels-per-unit canvas pixels-per-unit)
552 (set! main-canvas canvas)
553 (draw-rectangle 0 0 canvas-width canvas-height "white" 0)
557 (define (draw-rectangle x1 y1 x2 y2 color width-units)
558 (make <gnome-canvas-rect>
559 #:parent (root main-canvas) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
560 #:fill-color color #:width-units width-units))
562 (define (main outputter bookpaper pages)
563 (let* ((window (make <gtk-window> #:type 'toplevel))
564 (button (make <gtk-button> #:label "Exit"))
565 (next (make <gtk-button> #:label "Next"))
566 (prev (make <gtk-button> #:label "Previous"))
567 (vbox (make <gtk-vbox> #:homogeneous #f))
568 (hbox (make <gtk-hbox> #:homogeneous #f))
569 (scrolled (make <gtk-scrolled-window>))
570 (canvas (new-canvas)))
572 (papersize window bookpaper)
573 (set-size-request window window-width window-height)
574 ;;; (ly:bookpaper-outputscale bookpaper))))
578 (add scrolled canvas)
581 (set-size-request hbox window-width button-height)
582 (set-child-packing vbox hbox #f #f 0 'end)
584 (set-child-packing hbox button #f #f 0 'end)
585 (set-size-request button (quotient window-width 2) button-height)
591 (gtype-instance-signal-connect button 'clicked
592 (lambda (b) (gtk-main-quit)))
593 (gtype-instance-signal-connect next 'clicked
594 (lambda (b) (dump-page (1+ page-number))))
595 (gtype-instance-signal-connect prev 'clicked
596 (lambda (b) (dump-page (1- page-number))))
598 (gtype-instance-signal-connect window 'key-press-event key-press-event)
601 ;; HMMM. Make some class for these vars?
602 (set! main-window window)
603 (set! main-scrolled scrolled)
604 (set! output-canvas outputter)
605 (set! page-stencils pages)