;;;;
;;;; source file of the GNU LilyPond music typesetter
;;;;
-;;;; (c) 2004 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; (c) 2004--2006 Jan Nieuwenhuizen <janneke@gnu.org>
;;;; 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)
(gnome gtk gdk-event)
(gnome gw canvas))
-(define-public (output-framework outputter book scopes fields basename)
- (gnome-main book))
+(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)
- (apply format (cons (current-error-port) (cons string rest)))
- (force-output (current-error-port)))
-
(define (debugf string . rest)
(if #f
- (stderr (cons string rest))))
-
+ (apply stderr (cons string rest))))
+
(define-class <gnome-outputter> ()
+ (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 <gtk-window> #:type 'toplevel) #:accessor window)
(canvas-height #:init-keyword #:canvas-height #:accessor canvas-height))
(define-method (initialize (go <gnome-outputter>))
- (let* ((button (make <gtk-button> #:label "Exit"))
+ (let* ((save (make <gtk-button> #:label "Save"))
+ (exit (make <gtk-button> #:label "Exit"))
(next (make <gtk-button> #:label "Next"))
(prev (make <gtk-button> #:label "Previous"))
(vbox (make <gtk-vbox> #:homogeneous #f))
;;(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
- (connect button 'clicked (lambda (b) (gtk-main-quit)))
+ (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
(show-all (window go))))
-(define (gnome-main book)
+(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))
(desktop-height (- screen-height PANELS-HEIGHT))
(go (make <gnome-outputter>
- #:page-stencils (list->vector (ly:paper-book-pages book))
+ #:name name
+ #:page-stencils (list->vector (map page-stencil (ly:paper-book-pages book)))
#:canvas-width page-width
#:canvas-height page-height
#:window-width
;; 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)))
(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)
(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)
(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 <gnome-outputter>) 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 <gnome-outputter>))
+ (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)
(let ((button (gdk-event-button:button event)))
(cond
((= button 1)
- (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))))
+ (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))
- (debugf "GROB: ~S\n" grob)
- (debugf "PROPERTIES: ~S\n" properties)
- (debugf "BASIC PROPERTIES: ~S\n" basic-properties)
-
- (let ((window (make <gtk-window>))
- (vbox (make <gtk-vbox>))
- (button (make <gtk-button> #:label "Ok")))
-
- (add window vbox)
- (connect button 'clicked (lambda (b) (destroy window)))
-
- (for-each
- (lambda (x)
- (let ((button (make <gtk-button>
- #:xalign 0.0
- #:label
- (string-append
- (symbol->string (car x))
- ": "
- (format #f "~S" (cdr x))))))
- (set-size-request button 150 BUTTON-HEIGHT)
- (add vbox button)))
- properties)
- (add vbox button)
-
- ;; FIXME: how to do window placement?
- ;; - no effect:
- (move window x y)
- (show-all window)
- ;; - shows actual movement:
- (move window x y)
- )))))))
+ ;; 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 <gtk-window>))
+ (vbox (make <gtk-vbox>))
+ (ok (make <gtk-button> #:label "Ok")))
+
+ (add window vbox)
+ (connect ok 'clicked (lambda (b) (destroy window)))
+
+ (for-each
+ (lambda (x)
+ (let ((label (make <gtk-label>
+ ;;#:label (symbol->string (car x))))
+ #:label (format #f "~S" (car x))))
+ ;;(symbol->string (car x))))
+ (entry (make <gtk-entry>
+ #:text (format #f "~S" (cdr x))))
+ (hbox (make <gtk-hbox>)))
+ (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")))
+ ((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 go factor)
(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))
(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))
(if (is-a? result <gnome-canvas-text>)
(set! (text-items go) (cons result (text-items go))))))))
-
projects / lilypond.git / blobdiff