X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-gnome.scm;h=826a159620d0f64b40b6e7964e9d2745c1b3298c;hb=7e5826578e2218cb1a2c91906614ca6ff648c2ed;hp=21650136529ff400bad39830913b2df4ea4b9fa6;hpb=3cec7262ac857e25dcc6e8007392fb2231024aed;p=lilypond.git diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm index 2165013652..826a159620 100644 --- a/scm/framework-gnome.scm +++ b/scm/framework-gnome.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Jan Nieuwenhuizen +;;;; (c) 2004--2005 Jan Nieuwenhuizen ;;;; See output-gnome.scm for usage information. @@ -18,66 +18,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) @@ -85,17 +26,14 @@ (define PANELS-HEIGHT 80) (define PIXELS-PER-UNIT 2) +;; 2.5?? (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) @@ -114,7 +52,6 @@ (text-items #:init-value '() #:accessor text-items) (grob #:init-value #f #:accessor grob) (item-grobs #:init-value (make-hash-table 31) #:accessor item-grobs) - (grob-tweaks #:init-value (make-hash-table 31) #:accessor grob-tweaks) (window-width #:init-keyword #:window-width #:accessor window-width) (window-height #:init-keyword #:window-height #:accessor window-height) (canvas-width #:init-keyword #:canvas-width #:accessor canvas-width) @@ -197,12 +134,6 @@ ;; possibly a goops 1.6.4 problem (initialize go) - (map ly:pango-add-afm-decoder - '("lilypond-feta" - "lilypond-braces" - "lilypond-dyn" - "lilypond-parmesan")) - (dump-page go 0) (gtk-main))) @@ -235,12 +166,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) @@ -248,30 +173,19 @@ (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) @@ -287,41 +201,43 @@ (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 - (hashq-set! (grob-tweaks go) grob - (cons - 'extra-offset - (list - (cons (+ (car origin) (car offset)) - (- 0 (+ (cdr origin) (cdr offset)))))))))) - -;; FIXME: this only saves new tweaks, old tweaks are lost. + (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 (hash-fold - (lambda (grob value seed) - (cons - (list 'set-property - (list - 'key - (ly:dumper-key-serial dumper (ly:grob-key grob))) - value) - seed)) - '() (grob-tweaks go)))) - - (if (not (null? 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"))) - (format file ";;; KEYS\n`~S\n;;; TWEAKS \n`~S\n" + (format file + ";;;tweaks. Generated file. Do not edit. +(ly:tweak-clear-registry) +(ly:tweak-define-keys `~S) +(ly:tweak-define-tweaks `~S)" (ly:dumper-definitions dumper) - tweaks))))) + serialized-tweaks))))) ;;;(define (item-event go grob item event) (define (item-event go item event) @@ -365,52 +281,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)) - (id (ly:grob-id 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) @@ -440,7 +354,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)) @@ -449,6 +363,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))