X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-gnome.scm;h=714d7372ea65e71637c84f183da880361a44ab2f;hb=09d3a31e317dd1b24ea57fed99c21acdbd7e9b1c;hp=a771a5cd8051c227662abab10847f281fd3df2ca;hpb=4511ab0f51688d176778af27b2f069e05809e5b0;p=lilypond.git diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index a771a5cd80..714d7372ea 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -4,285 +4,105 @@ ;;;; ;;;; (c) 2004 Jan Nieuwenhuizen - -;;; HIP -- hack in progress +;;; TODO: ;;; +;;; * Figure out and fix font scaling and character placement +;;; * EC font package: add missing X font directories and AFMs +;;; * User-interface, keybindings +;;; * Implement missing stencil functions +;;; * Implement missing commands +;;; * More information in stencils, e.g., location and grob tag. +;;; * Embedded Lily: +;;; - allow GnomeCanvas or `toplevel' GtkWindow to be created +;;; outside of LilyPond +;;; - lilylib. +;;; * Release schedule and packaging of dependencies. This hack +;;; depends on several CVS and TLA development sources. + ;;; You need: ;;; -;;; * guile-1.6.4 (NOT CVS) -;;; * Rotty's g-wrap--tng, possibly Janneke's if you have libffi-3.4. -;;; * lilypond branch: lilypond_2_3_2b; the framework-* backend -;;; loads output-gnome.scm at startup, which seems to break g-wrapped -;;; goops. -;;; -;;; see also: guile-gtk-general@gnu.org +;;; * Rotty's g-wrap--tng TLA, possibly Janneke's if you have libffi-3.4. +;;; * guile-gnome TLA +;;; * pango CVS (ie, > 2004-06-12) ;;; +;;; See also: guile-gtk-general@gnu.org + ;;; Try it ;;; -;;; * Install g-wrap, guile-gnome (see script below) +;;; * Get cvs and tla +;;; +;;; * Install gnome/gtk and libffi development stuff +;;; +;;; * Install pango, g-wrap and guile-gnome from CVS or arch: +;;; see buildscripts/guile-gnome.sh ;;; -;;; * Use latin1 encoding for gnome backend, do -;;; make -C mf clean -;;; make -C mf ENCODING_FILE=$(kpsewhich cork.enc) -;;; (cd mf/out && mkfontdir) -;;; xset +fp $(pwd)/mf/out +;;; * Build LilyPond with gui support: configure --enable-gui ;;; -;;; * Setup PATHs: - +;;; * Supposing that LilyPond was built in ~/cvs/lilypond, tell X about +;;; feta fonts: " -# do not use guile CVS: -export PATH=/usr/bin/:$PATH -# use g-wrap and guile-gnome from usr/pkg -export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile -export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib +ln -s ~/cvs/lilypond/mf/out ~/.fonts +mkfontdir ~/.fonts +xset +fp ~/.fonts " - -;;; * Set XEDITOR and add -;;; #(ly:set-point-and-click 'line-column) -;;; to your .ly to get point-and-click -;;; -;;; * Run lily: lilypond-bin -fgnome input/simple-song.ly ;;; +;;; * Setup environment +" +export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$HOME/usr/pkg/g-wrap/share/guile/site/g-wrap:$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH +export LD_LIBRARY_PATH=$HOME/usr/pkg/pango/lib:$HOME/usr/pkg/g-wrap/lib:$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH +export XEDITOR='/usr/bin/emacsclient --no-wait +%l:%c %f' +" +;;; * Also for GNOME point-and-click, you need to set XEDITOR and add +" +#(ly:set-point-and-click 'line-column) +" +;;; to your .ly. ;;; -;;; todo: hmm --output-base broken? -;;; ### cd mf && mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf && mv feta20.pfa out - -;;; TODO: -;;; * pango+feta font (see archives gtk-i18n-list@gnome.org and -;;; lilypond-devel) -;;; - wait for/help with pango 1.6 -;;; - convert feta to OpenType (CFF) or TrueType (fontforge?) -;;; - hack feta20/feta20.pfa?: -;;; * font, canvas, scaling? -;;; * implement missing stencil functions -;;; * implement missing commands -;;; * user-interface, keybindings -;;; * cleanups: (too many) global vars - -;;; Note: this install information is volatile -;;; you'll probably want to pull all from -;;; from guile-gnome-devel@gnu.org--2004 soon -;;; - +;;; * Run lily: " -#!/bin/bash - -set -ex - -# no CVS guile. -export PATH=/usr/bin/:$PATH - -if [ -d $HOME/usr/pkg/libffi/ ] ; then - export LDFLAGS=-L$HOME/usr/pkg/libffi/lib/ - export CPPFLAGS=-I$HOME/usr/pkg/libffi/include -fi - -export AUTOMAKE=automake-1.8 -export AUTOCONF=autoconf2.50 - -rm -rf test -mkdir test -cd test - -## 1. install gnome-devel (Debian/unstable: apt-get install gnome-devel) - -## 2. *** NOTE: use guile-1.6 for g-wrap and guile-gnome *** -##### using GUILE CVS g-wrap/guile-gnome is experimental (read: segfaults) -PATH=/usr/bin:$PATH - - -## 3. get g-wrap 2.0 -tla register-archive a.rottmann@gmx.at--2004-main http://people.debian.org/~rotty/arch/a.rottmann@gmx.at/2004-main || true - -rm -rf g-wrap -## tla get a.rottmann@gmx.at--2004-main/g-wrap--tng g-wrap -## pull latest g-wrap from janneke -- this step is probably no longer -## necessary when you read this -tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true -tla get janneke@gnu.org--2004-gnome/g-wrap--janneke g-wrap -cd g-wrap - -rm -rf $HOME/usr/pkg/g-wrap -sh autogen.sh --noconfigure -mkdir =build -cd =build -../configure --prefix=$HOME/usr/pkg/g-wrap -make install - -# cp srfi-34.scm from CVS head ? --hwn -(cd $HOME/usr/pkg/g-wrap/share/guile/site - mv srfi-34.scm srfi-34.scm-g-wrap - cp $HOME/usr/pkg/guile/share/guile-1.7/srfi/srfi-34.scm .) - -cd ../.. - -## 4. get guile-gnome -tla register-archive guile-gnome-devel@gnu.org--2004 http://people.debian.org/~rotty/arch/guile-gnome-devel@gnu.org/2004/ || true -rm -rf guile-gnome -tla get guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome -cd guile-gnome -tla build-config -r configs/gnu.org/dev -cd src - -## 5. get the gnome canvas module -tla get guile-gnome-devel@gnu.org--2004/libgnomecanvas--dev libgnomecanvas - -## pull latest defs from janneke -- this step is probably no longer -## necessary when you read this -## tla register-archive janneke@gnu.org--2004-gnome http://lilypond.org/~janneke/{arch}/2004-gnome || true -## rm -rf defs -## tla get janneke@gnu.org--2004-gnome/defs--janneke defs - -rm -rf $HOME/usr/pkg/guile-gnome -sh autogen.sh --noconfigure -mkdir ../=build -cd ../=build - -export GUILE_LOAD_PATH=$HOME/usr/pkg/g-wrap/share/guile/site:$GUILE_LOAD_PATH -export LD_LIBRARY_PATH=$HOME/usr/pkg/g-wrap/lib:$LD_LIBRARY_PATH -export PKG_CONFIG_PATH=$HOME/usr/pkg/g-wrap/lib/pkgconfig:$PKG_CONFIG_PATH - -../src/configure --prefix=$HOME/usr/pkg/guile-gnome - - -# requires 800mb RAM with -O2 -(cd libgnomecanvas/gnome/gw; perl -i~ -pe 's/-O2//g' Makefile) - -G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install - -export GUILE_LOAD_PATH=$HOME/usr/pkg/guile-gnome/share/guile:$GUILE_LOAD_PATH -export LD_LIBRARY_PATH=$HOME/usr/pkg/guile-gnome/lib:$LD_LIBRARY_PATH -guile -s ../src/libgnomecanvas/examples/canvas.scm - - -# simple test -guile -s ../src/libgnomecanvas/examples/canvas.scm - +lilypond-bin -fgnome input/simple-song.ly " +;;; point-and-click: (mouse-1) click on a graphical object; +;;; grob-property-list: (mouse-3) click on a graphical object. (debug-enable 'backtrace) (define-module (scm output-gnome)) - (define this-module (current-module)) (use-modules (guile) - (ice-9 regex) (srfi srfi-13) (lily) - (gnome gtk) - (gnome gtk gdk-event) - ;; the name of the module will change to canvas rsn - ;;(gnome gw libgnomecanvas)) - (gnome gw canvas)) - - -;;; Lily output interface --- fix silly names and docme - -" - The output interface has functions for - * formatting stencils, and - * output commands + (gnome gtk)) - Stencils: - beam - bezier-sandwich - bracket - ... - Commands: - define-fonts - header - placebox - ... +;; 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))) - The Bare minimum interface for \score { \notes c } } should - implement: - - INTERFACE-output-expression - char - filledbox - placebox - - and should intercept: -" - -(define (dummy . foo) #f) - -;; minimal intercept list: -(define output-interface-intercept - '(comment - define-fonts - end-output - header - header-end - lily-def - no-origin - output-scopes - start-page - stop-page - start-system - stop-system)) - -(map (lambda (x) (module-define! this-module x dummy)) - output-interface-intercept) - -(define-public (gnome-output-expression expr port) - (display (dispatch expr) port)) - -(define (dispatch expr) - (if (pair? expr) - (let ((keyword (car expr))) - (cond - ((eq? keyword 'some-func) "") - ;;((eq? keyword 'placebox) (dispatch (cadddr expr))) - (else - (if (module-defined? this-module keyword) - (apply (eval keyword this-module) (cdr expr)) - (begin - (display - (string-append "undefined: " (symbol->string keyword) "\n")) - ""))))) - expr)) - -;;; Global vars -(define main-window #f) -(define main-scrolled #f) -(define main-canvas #f) -(define canvas-root #f) -(define page-number 0) - -(define page-stencils #f) -(define output-canvas #f) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; globals +;; junkme (define system-origin '(0 . 0)) -;; UGHr -(define item-locations (make-hash-table 31)) -(define location #f) - -(define canvas-width 400) -(define canvas-height - (inexact->exact (round (* 1.42 canvas-width)))) - -(define font-paper #f) - -;;(define pixels-per-unit 1.0) -(define pixels-per-unit 2.0) +;;; set by framework-gnome.scm +(define canvas-root #f) +(define output-scale #f) -;; TODO: use canvas scaling, use output-scale for paper/canvas dimensions? -;;(define output-scale (* 2 2.83464566929134)) -;;(define output-scale 2.83464566929134) -(define OUTPUT-SCALE 2.83464566929134) -(define output-scale (* OUTPUT-SCALE pixels-per-unit)) -;;(define output-scale 1) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helper functions + (define (stderr string . rest) - (apply format (cons (current-error-port) (cons string rest))) - (force-output (current-error-port))) + ;; debugging + (if #f + (begin + (apply format (cons (current-error-port) (cons string rest))) + (force-output (current-error-port))))) (define (utf8 i) (cond @@ -306,90 +126,25 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (utf8 i) (utf8 (+ #xee00 i)))) -(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) - (set! ifs (getenv "IFS"))) - (if (not ifs) - (set! ifs " ")) - ifs) - -(define (spawn-editor location) - (let* ((line (car location)) - (column (cadr location)) - (file-name (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))) - - (stderr "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) - (case (gdk-event:type event) - ((enter-notify) (gobject-set-property item 'fill-color "white")) - ((leave-notify) (gobject-set-property item 'fill-color "black")) - ((button-press) - (let ((location (hashq-ref item-locations item #f))) - (if location - (location-callback location) - (stderr "no location\n")))) - ((2button-press) (gobject-set-property item 'fill-color "red"))) - #t) - -;; TODO: one list per-page -(define text-items '()) -(define (scale-canvas factor) - (set! pixels-per-unit (* pixels-per-unit factor)) - (set-pixels-per-unit main-canvas pixels-per-unit) - (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)) - -(define (key-press-event item event . data) - (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 #t ;;(null? mods) - (eq? keyval gdk:plus)) - (scale-canvas 2)) - ((and #t ;; (null? mods) - (eq? keyval gdk:minus)) - (scale-canvas 0.5)) - ((or (eq? keyval gdk:Page-Up) - (eq? keyval gdk:BackSpace)) - (dump-page (1- page-number))) - ((or (eq? keyval gdk:Page-Down) - (eq? keyval gdk:space)) - (dump-page (1+ page-number)))) - #f)) +(define (draw-rectangle x1 y1 x2 y2 color width-units) + (make + #:parent (canvas-root) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2 + #:fill-color color #:width-units width-units)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; stencil outputters +;;; + +;;; catch-all for missing stuff +;;; comment this out to see find out what functions you miss :-) +(define (dummy . foo) #f) +(map (lambda (x) (module-define! this-module x dummy)) + (append + (ly:all-stencil-expressions) + (ly:all-output-backend-commands))) + + (define (char font i) (text font (utf8 i))) @@ -405,98 +160,53 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (* output-scale (+ (car system-origin) x)) (* output-scale (- (car system-origin) y))) (affine-relative item output-scale 0 0 output-scale 0 0) - - (gtype-instance-signal-connect item 'event item-event) - (if location - (hashq-set! item-locations item location)) item) #f))) (define (round-filled-box breapth width depth height blot-diameter) - ;; FIXME: no rounded corners on rectangle - (make - #:parent canvas-root - #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height) - #:fill-color "black" #:width-units blot-diameter)) - -;;(define (fontify font expr) -;; #f) - -(define (main outputter pages) - (let* ((window (make #:type 'toplevel)) - (button (make #:label "Exit")) - (next (make #:label "Next")) - (prev (make #:label "Previous")) - (canvas (make )) - (vbox (make #:homogeneous #f)) - (hbox (make #:homogeneous #f)) - (scrolled (make ))) - - (add window vbox) - (add vbox scrolled) - (add scrolled canvas) - - ;;(set-size-request button canvas-width 20) - ;;(add vbox button) - ;;(set-child-packing vbox button #f #f 0 'end) - - (add vbox hbox) - (set-size-request hbox canvas-width 25) - (set-child-packing vbox hbox #f #f 0 'end) - - (set-child-packing hbox button #f #f 0 'end) - ;;(set-size-request next 40 25) - ;;(set-size-request prev 40 25) - (set-size-request button (/ canvas-width 2) 25) - - (add hbox next) - (add hbox prev) - (add hbox button) - - - (gtype-instance-signal-connect button 'clicked - (lambda (b) (gtk-main-quit))) - (gtype-instance-signal-connect next 'clicked - (lambda (b) (dump-page (1+ page-number)))) - (gtype-instance-signal-connect prev 'clicked - (lambda (b) (dump-page (1- page-number)))) - - ;; papersize - (set-size-request canvas canvas-width canvas-height) - (set-scroll-region canvas 0 0 2000 4000) - (set-pixels-per-unit canvas pixels-per-unit) - - (gtype-instance-signal-connect window 'key-press-event key-press-event) - (show-all window) - - ;; HMMM - (set! canvas-root (root canvas)) - (set! main-canvas canvas) - (set! main-window window) - (set! output-canvas outputter) - (set! page-stencils pages) - (set! main-scrolled scrolled) - - (dump-page 0) - (gtk-main))) + ;; FIXME: no rounded corners on rectangle... + ;; FIXME: blot? + (draw-rectangle (- breapth) depth width (- height) "black" blot-diameter)) (define (pango-font-name font) (cond ((equal? (ly:font-name font) "GNU-LilyPond-feta-20") "lilypond-feta, regular 32") (else - (ly:font-filename font)))) + ;; FIXME + "ecrm12"))) + ;;(ly:font-name font)))) + ;;(ly:font-filename font)))) (define (pango-font-size font) (let* ((designsize (ly:font-design-size font)) (magnification (* (ly:font-magnification font))) - ;;(ops (ly:paper-lookup paper 'outputscale)) - ;;(ops (* pixels-per-unit OUTPUT-SCALE)) - ;;(ops (* pixels-per-unit pixels-per-unit)) - (ops (* (/ 12 20) (* pixels-per-unit pixels-per-unit))) + + ;; experimental sizing: + ;; where does factor come from? + ;; + ;; 0.435 * (12 / 20) = 0.261 + ;; 2.8346456692913/ 0.261 = 10.86071137659501915708 + ;;(ops (* 0.435 (/ 12 20) (* output-scale pixels-per-unit))) + ;; for size-points + (ops 2.61) + (scaling (* ops magnification designsize))) + (stderr "OPS:~S\n" ops) + (stderr "scaling:~S\n" scaling) + (stderr "magnification:~S\n" magnification) + (stderr "design:~S\n" designsize) + scaling)) +;;font-name: "GNU-LilyPond-feta-20" +;;font-filename: "feta20" +;;pango-font-name: "lilypond-feta, regular 32" +;;OPS:2.61 +;;scaling:29.7046771653543 +;;magnification:0.569055118110236 +;;design:20.0 + (define (text font string) (stderr "font-name: ~S\n" (ly:font-name font)) ;; TODO s/filename/file-name/ @@ -504,80 +214,42 @@ guile -s ../src/libgnomecanvas/examples/canvas.scm (stderr "pango-font-name: ~S\n" (pango-font-name font)) (stderr "pango-font-size: ~S\n" (pango-font-size font)) - (set! - text-items - (cons - (make - #:parent canvas-root - #:x 0 #:y 0 - ;; #:font "new century schoolbook, i bold 20" - #:font (pango-font-name font) - ;; #:size-points 12 - #:size-points (pango-font-size font) - ;;#:size (pango-font-size font) - #:size-set #t - - ;;apparently no effect :-( - ;;#:scale 1.0 - ;;#:scale-set #t - - #:fill-color "black" - #:text string - #:anchor 'west) - text-items)) - (car text-items)) + + (make + #:parent (canvas-root) + + ;; experimental text placement corrections. + ;; UGHR? What happened to tex offsets? south-west? + ;; is pango doing something 'smart' wrt baseline ? + #:anchor 'south-west + #:x 0.003 #:y 0.123 + + ;;#:anchor 'west + ;;#:x 0.015 #:y -3.71 + + #:font (pango-font-name font) + + #:size-points (pango-font-size font) + ;;#:size ... + #:size-set #t + + ;;apparently no effect :-( + ;;#:scale 1.0 + ;;#:scale-set #t + + #:fill-color "black" + #:text string)) (define (filledbox a b c d) (round-filled-box a b c d 0.001)) ;; WTF is this in every backend? (define (horizontal-line x1 x2 thickness) - ;;(let ((thickness 2)) (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) -(define (start-system origin . rest) - (set! system-origin origin)) - -;; origin -- bad name -(define (define-origin file line col) - ;; ughr, why is this not passed as [part of] stencil object - (set! location (if (procedure? point-and-click) - ;; duh, only silly string append - ;; (point-and-click line col file) - (list line col file) - #f))) - -(define (dump-page number) - (if (or (not page-stencils) - (< number 0) - (>= number (vector-length page-stencils))) - (stderr "No such page: ~S\n" (1+ number)) - (begin - (set! page-number number) - - ;; no destroy method for gnome-canvas-text? - ;;(map destroy (gtk-container-get-children main-canvas)) - ;;(map destroy text-items) - - ;; UGHR - destroying the whole canvas.... - (if (and main-canvas - (not (null? text-items))) - (let* ((canvas (make )) - (root (root canvas))) - - (destroy main-canvas) - (add main-scrolled canvas) - - ;; papersize - (set-size-request canvas canvas-width canvas-height) - (set-scroll-region canvas 0 0 2000 4000) - (set-pixels-per-unit canvas pixels-per-unit) - (show canvas) - - (set! main-canvas canvas) - (set! canvas-root root) - (set! text-items '()))) - - (ly:outputter-dump-stencil output-canvas - (vector-ref page-stencils page-number))))) +;;(define (define-origin file line col) +;; (if (procedure? point-and-click) +;; (list 'location line col file))) +(define (grob-cause grob) + grob)