;;; You need:
;;;
-;;; * Rotty's g-wrap >= 1.9.1 (or TLA)
-;;; * guile-gnome-platform >= 2.5.992 (or TLA)
-;;; * pango >= 1.5.2 (or CVS)
+;;; * Rotty's g-wrap >= 1.9.3 (or TLA)
+;;; * guile-gnome-platform >= 2.7.95 (or TLA)
+;;; * pango >= 1.6.0
;;;
;;; See also: guile-gtk-general@gnu.org
;;; * Build LilyPond with gui support: configure --enable-gui
;;;
;;; * Supposing that LilyPond was built in ~/cvs/savannah/lilypond,
-;;; tell fontconfig about the feta fonts dir:
+;;; tell fontconfig about the feta fonts dir and run fc-cache
"
cat > ~/.fonts.conf << EOF
<fontconfig>
<dir>~/cvs/savannah/lilypond/mf/out</dir>
+<dir>/usr/share/texmf/fonts/type1/public/ec-fonts-mftraced</dir>
</fontconfig>
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:
(use-modules
(guile)
+ (ice-9 regex)
(srfi srfi-13)
(lily)
- (gnome gtk))
-
-
-;; 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)))
-
+ (gnome gtk)
+ (gnome gw canvas))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Wrappers from guile-gnome TLA
(gnome-canvas-path-def-lineto (get-def this) x y))
(define-method (closepath (this <gnome-canvas-path-def>))
(gnome-canvas-path-def-closepath (get-def this)))
+ (define-method (reset (this <gnome-canvas-path-def>))
+ (gnome-canvas-path-def-reset (get-def this)))
(define -set-path-def set-path-def)
(define -get-path-def get-path-def)
(+ #x80 (modulo y #x40))))))
(else FIXME)))
-(define (custom-utf8 i)
- (if (< i 80)
- (utf8 i)
- (utf8 (+ #xee00 i))))
-
-(define (string->utf8-string string)
- (list->string
- (apply append (map utf8 (map char->integer (string->list string))))))
-
-(define (char->utf8-string char)
- (list->string (utf8 (char->integer char))))
-
-(define (draw-rectangle x1 y1 x2 y2 color width-units)
- (make <gnome-canvas-rect>
- #:parent (canvas-root) #:x1 x1 #:y1 y1 #:x2 x2 #:y2 y2
- #:fill-color color #:width-units width-units))
-
+(define (char->utf8-string font char)
+ (list->string (utf8 (char->unicode-index font char))))
+
+(define (string->utf8-string font string)
+ (apply
+ string-append
+ (map (lambda (x) (char->utf8-string font x)) (string->list string))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; stencil outputters
(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 <gnome-canvas-path-def>))
+ (bezier (make <gnome-canvas-bpath>
+ #: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 <gnome-canvas-path-def>))
+ (y (* (- width) slope))
+ (props (make <gnome-canvas-bpath>
+ #: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 <gnome-canvas-path-def>))
#:parent (canvas-root)
#:fill-color "black"
#:outline-color "black"
- #:width-units thick)))
-
+ #: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
bezier))
(define (char font i)
- (text font (utf8 i)))
+ (text font (integer->char i)))
+
+;; FIXME: naming
+(define (filledbox breapth width depth height)
+ (make <gnome-canvas-rect>
+ #:parent (canvas-root)
+ #:x1 (- breapth) #:y1 depth #:x2 width #:y2 (- height)
+ #:fill-color "black"
+ #:join-style 'miter))
+
+(define (grob-cause grob)
+ grob)
+
+;; 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)
(debugf "item: ~S\n" expr)
item)
#f)))
-(define (round-filled-box breapth width depth height blot-diameter)
- ;; 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
- ;; 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)))
-
- ;; 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)))
- (debugf "OPS:~S\n" ops)
- (debugf "scaling:~S\n" scaling)
- (debugf "magnification:~S\n" magnification)
- (debugf "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 (dashed-line thick on off dx dy)
+ (draw-line thick 0 0 dx dy))
-(define (text font string)
- (if #f
- (begin
- (stderr "font-name: ~S\n" (ly:font-name font))
- ;; TODO s/filename/file-name/
- (stderr "font-filename: ~S\n" (ly:font-filename font))
-
- (stderr "pango-font-name: ~S\n" (pango-font-name font))
- (stderr "pango-font-size: ~S\n" (pango-font-size font))))
-
- (make <gnome-canvas-text>
- #:parent (canvas-root)
-
- #:anchor 'west
- #:x 0.0 #:y 0.0
-
- #:font (pango-font-name font)
-
- #:size-points (pango-font-size font)
- ;;#:size ...
- #:size-set #t
+(define (draw-line thick fx fy tx ty)
+ (let*
+ ((def (make <gnome-canvas-path-def>))
+ (props (make <gnome-canvas-bpath>
+ #:parent (canvas-root)
+ #:fill-color "black"
+ #:outline-color "black"
+ #:width-units thick)))
- ;;apparently no effect :-(
- ;;#:scale 1.0
- ;;#:scale-set #t
+ (reset def)
+ (moveto def fx (- fy))
+ (lineto def tx (- ty))
+ (set-path-def props def)
+ props))
- #:fill-color "black"
- #:text (if (string? string)
- (string->utf8-string string)
- (char->utf8-string (car 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)
- (filledbox (- x1) (- x2 x1) (* .5 thickness) (* .5 thickness)))
-
-;;(define (define-origin file line col)
-;; (if (procedure? point-and-click)
-;; (list 'location line col file)))
+(define (list->offsets accum coords)
+ (if (null? coords)
+ accum
+ (cons (cons (car coords) (cadr coords))
+ (list->offsets accum (cddr coords))
+ )))
+
+(define (polygon coords blotdiameter)
+ (let*
+ ((def (make <gnome-canvas-path-def>))
+ (props (make <gnome-canvas-bpath>
+ #:parent (canvas-root)
+ #:fill-color "black"
+ #:outline-color "black"
+ #:width-units blotdiameter))
+ (points (list->offsets '() coords))
+ (last-point (car (last-pair points))))
+
+ (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 (grob-cause grob)
- grob)
+(define (round-filled-box breapth width depth height blot-diameter)
+ (let ((r (/ blot-diameter 2)))
+ (make <gnome-canvas-rect>
+ #: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)
+ (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))
+
+ (let ((encoding (ly:font-encoding font)))
+ (make <gnome-canvas-text>
+ #:parent (canvas-root)
+ ;; ugh, experimental placement corections
+ ;; #:x 0.0 #:y 0.0
+ #:x 0.0 #:y (if (memq encoding '(fetaMusic fetaBraces)) 0.15 0.69)
+
+ #:anchor (if (memq encoding '(fetaMusic fetaBraces)) 'west 'south-west)
+ #:font (pango-font-name font)
+ #:size-points (pango-font-size font)
+ #:size-set #t
+ #:text (if (char? s)
+ (char->utf8-string font s)
+ (string->utf8-string font s)))))
projects / lilypond.git / blobdiff