X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-gnome.scm;h=9e8cf4510d955dcd123aca45a1fd85927ab79072;hb=5d576b1299d374ae478cb38075cc05d5cb691046;hp=21c03564ec6d6320bef0b57798137379552c0020;hpb=ffbaef8018d42f1636c9cd47885fbc187a08f3a8;p=lilypond.git diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm index 21c03564ec..9e8cf4510d 100644 --- a/scm/framework-gnome.scm +++ b/scm/framework-gnome.scm @@ -2,14 +2,18 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Jan Nieuwenhuizen +;;;; (c) 2004--2006 Jan Nieuwenhuizen ;;;; See output-gnome.scm for usage information. (define-module (scm framework-gnome)) -(use-modules (guile) (oop goops) (lily)) +(use-modules (guile) + (oop goops) + (scm page) + (scm paper-system) + (lily)) (use-modules (srfi srfi-2) @@ -18,66 +22,7 @@ (gnome gtk gdk-event) (gnome gw canvas)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Wrappers from guile-gnome TLA -;;; guile-gnome-devel@gnu.org--2004 -;;; http://arch.gna.org/guile-gnome/archive-2004 -;;; -;;; janneke@gnu.org--2004-gnome -;;; http://lilypond.org/~janneke/{arch}/2004-gnome -;;; -(if (not (defined? 'gdk-event-motion:x)) - (define (gdk-event-motion:x event) - (let ((vector (gdk-event->vector event))) - (case (gdk-event:type event) - ((motion-notify) - (vector-ref vector 4)) - (else - (gruntime-error "Event not of the proper type: ~A" event)))))) - -(if (not (defined? 'gdk-event-motion:y)) - (define (gdk-event-motion:y event) - (let ((vector (gdk-event->vector event))) - (case (gdk-event:type event) - ((motion-notify) - (vector-ref vector 5)) - (else - (gruntime-error "Event not of the proper type: ~A" event)))))) - -; (if (not (defined? 'gdk-event-motion:x-root)) -; (define (gdk-event-motion:x-root event) -; (let ((vector (gdk-event->vector event))) -; (case (gdk-event:type event) -; ((motion-notify) -; (vector-ref vector 9)) -; (else -; (gruntime-error "Event not of the proper type: ~A" event)))))) - -; (if (not (defined? 'gdk-event-motion:y-root)) -; (define (gdk-event-motion:y-root event) -; (let ((vector (gdk-event->vector event))) -; (case (gdk-event:type event) -; ((motion-notify) -; (vector-ref vector 10)) -; (else -; (gruntime-error "Event not of the proper type: ~A" event)))))) - -(if (not (defined? 'gdk-event-button:modifiers)) - (define (gdk-event-button:modifiers event) - (let ((vector (gdk-event->vector event))) - (case (gdk-event:type event) - ((button-press button-release) - ;; We have to do some hackery here, because there are bitmasks - ;; used by XKB that we don't know about. - (gflags->symbol-list - (make - #:value (logand #x1fff (vector-ref vector 6))))) - (else - (gruntime-error "Event not of the proper type: ~A" event)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-public (output-framework outputter book scopes fields basename) +(define-public (output-framework basename book scopes fields ) (gnome-main book basename)) (define SCROLLBAR-SIZE 20) @@ -89,14 +34,10 @@ (define OUTPUT-SCALE (* 2.5 PIXELS-PER-UNIT)) (define-public output-scale OUTPUT-SCALE) -(define (stderr string . rest) - (apply format (cons (current-error-port) (cons string rest))) - (force-output (current-error-port))) - (define (debugf string . rest) (if #f (apply stderr (cons string rest)))) - + (define-class () (name #:init-value "untitled" #:init-keyword #:name #:accessor name) @@ -170,12 +111,12 @@ (define (gnome-main book name) (let* ((paper (ly:paper-book-paper book)) - (hsize (ly:output-def-lookup paper 'hsize)) - (vsize (ly:output-def-lookup paper 'vsize)) - (page-width (inexact->exact (ceiling (* OUTPUT-SCALE hsize)))) - (page-height (inexact->exact (ceiling (* OUTPUT-SCALE vsize)))) - ;;(page-width (inexact->exact (ceiling hsize))) - ;;(page-height (inexact->exact (ceiling vsize))) + (paper-width (ly:output-def-lookup paper 'paper-width)) + (paper-height (ly:output-def-lookup paper 'paper-height)) + (page-width (inexact->exact (ceiling (* OUTPUT-SCALE paper-width)))) + (page-height (inexact->exact (ceiling (* OUTPUT-SCALE paper-height)))) + ;;(page-width (inexact->exact (ceiling paper-width))) + ;;(page-height (inexact->exact (ceiling paper-height))) (screen-width (gdk-screen-width)) (screen-height (gdk-screen-height)) @@ -183,7 +124,7 @@ (go (make #:name name - #:page-stencils (list->vector (ly:paper-book-pages book)) + #:page-stencils (list->vector (map page-stencil (ly:paper-book-pages book))) #:canvas-width page-width #:canvas-height page-height #:window-width @@ -197,20 +138,6 @@ ;; possibly a goops 1.6.4 problem (initialize go) - (map ly:pango-add-afm-decoder - '("lilypond-feta" - "lilypond-feta-braces-a" - "lilypond-feta-braces-b" - "lilypond-feta-braces-c" - "lilypond-feta-braces-d" - "lilypond-feta-braces-d" - "lilypond-feta-braces-e" - "lilypond-feta-braces-f" - "lilypond-feta-braces-g" - "lilypond-feta-braces-h" - "lilypond-feta-braces-i" - "lilypond-parmesan")) - (dump-page go 0) (gtk-main))) @@ -243,12 +170,6 @@ (add (scrolled go) (canvas go)) (show (canvas go))))) -(define x-editor #f) -(define (get-x-editor) - (if (not x-editor) - (set! x-editor (getenv "XEDITOR"))) - x-editor) - (define ifs #f) (define (get-ifs) (if (not ifs) @@ -256,70 +177,61 @@ (if (not ifs) (set! ifs " ")) ifs) - + (define (spawn-editor location) (let* ((file-name (car location)) (line (cadr location)) - (column (caddr location)) - (template (substring (get-x-editor) 0)) - - ;; Adhere to %l %c %f? - (command - (regexp-substitute/global - #f "%l" (regexp-substitute/global - #f "%c" - (regexp-substitute/global - #f "%f" template 'pre file-name 'post) - 'pre (number->string column) - 'post) - 'pre (number->string line) 'post))) - + (char (caddr location)) + (column (cadddr location)) + (command (get-editor-command file line char column))) (debugf "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 (get-location grob) - (and-let* ((p? (procedure? point-and-click)) + (and-let* ((p (procedure? point-and-click)) (g grob) (cause (ly:grob-property grob 'cause)) - (music-origin (if (ly:music? cause) - (ly:music-property cause 'origin) - ;; How come # [and '()] + (music-origin (if (ly:event? cause) + (ly:event-property cause 'origin) + ;; How come # [and '()] ;; are #t? :-( #f))) (if (ly:input-location? music-origin) (ly:input-location music-origin) #f))) +;; todo: how to integrate nicely? +;(define-public (tweak-grob-property grob sym val) +; (set! (ly:grob-property grob sym) val)) + (define-method (tweak (go ) item offset) (let* ((grob (hashq-ref (item-grobs go) item #f)) (extra-offset (ly:grob-property grob 'extra-offset)) (origin (if (null? extra-offset) '(0 . 0) - (cons (car extra-offset) - (- 0 (cdr extra-offset)))))) - + (offset-flip-y extra-offset)))) + (if grob - (ly:insert-tweak grob (list tweak-grob-property - 'extra-offset - (offset-add origin offset)))))) + (ly:grob-replace-tweak + grob (list tweak-grob-property + 'extra-offset + (offset-flip-y (offset-add origin offset))))))) (define-method (save-tweaks (go )) - (let* - ((dumper (ly:make-dumper)) - (tweaks (ly:all-tweaks)) - (serialized-tweaks (map - (lambda (tweak) - (append - (list - (ly:dumper-key-serial dumper (car tweak)) - (list 'unquote (procedure-name (cadr tweak)))) - (cddr tweak))) - tweaks))) + (let* ((dumper (ly:make-dumper)) + (tweaks (ly:all-tweaks)) + (serialized-tweaks + (map + (lambda (tweak) (append + (list (ly:dumper-key-serial dumper (car tweak)) + (list 'unquote (procedure-name (cadr tweak)))) + (cddr tweak))) + tweaks))) (if (not (null? serialized-tweaks)) (let ((file (open-file (string-append (name go) ".twy") "w"))) @@ -373,51 +285,50 @@ (begin (stderr "CLICK WITH MODIFIERS: ~S\n" (gdk-event-button:modifiers event)) - + ;; some modifier, do jump to source (and-let* ((grob (hashq-ref (item-grobs go) item #f)) (location (get-location grob))) (location-callback location))))) ((= button 2) - (and-let* - ((grob (hashq-ref (item-grobs go) item #f))) - - (let ((properties (ly:grob-properties grob)) - (basic-properties (ly:grob-basic-properties grob)) - (x (inexact->exact (gdk-event-button:x-root event))) - (y (inexact->exact (gdk-event-button:y-root event)))) - - (debugf "GROB: ~S\n" grob) - (debugf "PROPERTIES: ~S\n" properties) - (debugf "BASIC PROPERTIES: ~S\n" basic-properties) - - ;; FIXME: dialog iso window? - ;; http://www.gtk.org/tutorial/sec-textentries.html - (let ((window (make )) - (vbox (make )) - (ok (make #:label "Ok"))) - - (add window vbox) - (connect ok 'clicked (lambda (b) (destroy window))) - - (for-each - (lambda (x) - (let ((label (make - ;;#:label (symbol->string (car x)))) - #:label (format #f "~S" (car x)))) - ;;(symbol->string (car x)))) - (entry (make - #:text (format #f "~S" (cdr x)))) - (hbox (make ))) - (add hbox label) - (add hbox entry) - (set-size-request label 150 BUTTON-HEIGHT) - (add vbox hbox))) - (append properties basic-properties)) - (add vbox ok) - - (show-all window) - (move window x y)))))))) + (and-let* ((grob (hashq-ref (item-grobs go) item #f))) + + (let ((properties (ly:grob-properties grob)) + (basic-properties (ly:grob-basic-properties grob)) + (x (inexact->exact (gdk-event-button:x-root event))) + (y (inexact->exact (gdk-event-button:y-root event)))) + + (debugf "GROB: ~S\n" grob) + (debugf "PROPERTIES: ~S\n" properties) + (debugf "BASIC PROPERTIES: ~S\n" basic-properties) + + ;; FIXME: dialog iso window? + ;; http://www.gtk.org/tutorial/sec-textentries.html + (let ((window (make )) + (vbox (make )) + (ok (make #:label "Ok"))) + + (add window vbox) + (connect ok 'clicked (lambda (b) (destroy window))) + + (for-each + (lambda (x) + (let ((label (make + ;;#:label (symbol->string (car x)))) + #:label (format #f "~S" (car x)))) + ;;(symbol->string (car x)))) + (entry (make + #:text (format #f "~S" (cdr x)))) + (hbox (make ))) + (add hbox label) + (add hbox entry) + (set-size-request label 150 BUTTON-HEIGHT) + (add vbox hbox))) + (append properties basic-properties)) + (add vbox ok) + + (show-all window) + (move window x y)))))))) ((2button-press) (gobject-set-property item 'fill-color "green")) ((key-press) @@ -447,7 +358,7 @@ (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 go))) + (text-items go))) (define (key-press-event go item event) (let ((keyval (gdk-event-key:keyval event)) @@ -456,6 +367,9 @@ (eq? keyval gdk:w)) (equal? mods '(control-mask modifier-mask))) (gtk-main-quit)) + ((and (eq? keyval gdk:s) + (equal? mods '(control-mask modifier-mask))) + (save-tweaks go)) ((and #t ;;(null? mods) (eq? keyval gdk:plus)) (scale-canvas go 2))