- (stderr "spawning: ~s\n" command)
- (if (= (primitive-fork) 0)
- (let ((command-list (string-split command #\ )));; (get-ifs))))
- (apply execlp command-list)
- (primitive-exit)))))
-
-(define location-callback spawn-editor)
-
-(define (item-event item event . data)
- (case (gdk-event:type event)
- ((enter-notify) (gobject-set-property item 'fill-color "red"))
- ((leave-notify) (gobject-set-property item 'fill-color "black"))
- ((button-press)
- (let ((location (hashq-ref item-locations item #f)))
- (if location
- (location-callback location)
- (stderr "no location\n"))))
- ((2button-press) (gobject-set-property item 'fill-color "red")))
- #t)
-
-;; TODO: one list per-page
-(define text-items '())
-(define (scale-canvas factor)
- (set! pixels-per-unit (* pixels-per-unit factor))
- (set-pixels-per-unit main-canvas pixels-per-unit)
- (for-each
- (lambda (x)
- (let ((scale (gobject-get-property x 'scale))
- (points (gobject-get-property x 'size-points)))
- ;;(gobject-set-property x 'scale pixels-per-unit)
- (gobject-set-property x 'size-points (* points factor))))
- text-items))
-
-(define (key-press-event item event . data)
- (let ((keyval (gdk-event-key:keyval event))
- (mods (gdk-event-key:modifiers event)))
- (cond ((and (or (eq? keyval gdk:q)
- (eq? keyval gdk:w))
- (equal? mods '(control-mask modifier-mask)))
- (gtk-main-quit))
- ((and #t ;;(null? mods)
- (eq? keyval gdk:plus))
- (scale-canvas 2))
- ((and #t ;; (null? mods)
- (eq? keyval gdk:minus))
- (scale-canvas 0.5))
- ((or (eq? keyval gdk:Page-Up)
- (eq? keyval gdk:BackSpace))
- (dump-page (1- page-number)))
- ((or (eq? keyval gdk:Page-Down)
- (eq? keyval gdk:space))
- (dump-page (1+ page-number))))
- #f))
-
-(define (papersize window paper)
- (let* ((hsize (ly:output-def-lookup paper 'hsize))
- (vsize (ly:output-def-lookup paper 'vsize))
- (width (inexact->exact (ceiling (* output-scale hsize))))
- (height (inexact->exact (ceiling (* output-scale vsize))))
- (max-width (gdk-screen-width))
- (max-height (gdk-screen-height))
- (scrollbar-size 20))
-
- ;; ughr: panels?
- (set! max-height (- max-height 80))
-
- ;; hmm?
- ;;(set! OUTPUT-SCALE (ly:bookpaper-outputscale paper))
- ;;(set! output-scale (* OUTPUT-SCALE pixels-per-unit))
-
- ;; huh, *2?
-
- (set! window-width (min (+ scrollbar-size (* width 2)) max-width))
- (set! window-height (min (+ button-height scrollbar-size (* height 2))
- max-height))
-
- (set! canvas-width width)
- (set! canvas-height height)))
-
-
-(define (new-canvas)
- (let* ((canvas (make <gnome-canvas>))
- (root (root canvas)))
-
- (set-size-request canvas window-width window-height)
- (set-scroll-region canvas 0 0 canvas-width canvas-height)
-
- (set-pixels-per-unit canvas pixels-per-unit)
-
- (set! main-canvas canvas)
- (draw-rectangle 0 0 canvas-width canvas-height "white" 0)
-
- canvas))
-
-(define (main outputter bookpaper pages)
- (let* ((window (make <gtk-window> #:type 'toplevel))
- (button (make <gtk-button> #:label "Exit"))
- (next (make <gtk-button> #:label "Next"))
- (prev (make <gtk-button> #:label "Previous"))
- (vbox (make <gtk-vbox> #:homogeneous #f))
- (hbox (make <gtk-hbox> #:homogeneous #f))
- (scrolled (make <gtk-scrolled-window>))
- (canvas (new-canvas)))
-
- (papersize window bookpaper)
- (set-size-request window window-width window-height)
-
- (add window vbox)
- (add vbox scrolled)
- (add scrolled canvas)
-
- (add vbox hbox)
- (set-size-request hbox window-width button-height)
- (set-child-packing vbox hbox #f #f 0 'end)
-
- (set-child-packing hbox button #f #f 0 'end)
- (set-size-request button (quotient window-width 2) button-height)
-
- (add hbox next)
- (add hbox prev)
- (add hbox button)
-
- (gtype-instance-signal-connect button 'clicked
- (lambda (b) (gtk-main-quit)))
- (gtype-instance-signal-connect next 'clicked
- (lambda (b) (dump-page (1+ page-number))))
- (gtype-instance-signal-connect prev 'clicked
- (lambda (b) (dump-page (1- page-number))))
-
- (gtype-instance-signal-connect window 'key-press-event key-press-event)
- (show-all window)
-
- ;; HMMM. Make some class for these vars?
- (set! main-window window)
- (set! main-scrolled scrolled)
- (set! output-canvas outputter)
- (set! page-stencils pages)
-
- (dump-page 0)
-
- (gtk-main)))