;;; * implement missing commands
;;; * user-interface, keybindings
;;; * cleanups: (too many) global vars
+;;; * papersize, outputscale from book
;;; Note: this install information is volatile
;;; you'll probably want to pull all from
(define main-window #f)
(define main-scrolled #f)
(define main-canvas #f)
-(define canvas-root #f)
(define page-number 0)
(define page-stencils #f)
(define item-locations (make-hash-table 31))
(define location #f)
-(define canvas-width 400)
-(define canvas-height
- (inexact->exact (round (* 1.42 canvas-width))))
+(define button-height 25)
+(define canvas-width 2000)
+(define canvas-height 4000)
+
+(define window-width 400)
+(define window-height
+ (inexact->exact (round (* 1.42 window-width))))
(define font-paper #f)
(define output-scale (* OUTPUT-SCALE pixels-per-unit))
;;(define output-scale 1)
-;; helper functions
+;; helper functions -- sort this out
(define (stderr string . rest)
- (apply format (cons (current-error-port) (cons string rest)))
- (force-output (current-error-port)))
+ ;; debugging
+ (if #f
+ (begin
+ (apply format (cons (current-error-port) (cons string rest)))
+ (force-output (current-error-port)))))
(define (utf8 i)
(cond
(define (item-event item event . data)
(case (gdk-event:type event)
- ((enter-notify) (gobject-set-property item 'fill-color "white"))
+ ((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)))
#f)))
(define (round-filled-box breapth width depth height blot-diameter)
- ;; FIXME: no rounded corners on rectangle
- (make <gnome-canvas-rect>
- #:parent canvas-root
- #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
- #:fill-color "black" #:width-units blot-diameter))
-
-;;(define (fontify font expr)
-;; #f)
-
-(define (main outputter 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"))
- (canvas (make <gnome-canvas>))
- (vbox (make <gtk-vbox> #:homogeneous #f))
- (hbox (make <gtk-hbox> #:homogeneous #f))
- (scrolled (make <gtk-scrolled-window>)))
-
- (add window vbox)
- (add vbox scrolled)
- (add scrolled canvas)
-
- ;;(set-size-request button canvas-width 20)
- ;;(add vbox button)
- ;;(set-child-packing vbox button #f #f 0 'end)
-
- (add vbox hbox)
- (set-size-request hbox canvas-width 25)
- (set-child-packing vbox hbox #f #f 0 'end)
-
- (set-child-packing hbox button #f #f 0 'end)
- ;;(set-size-request next 40 25)
- ;;(set-size-request prev 40 25)
- (set-size-request button (/ canvas-width 2) 25)
-
- (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))))
-
- ;; papersize
- (set-size-request canvas canvas-width canvas-height)
- (set-scroll-region canvas 0 0 2000 4000)
- (set-pixels-per-unit canvas pixels-per-unit)
-
- (gtype-instance-signal-connect window 'key-press-event key-press-event)
- (show-all window)
-
- ;; HMMM
- (set! canvas-root (root canvas))
- (set! main-canvas canvas)
- (set! main-window window)
- (set! output-canvas outputter)
- (set! page-stencils pages)
- (set! main-scrolled scrolled)
-
- (dump-page 0)
- (gtk-main)))
+ ;; FIXME: no rounded corners on rectangle...
+ ;; FIXME: blot?
+ (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter))
(define (pango-font-name font)
(cond
text-items
(cons
(make <gnome-canvas-text>
- #:parent canvas-root
+ #:parent (root main-canvas)
#:x 0 #:y 0
;; #:font "new century schoolbook, i bold 20"
#:font (pango-font-name font)
(list line col file)
#f)))
+
+;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;; gnome stuff
+;;;;;;;;;;;;;;;;
(define (dump-page number)
(if (or (not page-stencils)
(< number 0)
(>= number (vector-length page-stencils)))
(stderr "No such page: ~S\n" (1+ number))
- (begin
+
+ (let* ((old-canvas main-canvas)
+ (canvas (new-canvas)))
(set! page-number number)
-
+
;; no destroy method for gnome-canvas-text?
;;(map destroy (gtk-container-get-children main-canvas))
;;(map destroy text-items)
- ;; UGHR - destroying the whole canvas....
- (if (and main-canvas
- (not (null? text-items)))
- (let* ((canvas (make <gnome-canvas>))
- (root (root canvas)))
-
- (destroy main-canvas)
- (add main-scrolled canvas)
-
- ;; papersize
- (set-size-request canvas canvas-width canvas-height)
- (set-scroll-region canvas 0 0 2000 4000)
- (set-pixels-per-unit canvas pixels-per-unit)
- (show canvas)
-
- (set! main-canvas canvas)
- (set! canvas-root root)
- (set! text-items '())))
-
+ ;;Hmm
+ ;;(set! main-canvas canvas)
+ (set! text-items '())
(ly:outputter-dump-stencil output-canvas
- (vector-ref page-stencils page-number)))))
+ (vector-ref page-stencils page-number))
+
+ (if old-canvas (destroy old-canvas))
+ (add main-scrolled canvas)
+ (show canvas)
+ )))
+
+
+(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)))
+
+ (set! window-width (min width max-width))
+ (set! window-height (min height 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 (draw-rectangle x1 y1 x2 y2 color width-units)
+ (make <gnome-canvas-rect>
+ #:parent (root main-canvas) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
+ #:fill-color color #:width-units width-units))
+
+(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)
+ ;;; (ly:bookpaper-outputscale bookpaper))))
+
+ (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)))
projects / lilypond.git / commitdiff