X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-gnome.scm;h=fb492474b8630cab67b93fd158f9c7330f2fc36d;hb=c37888fe2f06304914ae980b26cb82de2b1deccf;hp=fb1c34914ec4c628fe5965422c0b5279bd05cb8e;hpb=2be67678488b5829a52acdf36ab4278477375b6d;p=lilypond.git diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm index fb1c34914e..fb492474b8 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. @@ -12,42 +12,36 @@ (use-modules (guile) (oop goops) (lily)) (use-modules + (srfi srfi-2) (ice-9 regex) (gnome gtk) - (gnome gtk gdk-event)) - -;; the name of the module will change to canvas rsn -(if (resolve-module '(gnome gw canvas)) - (use-modules (gnome gw canvas)) - (use-modules (gnome gw libgnomecanvas))) - -(define-public (output-framework-gnome outputter book scopes fields basename) - (if #t - (gnome-main book) - (ly:outputter-dump-stencil - outputter - (ly:make-stencil (list 'gnome-main book) '(0 . 0) '(0 . 0))))) - -;; WTF? -- jcn -;; Yay, I *finally* found it! -(define-public output-framework output-framework-gnome) + (gnome gtk gdk-event) + (gnome gw canvas)) + +(define-public (output-framework basename book scopes fields ) + (gnome-main book basename)) (define SCROLLBAR-SIZE 20) (define BUTTON-HEIGHT 25) (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) - ;; debugging +(define (debugf string . rest) (if #f - (begin - (apply format (cons (current-error-port) (cons string rest))) - (force-output (current-error-port))))) + (apply stderr (cons string rest)))) (define-class () + (name #:init-value "untitled" #:init-keyword #:name #:accessor name) + + ;; FIXME + (dragging #:init-value #f #:accessor dragging) + (drag-origin #:init-value #f #:accessor drag-origin) + (drag-location #:init-value #f #:accessor drag-location) + (page-stencils ;;#:init-value '#() #:init-keyword #:page-stencils #:accessor page-stencils) (window #:init-value (make #:type 'toplevel) #:accessor window) @@ -56,15 +50,16 @@ (page-number #:init-value 0 #:accessor page-number) (pixels-per-unit #:init-value PIXELS-PER-UNIT #:accessor pixels-per-unit) (text-items #:init-value '() #:accessor text-items) - (location #:init-value #f #:accessor location) - (item-locations #:init-value (make-hash-table 31) #:accessor item-locations) + (grob #:init-value #f #:accessor grob) + (item-grobs #:init-value (make-hash-table 31) #:accessor item-grobs) (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) (canvas-height #:init-keyword #:canvas-height #:accessor canvas-height)) (define-method (initialize (go )) - (let* ((button (make #:label "Exit")) + (let* ((save (make #:label "Save")) + (exit (make #:label "Exit")) (next (make #:label "Next")) (prev (make #:label "Previous")) (vbox (make #:homogeneous #f)) @@ -91,32 +86,29 @@ ;;(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 go) 2) BUTTON-HEIGHT) + (set-size-request exit (quotient (window-width go) 2) BUTTON-HEIGHT) (add hbox next) (add hbox prev) - (add hbox button) + (add hbox save) + (add hbox exit) ;; signals - (gtype-instance-signal-connect - button 'clicked (lambda (b) (gtk-main-quit))) - (gtype-instance-signal-connect - next 'clicked (lambda (b) (dump-page go (1+ (page-number go))))) - (gtype-instance-signal-connect - prev 'clicked (lambda (b) (dump-page go (1- (page-number go))))) - (gtype-instance-signal-connect - (window go) 'key-press-event key-press-event) + (connect exit 'clicked (lambda (b) (gtk-main-quit))) + (connect save 'clicked (lambda (b) (save-tweaks go))) + (connect next 'clicked (lambda (b) (dump-page go (1+ (page-number go))))) + (connect prev 'clicked (lambda (b) (dump-page go (1- (page-number go))))) + (connect (window go) 'key-press-event + (lambda (w e) (key-press-event go w e))) (show-all (window go)))) -(define-public global-go #f) - -(define (gnome-main book) - (let* ((book-paper (ly:paper-book-book-paper book)) - (hsize (ly:output-def-lookup book-paper 'hsize)) - (vsize (ly:output-def-lookup book-paper 'vsize)) +(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))) @@ -127,6 +119,7 @@ (desktop-height (- screen-height PANELS-HEIGHT)) (go (make + #:name name #:page-stencils (list->vector (ly:paper-book-pages book)) #:canvas-width page-width #:canvas-height page-height @@ -138,13 +131,11 @@ desktop-height)))) ;; ugh. The GOOPS doc promises this is called automagically. + ;; possibly a goops 1.6.4 problem (initialize go) - + (dump-page go 0) - ;; ugh - (set! global-go go) - (gtk-main))) (define (dump-page go number) @@ -157,12 +148,12 @@ (new-canvas go) (set! (page-number go) number) - ;; no destroy method for gnome-canvas-text? + ;; no destroy method for gnome-canvas-text yet. ;;(map destroy (gtk-container-get-children main-canvas)) ;;(map destroy text-items) (set! (text-items go) '()) - (stderr "page-stencil ~S: ~S\n" + (debugf "page-stencil ~S: ~S\n" (page-number go) (vector-ref (page-stencils go) (page-number go))) @@ -188,11 +179,11 @@ (if (not ifs) (set! ifs " ")) ifs) - + (define (spawn-editor location) - (let* ((line (car location)) - (column (cadr location)) - (file-name (caddr location)) + (let* ((file-name (car location)) + (line (cadr location)) + (column (caddr location)) (template (substring (get-x-editor) 0)) ;; Adhere to %l %c %f? @@ -206,62 +197,200 @@ 'post) 'pre (number->string line) 'post))) - (stderr "spawning: ~s\n" command) + (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 (item-event item event . data) -(define-public (item-event item event . data) +(define (get-location grob) + (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 '()] + ;; are #t? :-( + #f))) + (if (ly:input-location? music-origin) + (ly:input-location music-origin) + #f))) + + +(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) + (offset-flip-y extra-offset)))) + + (if grob + (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))) + + (if (not (null? serialized-tweaks)) + (let ((file (open-file (string-append (name go) ".twy") "w"))) + (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) + serialized-tweaks))))) + +;;;(define (item-event go grob item event) +(define (item-event go item event) + ;;(stderr "EVENT: ~S\n" event) + ;;(stderr "TYPE: ~S\n" (gdk-event:type event)) (case (gdk-event:type event) ((enter-notify) (gobject-set-property item 'fill-color "red")) ((leave-notify) (gobject-set-property item 'fill-color "black")) + ((motion-notify) (if (ly:grob? (dragging go)) + (let ((x (gdk-event-motion:x event)) + (y (gdk-event-motion:y event)) + (s output-scale) + (r (drag-location go))) + ;;(stderr "MOVED AT: ~S ~S\n" x y) + (move item (/ (- x (car r)) s) (/ (- y (cdr r)) s)) + (set! (drag-location go) (cons x y))))) + ((button-release) (if (ly:grob? (dragging go)) + (let ((x (gdk-event-button:x event)) + (y (gdk-event-button:y event)) + (s output-scale) + (o (drag-origin go)) + (r (drag-location go))) + (move item (/ (- x (car r)) s) (/ (- y (cdr r)) s)) + (set! (drag-location go) #f) + (set! (drag-origin go) #f) + (stderr "RELEASE at: ~S ~S\n" x y) + (set! (dragging go) #f) + (tweak go item (cons (/ (- x (car o)) s) + (/ (- y (cdr o)) s)))))) ((button-press) - - ;;FIXME - (let ((location (hashq-ref (item-locations global-go) item #f))) - - (if location - (location-callback location) - (stderr "no location\n")))) - ((2button-press) (gobject-set-property item 'fill-color "red"))) + (let ((button (gdk-event-button:button event))) + (cond + ((= button 1) + (if (null? (gdk-event-button:modifiers event)) + (let ((x (gdk-event-button:x event)) + (y (gdk-event-button:y event))) + (stderr "CLICK at: ~S ~S\n" x y) + (set! (dragging go) (hashq-ref (item-grobs go) item #f)) + (set! (drag-origin go) (cons x y)) + (set! (drag-location go) (cons x y))) + (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)))))))) + + ((2button-press) (gobject-set-property item 'fill-color "green")) + ((key-press) + (let ((keyval (gdk-event-key:keyval event)) + (mods (gdk-event-key:modifiers event)) + (step (quotient (pixels-per-unit go) 2))) + (cond ((and (null? mods) + (eq? keyval gdk:Up)) + (tweak go item (cons 0 (- 0 step)))) + ((and (null? mods) + (eq? keyval gdk:Down)) + (tweak go item (cons 0 step))) + ((and (null? mods) + (eq? keyval gdk:Left)) + (tweak go item (cons (- 0 step) 0))) + ((and (null? mods) + (eq? keyval gdk:Right)) + (tweak go item (cons step 0))))))) #t) -(define (scale-canvas factor) - (set! pixels-per-unit (* pixels-per-unit factor)) - (set-pixels-per-unit main-canvas pixels-per-unit) +(define (scale-canvas go factor) + (set! (pixels-per-unit go) (* (pixels-per-unit go) factor)) + (set-pixels-per-unit (canvas go) (pixels-per-unit go)) (for-each (lambda (x) (let ((scale (gobject-get-property x 'scale)) (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)) + (text-items go))) -(define (key-press-event item event . data) +(define (key-press-event go item event) (let ((keyval (gdk-event-key:keyval event)) (mods (gdk-event-key:modifiers event))) (cond ((and (or (eq? keyval gdk:q) (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 2)) + (scale-canvas go 2)) ((and #t ;; (null? mods) (eq? keyval gdk:minus)) - (scale-canvas 0.5)) + (scale-canvas go 0.5)) ((or (eq? keyval gdk:Page-Up) (eq? keyval gdk:BackSpace)) - ;;FIXME - (dump-page global-go (1- (page-number global-go)))) + (dump-page go (1- (page-number go)))) ((or (eq? keyval gdk:Page-Down) (eq? keyval gdk:space)) - ;;FIXME - (dump-page global-go (1+ (page-number global-go))))) + (dump-page go (1+ (page-number go))))) #f)) (define (new-canvas go) @@ -282,16 +411,20 @@ (module-define! m 'output-scale output-scale) (set! output-gnome-module m))) output-gnome-module) - + (define-public (gnome-output-expression go expr) (let* ((m (get-output-gnome-module go)) (result (eval expr m))) (cond - ((and (pair? result) - (eq? (car result) 'location)) - (set! (location go) (cdr result))) + ((ly:grob? result) (set! (grob go) result)) ((is-a? result ) - (gtype-instance-signal-connect result 'event item-event) - (if (location go) - (hashq-set! (item-locations go) result (location go))))))) - + + ;; AAARGH; grobs happen after stencils + ;; (connect result 'event (lambda (w e) (item-event go (grob go) w e))) + (connect result 'event (lambda (w e) (item-event go w e))) + (if (grob go) + (hashq-set! (item-grobs go) result (grob go))) + (set! (grob go) #f) + + (if (is-a? result ) + (set! (text-items go) (cons result (text-items go))))))))