1 ;;;; framework-gnome.scm --
3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
7 (define-module (scm framework-gnome)
8 :use-module (oop goops)
9 #:export (<gnome-outputter>))
11 ;;(define this-module (current-module))
13 (use-modules (guile) (oop goops) (lily))
22 ;; the name of the module will change to canvas rsn
23 (if (resolve-module '(gnome gw canvas))
24 (use-modules (gnome gw canvas))
25 (use-modules (gnome gw libgnomecanvas)))
27 (define SCROLLBAR-SIZE 20)
28 (define BUTTON-HEIGHT 25)
29 (define PANELS-HEIGHT 80)
31 (define PIXELS-PER-UNIT 2)
32 (define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT))
34 ;; helper functions -- sort this out
35 (define (stderr string . rest)
39 (apply format (cons (current-error-port) (cons string rest)))
40 (force-output (current-error-port)))))
43 ;; Hmm, actually, the only vars really needed by output-gnome are
44 ;; * (root (canvas go))
50 ;; so this class could be split in two parts / records?
51 (define-class <gnome-outputter> ()
52 (page-stencils ;;#:init-value '#()
53 #:init-keyword #:page-stencils #:accessor page-stencils)
54 (window #:init-value (make <gtk-window> #:type 'toplevel) #:accessor window)
55 (scrolled #:init-value (make <gtk-scrolled-window>) #:accessor scrolled)
56 (canvas #:init-value #f #:accessor canvas)
57 (page-number #:init-value 0 #:accessor page-number)
58 (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit)
59 (text-items #:init-value '() #:accessor text-items)
60 (location #:init-value #:f #:accessor location)
61 (item-locations #:init-value (make-hash-table 31) #:accessor item-locations)
62 (window-width #:init-keyword #:window-width #:accessor window-width)
63 (window-height #:init-keyword #:window-height #:accessor window-height)
64 (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width)
65 (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
67 ;;(define-method (initialize (go <gnome-outputter>))
71 (let* ((button (make <gtk-button> #:label "Exit"))
72 (next (make <gtk-button> #:label "Next"))
73 (prev (make <gtk-button> #:label "Previous"))
74 (vbox (make <gtk-vbox> #:homogeneous #f))
75 (hbox (make <gtk-hbox> #:homogeneous #f)))
77 (set-size-request (window go) (window-width go) (window-height go))
81 (add (window go) vbox)
82 (add vbox (scrolled go))
84 (add (scrolled go) (canvas go))
88 (set-size-request hbox (window-width go) BUTTON-HEIGHT)
91 ;;(set-child-packing vbox hbox #f #f 0 'end)
92 ;;(set-child-packing hbox button #f #f 0 'end)
94 (set-size-request button (quotient (window-width go) 2) BUTTON-HEIGHT)
100 (gtype-instance-signal-connect
101 button 'clicked (lambda (b) (gtk-main-quit)))
102 (gtype-instance-signal-connect
103 next 'clicked (lambda (b) (dump-page go (1+ (page-number go)))))
104 (gtype-instance-signal-connect
105 prev 'clicked (lambda (b) (dump-page go (1- (page-number go)))))
106 (gtype-instance-signal-connect
107 (window go) 'key-press-event key-press-event)
109 (show-all (window go))))
112 (define-public (output-framework-gnome outputter book scopes fields basename)
113 (let* ((book-paper (ly:paper-book-book-paper book))
115 (hsize (ly:output-def-lookup book-paper 'hsize))
116 (vsize (ly:output-def-lookup book-paper 'vsize))
117 (page-width (inexact->exact (ceiling (* OUTPUT-SCALE hsize))))
118 (page-height (inexact->exact (ceiling (* OUTPUT-SCALE vsize))))
119 ;;(page-width (inexact->exact (ceiling hsize)))
120 ;;(page-height (inexact->exact (ceiling vsize)))
122 (screen-width (gdk-screen-width))
123 (screen-height (gdk-screen-height))
124 (desktop-height (- screen-height PANELS-HEIGHT))
126 (go (make <gnome-outputter>
127 #:page-stencils (list->vector (ly:paper-book-pages book))
128 #:canvas-width page-width
129 #:canvas-height page-height
131 ;; huh, *2 -- pixels-per-unit?
132 (min (+ SCROLLBAR-SIZE (* page-width 2)) screen-width)
134 (min (+ BUTTON-HEIGHT SCROLLBAR-SIZE (* page-height 2))
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
143 ;;;; gnome stuff --- move to framework-gnome
144 ;;(define (dump-page (go <gnome-outputter>) number)
146 (define output-gnome-module
147 (make-module 1021 (list (resolve-interface '(scm output-gnome)))))
149 (define-public (gnome-output-expression go expr)
151 (let ((m output-gnome-module))
153 ;; this does not seem to work
154 (module-define! m 'go go)
160 (define (dump-page go number)
161 (if (or (not (page-stencils go))
163 (>= number (vector-length (page-stencils go))))
164 (stderr "No such page: ~S\n" (1+ number))
166 (let ((old-canvas (canvas go)))
168 (set! (page-number go) number)
170 ;; no destroy method for gnome-canvas-text?
171 ;;(map destroy (gtk-container-get-children main-canvas))
172 ;;(map destroy text-items)
175 ;;(set! main-canvas canvas)
176 (set! (text-items go) '())
177 ;;(ly:outputter-dump-stencil output-canvas
178 ;; (vector-ref page-stencils page-number))
179 (stderr "page-stencil ~S: ~S\n"
181 (vector-ref (page-stencils go) (page-number go)))
183 (ly:interpret-stencil-expression
184 ;;(vector-ref (page-stencils go) (page-number go))
185 (ly:stencil-expr (vector-ref (page-stencils go) (page-number go)))
186 gnome-output-expression go '(0 . 0))
188 (if old-canvas (destroy old-canvas))
189 (add (scrolled go) (canvas go))
190 (show (canvas go)))))
193 (define (get-x-editor)
195 (set! x-editor (getenv "XEDITOR")))
201 (set! ifs (getenv "IFS")))
206 (define (spawn-editor location)
207 (let* ((line (car location))
208 (column (cadr location))
209 (file-name (caddr location))
210 (template (substring (get-x-editor) 0))
212 ;; Adhere to %l %c %f?
214 (regexp-substitute/global
215 #f "%l" (regexp-substitute/global
217 (regexp-substitute/global
218 #f "%f" template 'pre file-name 'post)
219 'pre (number->string column)
221 'pre (number->string line) 'post)))
223 (stderr "spawning: ~s\n" command)
224 (if (= (primitive-fork) 0)
225 (let ((command-list (string-split command #\ )));; (get-ifs))))
226 (apply execlp command-list)
229 (define location-callback spawn-editor)
231 (define (item-event item event . data)
232 (case (gdk-event:type event)
233 ((enter-notify) (gobject-set-property item 'fill-color "red"))
234 ((leave-notify) (gobject-set-property item 'fill-color "black"))
236 (let ((location (hashq-ref item-locations item #f)))
238 (location-callback location)
239 (stderr "no location\n"))))
240 ((2button-press) (gobject-set-property item 'fill-color "red")))
243 (define (scale-canvas factor)
244 (set! pixels-per-unit (* pixels-per-unit factor))
245 (set-pixels-per-unit main-canvas pixels-per-unit)
248 (let ((scale (gobject-get-property x 'scale))
249 (points (gobject-get-property x 'size-points)))
250 ;;(gobject-set-property x 'scale pixels-per-unit)
251 (gobject-set-property x 'size-points (* points factor))))
254 (define (key-press-event item event . data)
255 (let ((keyval (gdk-event-key:keyval event))
256 (mods (gdk-event-key:modifiers event)))
257 (cond ((and (or (eq? keyval gdk:q)
259 (equal? mods '(control-mask modifier-mask)))
261 ((and #t ;;(null? mods)
262 (eq? keyval gdk:plus))
264 ((and #t ;; (null? mods)
265 (eq? keyval gdk:minus))
267 ((or (eq? keyval gdk:Page-Up)
268 (eq? keyval gdk:BackSpace))
269 (dump-page (1- page-number)))
270 ((or (eq? keyval gdk:Page-Down)
271 (eq? keyval gdk:space))
272 (dump-page (1+ page-number))))
275 ;;(define (new-canvas go <gnome-outputter>)
276 (define (new-canvas go)
277 (set! (canvas go) (make <gnome-canvas>))
278 (set-size-request (canvas go) (window-width go) (window-height go))
279 (set-scroll-region (canvas go) 0 0 (canvas-width go) (canvas-height go))
280 (set-pixels-per-unit (canvas go) (pixels-per-unit go))
281 (make <gnome-canvas-rect>
282 #:parent (root (canvas go))
283 #:x2 (canvas-width go) #:y2 (canvas-height go)
284 #:fill-color "white"))