X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-gnome.scm;h=2846daa9ba8b8383d53185bc96f33d07d9d593c5;hb=3b2376c6828136cdbc078015c0b9bee26bffb448;hp=809132e138485e1c6437d72bd0f7363a478ff4e2;hpb=dcae8384f0910d4b4763a49506f10f828b05ef71;p=lilypond.git diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index 809132e138..2846daa9ba 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -4,91 +4,75 @@ ;;;; ;;;; (c) 2004 Jan Nieuwenhuizen - -;;; HIP -- hack in progress +;;; TODO: ;;; -;;; status: hello-world +;;; * check: blot+scaling +;;; * 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. +;;; - g-wrap-1.9.3 is already in incoming. +;;; - guile-gnome-platform-2.8.0 will probably be packaged early 2005. + +;;; You need: ;;; -;;; This first working version needs rotty's g-wrap--tng. -;;; (janneke's guile-gnome patches now in main archive). +;;; * Rotty's g-wrap >= 1.9.3 +;;; * guile-gnome-platform >= 2.7.97 +;;; * pango >= 1.6.0 ;;; -;;; Try it: -;;; lilypond-bin -fgnome input/simple-song.ly - -;;; Set XEDITOR and add -;;; #(ly:set-point-and-click 'line-column) -;;; to your .ly to get point-and-click - -;;; 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?: use latin1 encoding for gnome backend -;;; Trying: -;;; mftrace --encoding=$(kpsewhich cork.enc) --autotrace --output-base=feta-cork-20 feta20.mf -;;; hmm --output-base broken? -;;; * implement missing stencil functions -;;; * implement missing commands (next, prev? page) -;;; * user-interface, keybindings - -;;; Note: this install information is volatile -;;; you'll probably want to pull all from -;;; from guile-gnome-devel@gnu.org--2004 soon -;;; -;;; move this into workbook? +;;; See also: guile-gtk-general@gnu.org +;;; Try it +;;; +;;; * Install gnome/gtk and libffi development stuff +;;; +;;; * Install [pango, g-wrap and] guile-gnome from source, +;;; see buildscripts/guile-gnome.sh +;;; +;;; * Build LilyPond with gui support: configure --enable-gui +;;; +;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond, +;;; tell fontconfig about the feta fonts dir and run fc-cache " -## install gnome-devel - -## use guile-1.6 for g-wrap/guile-gnome -PATH=/usr/bin:$PATH - -## 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 gw-pristine -tla get a.rottmann@gmx.at--2004-main/g-wrap--tng gw-pristine -cd gw-pristine - -AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 sh autogen.sh --noconfigure -mkdir =build -cd =build -../configure --prefix=$HOME/usr/pkg/g-wrap -make install - -cd ../.. - -## 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 guile-gnome-devel@gnu.org--2004/dists--dev guile-gnome -cd guile-gnome -tla build-config -r configs/gnu.org/dev -cd src - -AUTOMAKE=automake-1.8 AUTOCONF=autoconf2.50 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 - -G_WRAP_MODULE_DIR=$HOME/usr/pkg/g-wrap/share/guile/site make install -#FIXME: fixup -(cd $HOME/usr/pkg/guile-gnome/share/guile/gnome && mv gtk/g[dt]k.scm gw) - -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/gtk/examples/hello.scm - - +cat > ~/.fonts.conf << EOF + +~/cvs/savannah/lilypond/mf/out +/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced + +EOF +fc-cache " - - +;;; or copy all your .pfa/.pfb's to ~/.fonts if your fontconfig +;;; already looks there for fonts. Check if it works by doing: +" +fc-list | grep -i lily +" +;;; +;;; * 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. +;;; +;;; * Run lily: +" +lilypond -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) @@ -101,279 +85,314 @@ guile -s ../src/gtk/examples/hello.scm (srfi srfi-13) (lily) (gnome gtk) - (gnome gtk gdk-event) - (gnome gw libgnomecanvas)) - + (gnome gw canvas)) -;;; Lily output interface --- fix silly names and docme +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; globals -" - The output interface has functions for - * formatting stencils, and - * output commands - - Stencils: - beam - bezier-sandwich - bracket - ... +;;; set by framework-gnome.scm +(define canvas-root #f) +(define output-scale #f) - Commands: - define-fonts - header - placebox - ... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helper functions +(define (stderr string . rest) + (apply format (cons (current-error-port) (cons string rest))) + (force-output (current-error-port))) - The Bare minimum interface for \score { \notes c } } should - implement: +(define (debugf string . rest) + (if #f + (apply stderr (cons string rest)))) - INTERFACE-output-expression - char - filledbox - placebox +(define (utf8 i) + (cond + ((< i #x80) (list (integer->char i))) + ((< i #x800) (map integer->char + (list (+ #xc0 (quotient i #x40)) + (+ #x80 (modulo i #x40))))) + ((< i #x10000) + (let ((x (quotient i #x1000)) + (y (modulo i #x1000))) + (map integer->char + (list (+ #xe0 x) + (+ #x80 (quotient y #x40)) + (+ #x80 (modulo y #x40)))))) + (else (begin (stderr "programming-error: utf-8 too big:~x\n" i) + (list (integer->char 32)))))) + +(define (integer->utf8-string integer) + (list->string (utf8 integer))) + +(define (char->utf8-string char) + (list->string (utf8 (char->integer char)))) + +(define (string->utf8-string string) + (apply + string-append + (map (lambda (x) (char->utf8-string x)) (string->list string)))) + +(define (music-font? font) + (let ((encoding (ly:font-encoding font)) + (family (font-family font))) + (or (memq encoding '(fetaMusic fetaBraces)) + (string=? (substring family 0 (min (string-length family) 9)) + "bigcheese")))) + +;; FIXME +(define-public (otf-name-mangling font family) + ;; Hmm, family is bigcheese20/26? + (if (string=? (substring family 0 (min (string-length family) 9)) + "bigcheese") + (string-append "LilyPond " (substring family 9)) + (if (string=? family "aybabtu") + "LilyPondBraces" + family))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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? ')) + (begin + (define-class () + (closure #:init-value (gnome-canvas-path-def-new) + #:init-keyword #:path-def + #:getter get-def #:setter set-def)) + + (define-method (moveto (this ) x y) + (gnome-canvas-path-def-moveto (get-def this) x y)) + (define-method (curveto (this ) x1 y1 x2 y2 x3 y3) + (gnome-canvas-path-def-curveto (get-def this) x1 y1 x2 y2 x3 y3)) + (define-method (lineto (this ) x y) + (gnome-canvas-path-def-lineto (get-def this) x y)) + (define-method (closepath (this )) + (gnome-canvas-path-def-closepath (get-def this))) + (define-method (reset (this )) + (gnome-canvas-path-def-reset (get-def this))) + + (define -set-path-def set-path-def) + (define -get-path-def get-path-def) + + (define-method (set-path-def (this ) + (def )) + (-set-path-def this (get-def def))) + + (define-method (get-path-def (this )) + (make #:path-def (-get-path-def this))))) - and should intercept: -" +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; stencil outputters +;;; +;;; catch-all for missing stuff +;;; comment this out to see find out what functions you miss :-) (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-canvas #f) -(define canvas-root #f) - -(define system-origin '(0 . 0)) - -;; UGHr -(define item-locations (make-hash-table 31)) -(define location #f) + (append + (ly:all-stencil-expressions) + (ly:all-output-backend-commands))) + +(define (beam width slope thick blot) + (define cursor '(0 . 0)) + (define (rmoveto def x y) + (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor)))) + (moveto def (car cursor) (cdr cursor))) + (define (rlineto def x y) + (set! cursor (cons (+ x (car cursor)) (+ y (cdr cursor)))) + (lineto def (car cursor) (cdr cursor))) + (let* ((def (make )) + (bezier (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:width-units blot + #:join-style 'round)) + (t (- thick blot)) + (w (- width blot)) + (h (* w slope))) + + (reset def) + (rmoveto def (/ blot 2) (/ t 2)) + (rlineto def w (- h)) + (rlineto def 0 (- t)) + (rlineto def (- w) h) + (rlineto def 0 t) + (closepath def) + (set-path-def bezier def) + bezier)) + +(define (square-beam width slope thick blot) + (let* ((def (make )) + (y (* (- width) slope)) + (props (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:width-units 0.0))) + + (reset def) + (moveto def 0 0) + (lineto def width y) + (lineto def width (- y thick)) + (lineto def 0 (- thick)) + (lineto def 0 0) + (closepath def) + (set-path-def props def) + props)) + +;; two beziers +(define (bezier-sandwich lst thick) + (let* ((def (make )) + (bezier (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:width-units thick + #:join-style 'round))) + + (reset def) + + ;; FIXME: LST is pre-mangled for direct ps stack usage + ;; cl cr r l 0 1 2 3 + ;; cr cl l r 4 5 6 7 + + (moveto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3)))) + (curveto def (car (list-ref lst 0)) (- (cdr (list-ref lst 0))) + (car (list-ref lst 1)) (- (cdr (list-ref lst 1))) + (car (list-ref lst 2)) (- (cdr (list-ref lst 2)))) -(define canvas-width 400) -(define canvas-height - (inexact->exact (round (* 1.42 canvas-width)))) + (lineto def (car (list-ref lst 7)) (- (cdr (list-ref lst 7)))) + (curveto def (car (list-ref lst 4)) (- (cdr (list-ref lst 4))) + (car (list-ref lst 5)) (- (cdr (list-ref lst 5))) + (car (list-ref lst 6)) (- (cdr (list-ref lst 6)))) + (lineto def (car (list-ref lst 3)) (- (cdr (list-ref lst 3)))) -;; 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 1) + (closepath def) + (set-path-def bezier def) + bezier)) -;; helper functions -(define (stderr string . rest) - (apply format (cons (current-error-port) (cons string rest))) - (force-output (current-error-port))) - - -(define x-editor #f) -(define (get-x-editor) - (if (not x-editor) - (set! x-editor (getenv "XEDITOR"))) - x-editor) +(define (char font i) + (text font (ly:font-index-to-charcode font i))) + +(define (dashed-line thick on off dx dy) + (draw-line thick 0 0 dx dy)) + +(define (draw-line thick x1 y1 x2 y2) + (let* ((def (make )) + (props (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:width-units thick))) + (reset def) + (moveto def x1 (- y1)) + (lineto def x2 (- y2)) + (set-path-def props def) + props)) + +;; FIXME: naming +(define (filledbox breapth width depth height) + (make + #:parent (canvas-root) + #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height) + #:fill-color "black" + #:join-style 'miter)) -(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) - -(define pixels-per-unit 1.0) -(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)) - (set! pixels-per-unit (* pixels-per-unit 2)) - (set-pixels-per-unit main-canvas pixels-per-unit)) - ((and #t ;; (null? mods) - (eq? keyval gdk:minus)) - (set! pixels-per-unit (/ pixels-per-unit 2)) - (set-pixels-per-unit main-canvas pixels-per-unit))) - #f)) +(define (grob-cause grob) + grob) -(define (char font i) - ;;(text font (make-string 1 (integer->char i)))) - ;;(text font "a")) - ;; FIXME: utf8? - (if (< i 127) - (text font (make-string 1 (integer->char i))) - (text font "a"))) +;; WTF is this in every backend? +(define (horizontal-line x1 x2 thickness) + (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) (define (placebox x y expr) (let ((item expr)) - (if item + ;;(if item + ;; FIXME ugly hack to skip #unspecified ... + (if (and item (not (eq? item (if #f #f)))) (begin - (move item - (* output-scale (+ (car system-origin) x)) - (* output-scale (- (car system-origin) y))) + (move item (* output-scale x) (* output-scale (- 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 (end-output) - (gtk-main)) - -(define (header . rest) - (let* ((window (make #:type 'toplevel)) - (button (make #:label "Exit")) - (canvas (make )) - (vbox (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) - - (gtype-instance-signal-connect button 'clicked - (lambda (b) (gtk-main-quit))) - - ;; papersize - (set-size-request canvas canvas-width canvas-height) - (set-scroll-region canvas 0 0 2000 4000) - - (gtype-instance-signal-connect window 'key-press-event key-press-event) +(define (named-glyph font name) + (text font (ly:font-glyph-name-to-charcode font name))) + +(define (polygon coords blot-diameter) + (let* ((def (make )) + (props (make + #:parent (canvas-root) + #:fill-color "black" + #:outline-color "black" + #:join-style 'round) + #:width-units blot-diameter) + (points (ly:list->offsets '() coords)) + (last-point (car (last-pair points)))) - (show-all window) - (set! canvas-root (root canvas)) - (set! main-canvas canvas) - (set! main-window window))) + (reset def) + (moveto def (car last-point) (cdr last-point)) + (for-each (lambda (x) (lineto def (car x) (cdr x))) points) + (closepath def) + (set-path-def props def) + props)) + +(define (round-filled-box breapth width depth height blot-diameter) + (let ((r (/ blot-diameter 2))) + (make + #:parent (canvas-root) + #:x1 (- r breapth) #:y1 (- depth r) #:x2 (- width r) #:y2 (- r height) + #:fill-color "black" + #:outline-color "black" + #:width-units blot-diameter + #:join-style 'round))) + +(define (text font s) + + (define (pango-font-name font) + (debugf "FONT-NAME:~S:~S\n" (ly:font-name font) (ly:font-design-size font)) + (debugf "FONT-FAMILY:~S:~S\n" (font-family font) (otf-name-mangling font (font-family font))) + (otf-name-mangling font (font-family font))) + + (define (pango-font-size font) + (let* ((designsize (ly:font-design-size font)) + (magnification (* (ly:font-magnification font))) + + ;;font-name: "GNU-LilyPond-feta-20" + ;;font-file-name: "feta20" + ;;pango-font-name: "lilypond-feta, regular 32" + ;;OPS:2.61 + ;;scaling:29.7046771653543 + ;;magnification:0.569055118110236 + ;;design:20.0 + + ;; ugh, experimental sizing + ;; where does factor ops come from? + ;; Hmm, design size: 26/20 + (ops 2.60) + + (scaling (* ops magnification designsize))) + (debugf "OPS:~S\n" ops) + (debugf "scaling:~S\n" scaling) + (debugf "magnification:~S\n" magnification) + (debugf "design:~S\n" designsize) + + scaling)) -(define (pango-font-name font) - (cond - ((equal? (ly:font-name font) "GNU-LilyPond-feta-20") - "lilypond-feta, regular 32") - (else - (ly:font-filename font)))) - -(define (text font string) - (stderr "font-name: ~S\n" (ly:font-name font)) - ;; TODO s/filename/file-name/ - (stderr "font-filename: ~S\n" (ly:font-filename font)) (make - #:parent canvas-root - #:x 0 #:y 0 - #:size-points 12 - #:size-set #t - ;; #:font "new century schoolbook, i bold 20" + #:parent (canvas-root) + ;; ugh, experimental placement corections + ;; #:x 0.0 #:y 0.0 + #:x 0.0 #:y (if (music-font? font) 0.15 0.69) + #:anchor (if (music-font? font) 'west 'south-west) #:font (pango-font-name font) - #: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))) - + #:size-points (pango-font-size font) + #:size-set #t + #:text (if (integer? s) + (integer->utf8-string s) + (string->utf8-string s))))