function.
+2004-12-19 Jan Nieuwenhuizen <janneke@gnu.org>
+
+ * scm/output-svg.scm (polygon, draw-line, dashed-line): New
+ function.
+
2004-12-19 Han-Wen Nienhuys <hanwen@xs4all.nl>
* scm/output-texstr.scm (placebox): add routine
(ly:parser-print-book parser book)))
(define-public (print-score-as-book parser score)
- (let*
- ((head (ly:parser-lookup parser '$globalheader))
- (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
- head score)))
+ (let* ((head (ly:parser-lookup parser '$globalheader))
+ (book (ly:make-book (ly:parser-lookup parser $defaultpaper)
+ head score)))
(ly:parser-print-book parser book)))
(define-public (print-score parser score)
(ly:parser-print-score parser book)))
(define-public (collect-scores-for-book parser score)
- (let*
- ((oldval (ly:parser-lookup parser 'toplevel-scores)))
- (ly:parser-define parser 'toplevel-scores (cons score oldval))
- ))
+ (let* ((oldval (ly:parser-lookup parser 'toplevel-scores)))
+ (ly:parser-define parser 'toplevel-scores (cons score oldval))))
(define-public (collect-music-for-book parser music)
(collect-scores-for-book parser (ly:music-scorify music parser)))
(if (null? list)
'()
(cons (cons (caar list) (func (cdar list)))
- (map-alist-vals func (cdr list)))
- ))
+ (map-alist-vals func (cdr list)))))
(define (map-alist-keys func list)
"map FUNC over the keys of an alist LIST, leaving the vals. "
(if (null? list)
'()
(cons (cons (func (caar list)) (cdar list))
- (map-alist-keys func (cdr list)))
- ))
+ (map-alist-keys func (cdr list)))))
;;;;;;;;;;;;;;;;
;; vector
(do
((i 0 (1+ i)))
((>= i (vector-length vec)) vec)
-
- (vector-set! vec i
- (proc (vector-ref vec i)))))
+ (vector-set! vec i (proc (vector-ref vec i)))))
;;;;;;;;;;;;;;;;
;; hash
-(if (not (defined? 'hash-table?)) ; guile 1.6 compat
+(if (not (defined? 'hash-table?)) ;; guile 1.6 compat
(begin
(define hash-table? vector?)
(define-public (hash-table->alist t)
"Convert table t to list"
- (apply append
- (vector->list t)
- )))
+ (apply append (vector->list t))))
;; native hashtabs.
(begin
(define-public (hash-table->alist t)
-
(hash-fold (lambda (k v acc) (acons k v acc))
- '() t)
- )
- ))
+ '() t))))
;; todo: code dup with C++.
-(define-public (alist->hash-table l)
+(define-public (alist->hash-table lst)
"Convert alist to table"
- (let
- ((m (make-hash-table (length l))))
-
- (map (lambda (k-v)
- (hashq-set! m (car k-v) (cdr k-v)))
- l)
-
+ (let ((m (make-hash-table (length lst))))
+ (map (lambda (k-v) (hashq-set! m (car k-v) (cdr k-v))) lst)
m))
-
-
-
;;;;;;;;;;;;;;;;
; list
'()
(if (pair? (car lst))
(append (flatten-list (car lst)) (flatten-list (cdr lst)))
- (cons (car lst) (flatten-list (cdr lst))))
- ))
+ (cons (car lst) (flatten-list (cdr lst))))))
(define (list-minus a b)
"Return list of elements in A that are not in B."
(lset-difference eq? a b))
-
;; TODO: use the srfi-1 partition function.
-(define-public (uniq-list l)
+(define-public (uniq-list lst)
- "Uniq LIST, assuming that it is sorted"
- (define (helper acc l)
- (if (null? l)
+ "Uniq LST, assuming that it is sorted"
+ (define (helper acc lst)
+ (if (null? lst)
acc
- (if (null? (cdr l))
- (cons (car l) acc)
- (if (equal? (car l) (cadr l))
- (helper acc (cdr l))
- (helper (cons (car l) acc) (cdr l)))
- )))
- (reverse! (helper '() l) '()))
-
-
-(define (split-at-predicate predicate l)
- "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
-into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
-Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
-L1 is copied, L2 not.
-
-(split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
-;; "
-
-;; KUT EMACS MODE.
-
- (define (inner-split predicate l acc)
- (cond
- ((null? l) acc)
- ((null? (cdr l))
- (set-car! acc (cons (car l) (car acc)))
- acc)
- ((predicate (car l) (cadr l))
- (set-car! acc (cons (car l) (car acc)))
- (inner-split predicate (cdr l) acc))
- (else
- (set-car! acc (cons (car l) (car acc)))
- (set-cdr! acc (cdr l))
- acc)
-
- ))
- (let*
- ((c (cons '() '()))
- )
- (inner-split predicate l c)
- (set-car! c (reverse! (car c)))
- c)
-)
-
-
-(define-public (split-list l sep?)
-"
-(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
-=>
-((a b c) (d e f) (g))
-
-"
-;; " KUT EMACS.
-
-(define (split-one sep? l acc)
- "Split off the first parts before separator and return both parts."
- (if (null? l)
- (cons acc '())
- (if (sep? (car l))
- (cons acc (cdr l))
- (split-one sep? (cdr l) (cons (car l) acc))
- )
- ))
-
-(if (null? l)
- '()
- (let* ((c (split-one sep? l '())))
- (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
- )))
-
+ (if (null? (cdr lst))
+ (cons (car lst) acc)
+ (if (equal? (car lst) (cadr lst))
+ (helper acc (cdr lst))
+ (helper (cons (car lst) acc) (cdr lst))))))
+ (reverse! (helper '() lst) '()))
+
+(define (split-at-predicate predicate lst)
+ "Split LST = (a_1 a_2 ... a_k b_1 ... b_k)
+ into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
+ Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
+ L1 is copied, L2 not.
+
+ (split-at-predicate (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
+ ;; " Emacs is broken
+
+ (define (inner-split predicate lst acc)
+ (cond
+ ((null? lst) acc)
+ ((null? (cdr lst))
+ (set-car! acc (cons (car lst) (car acc)))
+ acc)
+ ((predicate (car lst) (cadr lst))
+ (set-car! acc (cons (car lst) (car acc)))
+ (inner-split predicate (cdr lst) acc))
+ (else
+ (set-car! acc (cons (car lst) (car acc)))
+ (set-cdr! acc (cdr lst))
+ acc))
+ (let* ((c (cons '() '())))
+ (inner-split predicate lst c)
+ (set-car! c (reverse! (car c)))
+ c)))
+
+(define-public (split-list lst sep?)
+ "(display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
+ =>
+ ((a b c) (d e f) (g))
+ "
+ ;; " Emacs is broken
+ (define (split-one sep? lst acc)
+ "Split off the first parts before separator and return both parts."
+ (if (null? lst)
+ (cons acc '())
+ (if (sep? (car lst))
+ (cons acc (cdr lst))
+ (split-one sep? (cdr lst) (cons (car lst) acc)))))
+
+ (if (null? lst)
+ '()
+ (let* ((c (split-one sep? lst '())))
+ (cons (reverse! (car c) '()) (split-list (cdr c) sep?)))))
(define-public (offset-add a b)
(cons (+ (car a) (car b))
(+ (cdr a) (cdr b))))
+(define-public (ly:list->offsets accum coords)
+ (if (null? coords)
+ accum
+ (cons (cons (car coords) (cadr coords))
+ (ly:list->offsets accum (cddr coords)))))
+
(define-public (interval-length x)
"Length of the number-pair X, when an interval"
- (max 0 (- (cdr x) (car x)))
- )
+ (max 0 (- (cdr x) (car x))))
+
(define-public interval-start car)
(define-public interval-end cdr)
(define (other-axis a)
(remainder (+ a 1) 2))
-
(define-public (interval-widen iv amount)
(cons (- (car iv) amount)
(cons (min (car i1) (car i2))
(max (cdr i1) (cdr i2))))
-
(define-public (write-me message x)
"Return X. Display MESSAGE and write X. Handy for debugging,
possibly turned off."
(display message) (write x) (newline) x)
;; x)
-
(define-public (stderr string . rest)
(apply format (cons (current-error-port) (cons string rest)))
(force-output (current-error-port)))
-
(define (index-cell cell dir)
(if (equal? dir 1)
(cdr cell)
"map F to contents of X"
(cons (f (car x)) (f (cdr x))))
-
(define-public (list-insert-separator lst between)
"Create new list, inserting BETWEEN between elements of LIST"
(define (conc x y )
(if (eq? y #f)
(list x)
- (cons x (cons between y))
- ))
+ (cons x (cons between y))))
(fold-right conc #f lst))
;;;;;;;;;;;;;;;;
0
(if (< x 0) -1 1)))
-(define-public (symbol<? l r)
- (string<? (symbol->string l) (symbol->string r)))
-
-(define-public (!= l r)
- (not (= l r)))
+(define-public (symbol<? lst r)
+ (string<? (symbol->string lst) (symbol->string r)))
+(define-public (!= lst r)
+ (not (= lst r)))
(define-public scale-to-unit
(cond
;;(stderr "font-name: ~S\n" (ly:font-name font))
;;(stderr "font-file-name: ~S\n" (ly:font-file-name font))
(ly:font-file-name font)))))
-
;;; TODO:
;;;
+;;; * 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
(if #f
(apply stderr (cons string rest))))
-(define (list->offsets accum coords)
- (if (null? coords)
- accum
- (cons (cons (car coords) (cadr coords))
- (list->offsets accum (cddr coords)))))
-
(define (utf8 i)
(cond
((< i #x80) (list (integer->char i)))
(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 <gnome-canvas-path-def>))
+ (props (make <gnome-canvas-bpath>
+ #: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 <gnome-canvas-rect>
item)
#f)))
-(define (dashed-line thick on off dx dy)
- (draw-line thick 0 0 dx dy))
-
-(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)))
-
- (reset def)
- (moveto def fx (- fy))
- (lineto def tx (- ty))
- (set-path-def props def)
- props))
-
(define (named-glyph font name)
(text font (ly:font-glyph-name-to-charcode font name)))
-(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))))
-
+(define (polygon coords blot-diameter)
+ (let* ((def (make <gnome-canvas-path-def>))
+ (props (make <gnome-canvas-bpath>
+ #: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))))
+
(reset def)
(moveto def (car last-point) (cdr last-point))
- (for-each (lambda (x)
- (lineto def (car x) (cdr x))
- ) points)
+ (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 <gnome-canvas-rect>
;;;; http://www.w3.org/TR/SVG11
;;;; TODO:
-;;;; * missing stencils: line, dashed-line ...
-;;;; * rounded corners on stencils: rect, bezier (inkscape bug?)
+;;;; * check: blot+scaling
;;;; * inkscape page/pageSet support
+;;;; * inkscape SVG-font support
+;;;; - use fontconfig/fc-cache for now, see output-gnome.scm
(debug-enable 'backtrace)
(define-module (scm output-svg))
(use-modules
(guile)
(ice-9 regex)
- (lily))
+ (lily)
+ (srfi srfi-13))
;; GLobals
;; FIXME: 2?
(define output-scale (* 2 scale-to-unit))
-(define indent-level 0)
-(define (indent s . add) s)
-
-;;(define (indentation indent str)
-;; (regexp-substitute/global #f "\(\n\)[ \t]*" str 'pre 1 indent 'post))
-
-(define (indent s . add)
- (let ((before indent-level)
- (after (apply + (cons indent-level add)))
- (after? (and (not (null? add)) (> (car add) 0))))
- (set! indent-level after)
- (if after?
- (string-append (make-string before #\ ) s)
- (string-append (make-string after #\ ) s))))
-
(define (debugf string . rest)
(if #f
(apply stderr (cons string rest))))
attributes-alist)))
(define-public (eo entity . attributes-alist)
- (indent (format #f "<~S~a>\n" entity (attributes attributes-alist)) 2))
+ (format #f "<~S~a>\n" entity (attributes attributes-alist)))
(define-public (eoc entity . attributes-alist)
- (indent (format #f "<~S~a/>\n" entity (attributes attributes-alist))))
+ (format #f "<~S~a/>\n" entity (attributes attributes-alist)))
(define-public (ec entity)
- (indent (format #f "</~S>\n" entity) -2))
+ (format #f "</~S>\n" entity))
(define-public (entity entity string . attributes-alist)
(if (equal? string "")
(string-append
(apply eo (cons entity attributes-alist)) string (ec entity))))
-(define (control->list c)
- (list (car c) (cdr c)))
-
-(define (control->string c)
- (string-append
- (number->string (car c)) ","
- ;; lose the -1
- (number->string (* -1 (cdr c))) " "))
-
-(define (control-flip-y c)
- (cons (car c) (* -1 (cdr c))))
-
-(define (ly:numbers->string lst)
- (string-append
- (number->string (car lst))
- (if (null? (cdr lst))
- ""
- (string-append "," (ly:numbers->string (cdr lst))))))
+(define (offset->point o)
+ (format #f " ~S,~S" (car o) (cdr o)))
(define (svg-bezier lst close)
(let* ((c0 (car (list-tail lst 3)))
(c123 (list-head lst 3)))
(string-append
(if (not close) "M " "L ")
- (control->string c0)
- "C " (apply string-append (map control->string c123))
+ (offset->point c0)
+ "C " (apply string-append (map offset->point c123))
(if (not close) "" (string-append
- "L " (control->string close))))))
+ "L " (offset->point close))))))
(define (sqr x)
(* x x))
(ly:all-stencil-expressions)
(ly:all-output-backend-commands)))
-(define (beam width slope thick blot)
+(define (beam width slope thick blot-diameter)
(let* ((x width)
(y (* slope width))
(z (sqrt (+ (sqr x) (sqr y)))))
(entity 'rect ""
- `(style . ,(format "stroke-linejoin:round;stroke-linecap:round;stroke-width:~f;" blot))
- `(x . "0")
- `(y . ,(number->string (* output-scale (- 0 (/ thick 2)))))
- `(width . ,(number->string (* output-scale width)))
- `(height . ,(number->string (* output-scale thick)))
- `(ry . ,(number->string (* output-scale (/ blot 2))))
- `(transform .
- ,(format #f "matrix (~f, ~f, 0, 1, 0, 0) scale (~f, ~f)"
- (/ x z)
- (* -1 (/ y z))
- 1 1)))))
+ ;; The stroke will stick out. To use stroke,
+ ;; the stroke-width must be subtracted from all other dimensions.
+ ;;'(stroke-linejoin . "round")
+ ;;'(stroke-linecap . "round")
+ ;;`(stroke-width . ,blot-diameter)
+ ;;'(stroke . "red")
+ ;;'(fill . "orange")
+
+ `(x . 0)
+ `(y . ,(- (/ thick 2)))
+ `(width . ,(+ width (* slope blot-diameter)))
+ `(height . ,thick)
+ `(rx . ,(/ blot-diameter 2))
+ `(transform . ,(string-append
+ (format #f "matrix (~f, ~f, 0, 1, 0, 0)"
+ (/ x z) (* -1 (/ y z)))
+ (format #f " scale (~f, ~f)"
+ output-scale output-scale))))))
(define (bezier-sandwich lst thick)
(let* ((first (list-tail lst 4))
(first-c0 (car (list-tail first 3)))
(second (list-head lst 4)))
(entity 'path ""
- `(style . ,(format "stroke-linejoin:round;stroke-linecap:round;stroke-width:~f;" thick))
- `(transform . ,(format #f "scale (~f, ~f)"
- output-scale output-scale))
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(stroke-width . ,thick)
+ '(stroke . "black")
+ '(fill . "black")
`(d . ,(string-append (svg-bezier first #f)
- (svg-bezier second first-c0))))))
+ (svg-bezier second first-c0)))
+ `(transform
+ . ,(format #f "scale (~f, -~f)" output-scale output-scale)))))
(define (char font i)
(dispatch
(define-public (comment s)
(string-append "<!-- " s " !-->\n"))
+(define (dashed-line thick on off dx dy)
+ (draw-line thick 0 0 dx dy))
+
+(define (draw-line thick x1 y1 x2 y2)
+ (entity 'line ""
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(stroke-width . ,thick)
+ '(stroke . "black")
+ ;;'(fill . "black")
+ `(x1 . ,x1)
+ `(y1 . ,y1)
+ `(x2 . ,x2)
+ `(y2 . ,y2)
+ `(transform
+ . ,(format #f "scale (~f, -~f)" output-scale output-scale))))
+
+;; WTF is this in every backend?
+(define (horizontal-line x1 x2 th)
+ (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))
+
(define (filledbox breapth width depth height)
(round-filled-box breapth width depth height 0))
expr
`(transform . ,(format #f "translate (~f, ~f)"
(* output-scale x)
- (- 0 (* output-scale y))))))
+ (- (* output-scale y))))))
+
+(define (polygon coords blot-diameter)
+ (entity 'polygon ""
+ '(stroke-linejoin . "round")
+ '(stroke-linecap . "round")
+ `(stroke-width . ,blot-diameter)
+ '(stroke . "black")
+ ;;'(fill . "black")
+ `(points . ,(string-join
+ (map offset->point (ly:list->offsets '() coords))))
+ `(transform
+ . ,(format #f "scale (~f, -~f)" output-scale output-scale))))
(define (round-filled-box breapth width depth height blot-diameter)
(entity 'rect ""
- `(style . ,(format "stroke-linejoin:round;stroke-linecap:round;stroke-width:~f;" blot-diameter))
- `(x . ,(number->string (* output-scale (- 0 breapth))))
- `(y . ,(number->string (* output-scale (- 0 height))))
- `(width . ,(number->string (* output-scale (+ breapth width))))
- `(height . ,(number->string (* output-scale (+ depth height))))
- `(ry . ,(number->string (/ blot-diameter 2)))))
+ ;; The stroke will stick out. To use stroke,
+ ;; the stroke-width must be subtracted from all other dimensions.
+ ;;'(stroke-linejoin . "round")
+ ;;'(stroke-linecap . "round")
+ ;;`(stroke-width . ,blot)
+ ;;'(stroke . "red")
+ ;;'(fill . "orange")
+
+ `(x . ,(- breapth))
+ `(y . ,(- height))
+ `(width . ,(+ breapth width))
+ `(height . ,(+ depth height))
+ `(ry . ,(/ blot-diameter 2))
+ ;;`(transform . ,(scale))))
+ `(transform
+ . ,(format #f "scale (~f, ~f)" output-scale output-scale))))
(define (text font string)
(dispatch `(fontify ,font ,(entity 'tspan (string->entities string)))))
-
-;; WTF is this in every backend?
-(define (horizontal-line x1 x2 th)
- (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))
projects / lilypond.git / commitdiff