X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Foutput-gnome.scm;h=0ea432e4f477797b544d6302e659106557b8d53c;hb=2a6f7d1f45438eae0b46636d43da07b36db53273;hp=83fe913d92cdb47ee60553890020110b0cc447d7;hpb=53811c6ebfd5531a67a33fc28fabf517df6a4306;p=lilypond.git diff --git a/scm/output-gnome.scm b/scm/output-gnome.scm index 83fe913d92..0ea432e4f4 100644 --- a/scm/output-gnome.scm +++ b/scm/output-gnome.scm @@ -2,90 +2,82 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2004 Jan Nieuwenhuizen +;;;; (c) 2004--2005 Jan Nieuwenhuizen +;;;; TODO: +;;;; +;;;; * .cff MUST NOT be in fc's fontpath. +;;;; - workaround: remove mf/out from ~/.fonts.conf, +;;;; instead add ~/.fonts and symlink all /mf/out/*otf there. +;;;; - bug in fontconfig/freetype/pango? + +;;; * 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: +;;; +;;; * Rotty's g-wrap >= 1.9.3 +;;; * guile-gnome-platform >= 2.7.97 +;;; * pango >= 1.6.0 +;;; +;;; See also: guile-gtk-general@gnu.org -;;; HIP -- hack in progress +;;; Try it ;;; -;;; status: hello-world +;;; * Install gnome/gtk and libffi development stuff ;;; -;;; This first working version needs rotty's g-wrap--tng. -;;; (janneke's guile-gnome patches now in main archive). +;;; * Install [pango, g-wrap and] guile-gnome from source, +;;; see buildscripts/guile-gnome.sh +;;; +;;; * Build LilyPond with gui support: configure --enable-gui ;;; -;;; 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: use latin1 encoding for gnome backend -;;; * 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? - +;;; * 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) @@ -98,264 +90,310 @@ 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 - -" - The output interface has functions for - * formatting stencils, and - * output commands - - Stencils: - beam - bezier-sandwich - bracket - ... - - Commands: - define-fonts - header - placebox - ... +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; globals +;;; set by framework-gnome.scm +(define canvas-root #f) +(define output-scale #f) - The Bare minimum interface for \score { \notes c } } should - implement: +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; helper functions - 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: utf8 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 ((family (car (font-name-style font)))) + (string=? (substring family 0 (min (string-length family) 10)) + "Emmentaler"))) + +;;; FONT may be font smob, or pango font string +(define (pango-font-name font) + (if (string? font) + (list font "Regular") + (apply format (append '(#f "~a, ~a") (font-name-style font))))) + +;;; FONT may be font smob, or pango font string +(define (canvas-font-size font) + ;; FIXME: 1.85? + (* 1.85 + (if (string? font) + 12 + (* output-scale (modified-font-metric-font-scaling font))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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)) + (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)))) -;; UGHr -(define item-locations (make-hash-table 31)) -(define location #f) + (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)))) -(define canvas-width 400) -(define canvas-height - (inexact->exact (round (* 1.42 canvas-width)))) + (closepath def) + (set-path-def bezier def) + bezier)) -;; 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) +(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)) + +;; FIXME: the framework-gnome backend needs to see every item that +;; gets created. All items created here must should be put in a group +;; that gets returned. +(define (glyph-string font postscript-font-name x-y-named-glyphs) + (for-each + (lambda (x) + + ;; UGR, glyph names not found + (stderr "GLYPH:~S\n" (caddr x)) + (stderr "ID:~S\n" (ly:font-glyph-name-to-charcode font (caddr x))) + (placebox (car x) (cadr x) + (make + #:parent (canvas-root) + ;;#:x 0.0 #:y (if (music-font? font) 0.15 0.69) + #:x 0.0 #:y 0.0 + #:anchor 'west + #:font (pango-font-name font) + #:size-points (canvas-font-size font) + #:size-set #t + #:text + (integer->utf8-string + (ly:font-glyph-name-to-charcode font (caddr x)))))) + x-y-named-glyphs)) + +(define (grob-cause offset grob) + grob) -;; 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 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)) +;; WTF is this in every backend? +(define (horizontal-line x1 x2 thickness) + (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness))) -(define (char font i) - ;;(text font (make-string 1 (integer->char i)))) - (text font "a")) +(define (named-glyph font name) + (text font (ly:font-glyph-name-to-charcode font name))) (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))) +(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)))) - ;; 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) - - (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 (text font string) +(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) (make - #:parent canvas-root - #:x 0 #:y 0 - #:size-points 12 + #:parent (canvas-root) + ;;#: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) + #:size-points (canvas-font-size font) #:size-set #t - #:font "new century schoolbook, i bold 20" - #: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))) + #:text (if (integer? s) + (integer->utf8-string s) + (string->utf8-string s)))) +(define (utf8-string pango-font-description string) + (make + #:parent (canvas-root) + #:x 0.0 #:y 0.0 + #:anchor 'west + #:font pango-font-description + #:size-points (canvas-font-size pango-font-description) + #:size-set #t + #:text string))