From: Jan Nieuwenhuizen Date: Sun, 13 Jun 2004 16:55:45 +0000 (+0000) Subject: White background, better window size, sane X-Git-Tag: release/2.3.4~4 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=8ab26fe2978296ac8371c1bd7781a05e5433b39f;p=lilypond.git White background, better window size, sane canvas size. --- diff --git a/ChangeLog b/ChangeLog index 10c8d18bcc..350a9c7e42 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +2004-06-13 Jan Nieuwenhuizen + + * scm/output-gnome.scm: White background, better window size, sane + canvas size. + 2004-06-13 Han-Wen Nienhuys * scm/output-gnome.scm: set PATH in script. diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm index 3ad11f4d40..aff36185a8 100644 --- a/scm/framework-gnome.scm +++ b/scm/framework-gnome.scm @@ -5,21 +5,14 @@ ;;;; (c) 2004 Jan Nieuwenhuizen (define-module (scm framework-gnome)) - -(use-modules - (guile) - (lily)) - -;; dump? -(define (dump-page outputter page page-number page-count) - (ly:outputter-dump-stencil outputter page)) +(use-modules (guile) (lily)) (define-public (output-framework-gnome outputter book scopes fields basename) (let* ((bookpaper (ly:paper-book-book-paper book)) - (pages (list->vector (map ly:page-stencil - (ly:paper-book-pages book))))) + (pages (list->vector (ly:paper-book-pages book)))) (ly:outputter-dump-stencil outputter - (ly:make-stencil (list 'main outputter pages) '(0 . 0) '(0 . 0))))) + (ly:make-stencil (list 'main outputter bookpaper pages) + '(0 . 0) '(0 . 0))))) diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm index 6787a0d04c..7706b9f883 100644 --- a/scm/framework-ps.scm +++ b/scm/framework-ps.scm @@ -166,7 +166,7 @@ (ly:outputter-dump-string outputter "} stop-system \nshowpage\n")) (define-public (output-framework-ps outputter book scopes fields basename) - (let* ((bookpaper (ly:paper-book-book-paper book)) + (let* ((bookpaper (ly:paper-book-book-paper book)) (pages (ly:paper-book-pages book)) (page-number 0) (page-count (length pages))) diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index a771a5cd80..2aa66f1d96 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -58,6 +58,7 @@ export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib ;;; * 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 @@ -251,7 +252,6 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (define main-window #f) (define main-scrolled #f) (define main-canvas #f) -(define canvas-root #f) (define page-number 0) (define page-stencils #f) @@ -263,9 +263,13 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (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) @@ -279,10 +283,13 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (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 @@ -347,7 +354,7 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (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))) @@ -413,72 +420,9 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm #f))) (define (round-filled-box breapth width depth height blot-diameter) - ;; FIXME: no rounded corners on rectangle - (make - #: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 #:type 'toplevel)) - (button (make #:label "Exit")) - (next (make #:label "Next")) - (prev (make #:label "Previous")) - (canvas (make )) - (vbox (make #:homogeneous #f)) - (hbox (make #:homogeneous #f)) - (scrolled (make ))) - - (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 @@ -508,7 +452,7 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm text-items (cons (make - #:parent canvas-root + #:parent (root main-canvas) #:x 0 #:y 0 ;; #:font "new century schoolbook, i bold 20" #:font (pango-font-name font) @@ -547,37 +491,115 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (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 )) - (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 )) + (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 + #: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 #:type 'toplevel)) + (button (make #:label "Exit")) + (next (make #:label "Next")) + (prev (make #:label "Previous")) + (vbox (make #:homogeneous #f)) + (hbox (make #:homogeneous #f)) + (scrolled (make )) + (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)))