From: Jan Nieuwenhuizen Date: Tue, 25 May 2004 16:16:30 +0000 (+0000) Subject: * scm/fret-diagrams.scm: Add header. X-Git-Tag: release/2.3.2~7 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=91573a75173dbd8fac4186a1be3e5dcb23f95aa6;p=lilypond.git * scm/fret-diagrams.scm: Add header. * scm/output-gnome.scm: Hello world :-) --- diff --git a/ChangeLog b/ChangeLog index 92127d076c..4f0b344a1f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2004-05-25 Jan Nieuwenhuizen + + * scm/fret-diagrams.scm: Add header. + + * scm/output-gnome.scm: Hello world :-) + 2004-05-25 Han-Wen Nienhuys * lily/percent-repeat-engraver.cc (try_music): add moments for diff --git a/scm/fret-diagrams.scm b/scm/fret-diagrams.scm index 7365aea3f5..4a169f3b8f 100644 --- a/scm/fret-diagrams.scm +++ b/scm/fret-diagrams.scm @@ -1,3 +1,9 @@ +;;;; fret-diagrams.scm -- +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2004 Carl D. Sorensen + (define nil '()) (define (fret-parse-string definition-string) "parse a fret diagram string and return an alist with the appropriate values" diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index 05d4751b70..c05015c9e6 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -6,6 +6,17 @@ ;;; HIP -- hack in progress +;;; +;;; status: hello-world +;;; +;;; This first working version needs rotty's g-wrap--tng +;;; and janneke's guile-gnome patches, instructions below. +;;; +;;; Try it: +;;; lilypond-bin -fgnome input/simple-song.ly +;;; + +;;; TODO: pango+feta font (wait for pango 1.6?) ;;; Note: this install information is volatile ;;; you'll probably want to pull all from @@ -44,9 +55,12 @@ cd src ## ugh: get janneke's stuff -- should make build-config, I guess? tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true rm -rf defs +rm -rf gtk rm -rf libgnomecanvas tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 libgnomecanvas tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 defs +tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 gtk +tla get janneke@gnu.org--2004-gnome/libgnomecanvas--janneke--0 libgnomecanvas AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure mkdir ../=build @@ -83,6 +97,7 @@ lilypond-bin -fgnome input/simple-song.ly (guile) (lily) (gnome gtk) + (gnome gtk gdk-event) (gnome gw libgnomecanvas)) @@ -143,60 +158,69 @@ lilypond-bin -fgnome input/simple-song.ly (display (dispatch expr) port)) (define (dispatch expr) - (let ((keyword (car expr))) - (cond - ((eq? keyword 'some-func) "") - ;;((eq? keyword 'placebox) (dispatch (cadddr expr))) - (else - (if (module-defined? this-module keyword) - (apply (eval keyword this-module) (cdr expr)) - (begin - (display - (string-append "undefined: " (symbol->string keyword) "\n")) - "")))))) - - + (if (pair? expr) + (let ((keyword (car expr))) + (cond + ((eq? keyword 'some-func) "") + ;;((eq? keyword 'placebox) (dispatch (cadddr expr))) + (else + (if (module-defined? this-module keyword) + (apply (eval keyword this-module) (cdr expr)) + (begin + (display + (string-append "undefined: " (symbol->string keyword) "\n")) + ""))))) + expr)) + +;; helper functions +(define (stderr string . rest) + (apply format (cons (current-error-port) (cons string rest))) + (force-output (current-error-port))) + +(define (item-event item event . data) + (case (gdk-event:type event) + ((enter-notify) (gobject-set-property item 'fill-color "white")) + ((leave-notify) (gobject-set-property item 'fill-color "black")) + ((2button-press) (gobject-set-property item 'fill-color "red"))) + #t) + ;;; Global vars (define main-window #f) (define canvas-root #f) -(define output-scale (* 2 2.83464566929134)) -(define system-y 0) -(define line-thickness 0.001) +(define system-origin '(0 . 0)) + +(define canvas-width 400) +(define canvas-height + (inexact->exact (round (* 1.42 canvas-width)))) +(define output-scale (* 2 2.83464566929134)) +;;(define output-scale 2.83464566929134) +;;(define output-scale 1) (define (char font i) - (let ((item (make #:x 0 #:y 0 - #:font "new century schoolbook, i bold 20" - #:text (char->string i)))) - (add canvas-root txt))) + ;;(text font (make-string 1 (integer->char i)))) + (text font "a")) (define (placebox x y expr) - #f) + (let ((item expr)) + (if item + (begin + (move item + (* output-scale (+ (car system-origin) x)) + (* output-scale (- (car system-origin) y))) + (affine-relative item output-scale 0 0 output-scale 0 0) + + (gtype-instance-signal-connect item 'event item-event) + item) + #f))) -;; gnome_canvas_item_new (gnome_canvas_root (canvas), -;; gnome_canvas_rect_get_type (), -;; "x1", (double) x1, -;; "y1", (double) y1, -;; "x2", (double) x2, -;; "y2", (double) y2, -;; "fill_color", "black", -;; "outline_color", "black", -;; "width_units", 1.0, -;; NULL); - (define (round-filled-box breapth width depth height blot-diameter) - (let* ((x1 . ,(number->string (* output-scale (- 0 breapth)))) - (y1 . ,(number->string (* output-scale (- 0 height)))) - (x2 . ,(number->string (* output-scale width))) - (y2 . ,(number->string (* output-scale height))) - ;;(ry . ,(number->string (/ blot-diameter 2))) - ;; FIXME: no rounded corners on rectangle - (item (make - #:x1 x1 #:y1 y1 #:x2 x2.0 #:y2 y2 - ;;#:width-unit blot-diameter - ))) - (add canvas-root item))) + ;; 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) @@ -207,35 +231,47 @@ lilypond-bin -fgnome input/simple-song.ly (define (header . rest) (let* ((window (make #:type 'toplevel)) (button (make #:label "Exit")) - (canvas (make )) - (vbox (make ))) + (canvas (make )) + (vbox (make #:homogeneous #f)) + (scrolled (make ))) - (gtk-container-add window vbox) - (gtk-widget-show vbox) - - (set-size-request canvas 300 300) - (gtk-container-add vbox canvas) + (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) - (gtk-container-add vbox button) (gtype-instance-signal-connect button 'clicked (lambda (b) (gtk-main-quit))) - (gtk-widget-show canvas) - (gtk-widget-show button) - (gtk-widget-show window) + ;; papersize + (set-size-request canvas canvas-width canvas-height) + (set-scroll-region canvas 0 0 2000 4000) + (show-all window) (set! canvas-root (root canvas)) (set! main-window window))) (define (text font string) - (let ((item (make #:x 0 #:y 0 - #:font "new century schoolbook, i bold 20" - #:text string))) - (add canvas-root txt))) + (make + #:parent canvas-root + #:x 0 #:y 0 + #:size-points 12 + #:size-set #t + #:font "new century schoolbook, i bold 20" + #:fill-color "black" + #:text string)) (define (filledbox a b c d) (round-filled-box a b c d 0.001)) ;; WTF is this in every backend? -(define (horizontal-line x1 x2 th) - (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th))) +(define (horizontal-line x1 x2 thickness) + ;;(let ((thickness 2)) + (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) + +(define (start-system origin . rest) + (set! system-origin origin)) +