X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-gnome.scm;h=d8a9699c36987071bba072f6ff4b6d093f15ae73;hb=ddd9f36c7550e064b4b6acef2f7fe491cdb5216d;hp=d11ebbbe7b85a4c10f40b4c8fc8e28e1ddaa9a28;hpb=b133adce8270d81c959b1f98663942f227b83201;p=lilypond.git

diff --git a/scm/framework-gnome.scm b/scm/framework-gnome.scm
index d11ebbbe7b..d8a9699c36 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 <janneke@gnu.org>
+;;;; (c) 2004--2005 Jan Nieuwenhuizen <janneke@gnu.org>
 
 ;;;; See output-gnome.scm for usage information.
 
@@ -18,49 +18,7 @@
  (gnome gtk gdk-event)
  (gnome gw canvas))
 
-
-;;; This is in 2.7.96 -- JUNKME.
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 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-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 <gdk-modifier-type>
-	      #: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)
@@ -72,14 +30,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 <gnome-outputter> ()
   (name #:init-value "untitled" #:init-keyword #:name #:accessor name)
 
@@ -180,23 +134,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"
-	   ;;"lilypond"
-	   ;;"bigcheese20"
-	   ))
-
     (dump-page go 0)
 
     (gtk-main)))
@@ -229,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)
@@ -242,30 +173,18 @@
   (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)))
-    
+	 (command (get-editor-command file line 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)
@@ -286,26 +205,24 @@
   (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 <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)))
+  (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")))
@@ -359,51 +276,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 <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))))))))
+	 (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"))
     ((key-press)
@@ -433,7 +349,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))
@@ -442,6 +358,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))