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
10 ;;; This first working version needs Rotty's g-wrap--tng.
11 ;;; (janneke's guile-gnome patches now in main archive).
12 ;;; see also: guile-gtk-general@gnu.org
16 ;;; * Use latin1 encoding for gnome backend, do
18 ;;; make -C mf ENCODING_FILE=$(kpsewhich cork.enc)
19 ;;; (cd mf/out && mkfontdir)
20 ;;; xset +fp $(pwd)/mf/out
22 ;;; * lilypond-bin -fgnome input/simple-song.ly
24 ;;; todo: hmm --output-base broken?
25 ;;; ### cd mf && mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf && mf feta20.pfa out
27 ;;; Set XEDITOR and add
28 ;;; #(ly:set-point-and-click 'line-column)
29 ;;; to your .ly to get point-and-click
32 ;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and
34 ;;; - wait for/help with pango 1.6
35 ;;; - convert feta to OpenType (CFF) or TrueType (fontforge?)
36 ;;; - hack feta20/feta20.pfa?:
37 ;;; * font, canvas, scaling?
38 ;;; * implement missing stencil functions
39 ;;; * implement missing commands (next, prev? page)
40 ;;; * user-interface, keybindings
42 ;;; Note: this install information is volatile
43 ;;; you'll probably want to pull all from
44 ;;; from guile-gnome-devel@gnu.org--2004 soon
46 ;;; move this into workbook?
49 ## 1. install gnome-devel (Debian/unstable: apt-get install gnome-devel)
51 ## 2. *** NOTE: use guile-1.6 for g-wrap and guile-gnome ***
56 tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true
59 tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine
62 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
65 ../configure --prefix=$HOME/usr/pkg/g-wrap
71 tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true
73 tla guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome
75 tla build-config -r configs/gnu.org/dev
78 AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure
82 export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH
83 export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH
84 export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH
86 ../src/configure --prefix=$HOME/usr/pkg/guile-gnome
88 G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install
89 #FIXME: fixup -- no longer necessary?
90 (cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw)
92 export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH
93 export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH
94 guile -s ../src/libgnoecanvas/examples/canvas.scm
101 (debug-enable 'backtrace)
103 (define-module (scm output-gnome))
104 (define this-module (current-module))
112 (gnome gtk gdk-event)
113 (gnome gw libgnomecanvas))
116 ;;; Lily output interface --- fix silly names and docme
119 The output interface has functions for
120 * formatting stencils, and
136 The Bare minimum interface for \score { \notes c } } should
139 INTERFACE-output-expression
144 and should intercept:
147 (define (dummy . foo) #f)
149 ;; minimal intercept list:
150 (define output-interface-intercept
166 (map (lambda (x) (module-define! this-module x dummy))
167 output-interface-intercept)
169 (define-public (gnome-output-expression expr port)
170 (display (dispatch expr) port))
172 (define (dispatch expr)
174 (let ((keyword (car expr)))
176 ((eq? keyword 'some-func) "")
177 ;;((eq? keyword 'placebox) (dispatch (cadddr expr)))
179 (if (module-defined? this-module keyword)
180 (apply (eval keyword this-module) (cdr expr))
183 (string-append "undefined: " (symbol->string keyword) "\n"))
188 (define main-window #f)
189 (define main-canvas #f)
190 (define canvas-root #f)
192 (define system-origin '(0 . 0))
195 (define item-locations (make-hash-table 31))
198 (define canvas-width 400)
199 (define canvas-height
200 (inexact->exact (round (* 1.42 canvas-width))))
202 (define font-paper #f)
204 ;;(define pixels-per-unit 1.0)
205 (define pixels-per-unit 2.0)
207 ;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions?
208 ;;(define output-scale (* 2 2.83464566929134))
209 ;;(define output-scale 2.83464566929134)
210 (define OUTPUT-SCALE 2.83464566929134)
211 (define output-scale (* OUTPUT-SCALE pixels-per-unit))
212 ;;(define output-scale 1)
215 (define (stderr string . rest)
216 (apply format (cons (current-error-port) (cons string rest)))
217 (force-output (current-error-port)))
221 ((< i #x80) (make-string 1 (integer->char i)))
222 ((< i #x800) (list->string
224 (list (+ #xc0 (quotient i #x40))
225 (+ #x80 (modulo i #x40))))))
227 (let ((x (quotient i #x1000))
228 (y (modulo i #x1000)))
232 (+ #x80 (quotient y #x40))
233 (+ #x80 (modulo y #x40)))))))
236 (define (custom-utf8 i)
239 (utf8 (+ #xee00 i))))
242 (define (get-x-editor)
244 (set! x-editor (getenv "XEDITOR")))
250 (set! ifs (getenv "IFS")))
255 (define (spawn-editor location)
256 (let* ((line (car location))
257 (column (cadr location))
258 (file-name (caddr location))
259 (template (substring (get-x-editor) 0))
261 ;; Adhere to %l %c %f?
263 (regexp-substitute/global
264 #f "%l" (regexp-substitute/global
266 (regexp-substitute/global
267 #f "%f" template 'pre file-name 'post)
268 'pre (number->string column)
270 'pre (number->string line) 'post)))
272 (stderr "spawning: ~s\n" command)
273 (if (= (primitive-fork) 0)
274 (let ((command-list (string-split command #\ )));; (get-ifs))))
275 (apply execlp command-list)
278 (define location-callback spawn-editor)
280 (define (item-event item event . data)
281 (case (gdk-event:type event)
282 ((enter-notify) (gobject-set-property item 'fill-color "white"))
283 ((leave-notify) (gobject-set-property item 'fill-color "black"))
285 (let ((location (hashq-ref item-locations item #f)))
287 (location-callback location)
288 (stderr "no location\n"))))
289 ((2button-press) (gobject-set-property item 'fill-color "red")))
292 (define (key-press-event item event . data)
293 (let ((keyval (gdk-event-key:keyval event))
294 (mods (gdk-event-key:modifiers event)))
295 (cond ((and (or (eq? keyval gdk:q)
297 (equal? mods '(control-mask modifier-mask)))
299 ((and #t ;;(null? mods)
300 (eq? keyval gdk:plus))
301 (set! pixels-per-unit (* pixels-per-unit 2))
302 (set-pixels-per-unit main-canvas pixels-per-unit))
303 ((and #t ;; (null? mods)
304 (eq? keyval gdk:minus))
305 (set! pixels-per-unit (/ pixels-per-unit 2))
306 (set-pixels-per-unit main-canvas pixels-per-unit)))
309 (define (char font i)
310 (text font (utf8 i)))
312 (define (placebox x y expr)
317 (* output-scale (+ (car system-origin) x))
318 (* output-scale (- (car system-origin) y)))
319 (affine-relative item output-scale 0 0 output-scale 0 0)
321 (gtype-instance-signal-connect item 'event item-event)
323 (hashq-set! item-locations item location))
327 (define (round-filled-box breapth width depth height blot-diameter)
328 ;; FIXME: no rounded corners on rectangle
329 (make <gnome-canvas-rect>
331 #:x1 (- breapth) #:y1 (- depth) #:x2 width #:y2 height
332 #:fill-color "black" #:width-units blot-diameter))
334 (define (fontify font expr)
340 (define (header . rest)
341 (let* ((window (make <gtk-window> #:type 'toplevel))
342 (button (make <gtk-button> #:label "Exit"))
343 (canvas (make <gnome-canvas>))
344 (vbox (make <gtk-vbox> #:homogeneous #f))
345 (scrolled (make <gtk-scrolled-window>)))
349 (add scrolled canvas)
351 (set-size-request button canvas-width 20)
353 (set-child-packing vbox button #f #f 0 'end)
355 (gtype-instance-signal-connect button 'clicked
356 (lambda (b) (gtk-main-quit)))
359 (set-size-request canvas canvas-width canvas-height)
360 (set-scroll-region canvas 0 0 2000 4000)
362 (gtype-instance-signal-connect window 'key-press-event key-press-event)
364 (set-pixels-per-unit canvas pixels-per-unit)
366 (set! canvas-root (root canvas))
367 (set! main-canvas canvas)
368 (set! main-window window)))
370 (define (pango-font-name font)
372 ((equal? (ly:font-name font) "GNU-LilyPond-feta-20")
373 "lilypond-feta, regular 32")
375 (ly:font-filename font))))
377 (define (pango-font-size font)
378 (let* ((designsize (ly:font-design-size font))
379 (magnification (* (ly:font-magnification font)))
380 ;;(ops (ly:paper-lookup paper 'outputscale))
381 ;;(ops (* pixels-per-unit OUTPUT-SCALE))
382 ;;(ops (* pixels-per-unit pixels-per-unit))
383 (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit)))
384 (scaling (* ops magnification designsize)))
387 (define (text font string)
388 (stderr "font-name: ~S\n" (ly:font-name font))
389 ;; TODO s/filename/file-name/
390 (stderr "font-filename: ~S\n" (ly:font-filename font))
391 (make <gnome-canvas-text>
394 ;; #:font "new century schoolbook, i bold 20"
395 #:font (pango-font-name font)
397 #:size-points (pango-font-size font)
398 ;;#:size (pango-font-size font)
403 (define (filledbox a b c d)
404 (round-filled-box a b c d 0.001))
406 ;; WTF is this in every backend?
407 (define (horizontal-line x1 x2 thickness)
408 ;;(let ((thickness 2))
409 (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
411 (define (start-system origin . rest)
412 (set! system-origin origin))
414 ;; origin -- bad name
415 (define (define-origin file line col)
416 ;; ughr, why is this not passed as [part of] stencil object
417 (set! location (if (procedure? point-and-click)
418 ;; duh, only silly string append
419 ;; (point-and-click line col file)
424 ;;(define (define-fonts paper . rest)
425 ;;(define (define-fonts foebar paper)
427 ;; (set! font-paper paper))