2004-03-13 Han-Wen Nienhuys <hanwen@xs4all.nl>
+ * scm/new-font.scm: new file. Tree based font lookup.
+
+ * scm/lily.scm (assoc-get): take default argument. Remove
+ assoc-get-default.
+ (chain-assoc-get): use chain-assoc-get everywhere.
+
* scripts/convert-ly.py (FatalConversionError.subst_in_trans):
autobeamsettings conversion bug.
(load-library "lilypond-font-lock")
(load-library "lilypond-indent")
+
+(defun LilyPond-guile ()
+ (interactive)
+ (require 'ilisp)
+ (guile "lilyguile" (LilyPond-command-expand (cadr (assoc "2Dvi" LilyPond-command-alist))
+ (funcall 'LilyPond-master-file)))
+ (comint-default-send (ilisp-process) "(define-module (*anonymous-ly-1*))")
+ (comint-default-send (ilisp-process) "(set! %load-path (cons \"/usr/share/ilisp/\" %load-path))")
+ (comint-default-send (ilisp-process) "(use-modules (guile-user) (guile-ilisp))")
+ (comint-default-send (ilisp-process) "(newline)"))
+
(provide 'lilypond-mode)
;;; lilypond-mode.el ends here
R1*21
<<
{
- \override Staff.MultiMeasureRest #'staff-position = #-6
+ \once \override Staff.MultiMeasureRest #'staff-position = #-6
R1
- \revert MultiMeasureRest #'staff-position
}
\new Voice { s2
\clef tenor
;; + steps:altered + (highest all -- if not altered)
;; + subs:missing
- (let* ((root->markup (assoc-get-default
+ (let* ((root->markup (assoc-get
'root->markup options note-name->markup))
- (step->markup (assoc-get-default
+ (step->markup (assoc-get
'step->markup options step->markup-plusminus))
- (sub->markup (assoc-get-default
+ (sub->markup (assoc-get
'sub->markup options
(lambda (x)
(step-based-sub->markup step->markup x))))
- (sep (assoc-get-default
+ (sep (assoc-get
'separator options (make-simple-markup "/"))))
(if
;; + steps:(highest base) + cons-alt
;; + 'add'
;; + steps:rest
- (let* ((root->markup (assoc-get-default
+ (let* ((root->markup (assoc-get
'root->markup options note-name->markup))
(step->markup
- (assoc-get-default
+ (assoc-get
;; FIXME: ignatzek
;;'step->markup options step->markup-accidental))
'step->markup options step->markup-ignatzek))
- (sep (assoc-get-default
+ (sep (assoc-get
'separator options (make-simple-markup " ")))
- (add-prefix (assoc-get-default 'add-prefix options
+ (add-prefix (assoc-get 'add-prefix options
(make-simple-markup " add"))))
(if
(ly:stencil-extent x X))
stencils))))
(word-count (length markups))
- (word-space (cdr (chain-assoc 'word-space props)))
- (line-width (cdr (chain-assoc 'linewidth props)))
+ (word-space (chain-assoc-get 'word-space props))
+ (line-width (chain-assoc-get 'linewidth props))
(fill-space (if (< line-width text-width)
word-space
(/ (- line-width text-width)
"Put @var{args} in a horizontal line. The property @code{word-space}
determines the space between each markup in @var{args}."
(stack-stencil-line
- (cdr (chain-assoc 'word-space props))
+ (chain-assoc-get 'word-space props)
(map (lambda (m) (interpret-markup paper props m)) args)))
(def-markup-command (combine paper props m1 m2) (markup? markup?)
(def-markup-command (column paper props args) (markup-list?)
"Stack the markups in @var{args} vertically."
(stack-lines
- -1 0.0 (cdr (chain-assoc 'baseline-skip props))
+ -1 0.0 (chain-assoc-get 'baseline-skip props)
(map (lambda (m) (interpret-markup paper props m)) args)))
(def-markup-command (dir-column paper props args) (markup-list?)
"Make a column of args, going up or down, depending on the setting
of the @code{#'direction} layout property."
- (let* ((dir (cdr (chain-assoc 'direction props))))
+ (let* ((dir (chain-assoc-get 'direction props)))
(stack-lines
(if (number? dir) dir -1)
0.0
- (cdr (chain-assoc 'baseline-skip props))
+ (chain-assoc-get 'baseline-skip props)
(map (lambda (x) (interpret-markup paper props x)) args))))
(def-markup-command (center-align paper props args) (markup-list?)
"Put @code{args} in a centered column. "
(let* ((mols (map (lambda (x) (interpret-markup paper props x)) args))
(cmols (map (lambda (x) (ly:stencil-align-to! x X CENTER)) mols)))
- (stack-lines -1 0.0 (cdr (chain-assoc 'baseline-skip props)) mols)))
+ (stack-lines -1 0.0 (chain-assoc-get 'baseline-skip props) mols)))
(def-markup-command (right-align paper props arg) (markup?)
(let* ((m (interpret-markup paper props arg)))
(ly:stencil-translate-axis (interpret-markup
paper
props arg)
- (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
+ (* 0.5 (chain-assoc-get 'baseline-skip props))
Y))
(def-markup-command (super paper props arg) (markup?)
paper
(cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
arg)
- (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
+ (* 0.5 (chain-assoc-get 'baseline-skip props))
Y))
(def-markup-command (translate paper props offset arg) (number-pair? markup?)
paper
(cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
arg)
- (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
+ (* -0.5 (chain-assoc-get 'baseline-skip props))
Y))
(def-markup-command (normal-size-sub paper props arg) (markup?)
(ly:stencil-translate-axis
(interpret-markup paper props arg)
- (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
+ (* -0.5 (chain-assoc-get 'baseline-skip props))
Y))
(def-markup-command (hbracket paper props arg) (markup?)
(else
(let*
((orig (car stencils))
- (handle (chain-assoc 'direction props))
- (dir (if (and (pair? handle) (ly:dir? (cdr handle)))
- (cdr handle)
- DOWN))
+ (dir (chain-assoc-get 'direction props DOWN))
(new (ly:stencil-moved-to-edge last-stencil Y dir
orig
0.1 bskip))
props
x)) args))
(leading
- (cdr (chain-assoc 'baseline-skip props)))
+ (chain-assoc-get 'baseline-skip props))
(stacked (stack-stencils stencils 1.25 #f))
(brackets (make-brackets stacked indices '()))
)
(uniqued-alist (cdr alist) (cons (car alist) acc)))))
-(define-public (assoc-get key alist)
- "Return value if KEY in ALIST, else #f."
+(define-public (assoc-get key alist . default)
+ "Return value if KEY in ALIST, else DEFAULT (or #f if not specified)."
(let ((entry (assoc key alist)))
- (if entry (cdr entry) #f)))
-
-(define-public (assoc-get-default key alist default)
- "Return value if KEY in ALIST, else DEFAULT."
- (let ((entry (assoc key alist)))
- (if entry (cdr entry) default)))
-
+ (if (pair? entry)
+ (cdr entry)
+ (if (pair? default) (car default) #f)
+ )))
(define-public (uniqued-alist alist acc)
(if (null? alist) acc
handle
(chain-assoc x (cdr alist-list))))))
-(define (chain-assoc-get x alist-list default)
+
+(define (chain-assoc-get x alist-list . default)
+ "Return ALIST entry for X. Return DEFAULT (optional, else #f) if not
+found."
(if (null? alist-list)
- default
+ (if (pair? default) (car default) #f)
(let* ((handle (assoc x (car alist-list))))
(if (pair? handle)
(cdr handle)
(chain-assoc-get x (cdr alist-list) default)))))
-
(define (map-alist-vals func list)
"map FUNC over the vals of LIST, leaving the keys."
(if (null? list)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other files.
-(map ly:load
+(for-each ly:load
;; load-from-path
'("define-music-types.scm"
"output-lib.scm"
"clef.scm"
"slur.scm"
"font.scm"
+ "new-font.scm"
"define-markup-commands.scm"
"define-grob-properties.scm"
--- /dev/null
+
+
+;; As an excercise, do it with records.
+;; Should use GOOPS, really.
+
+(define font-tree-record
+ (make-record-type
+ "font-tree-node"
+ '(qualifier default children)))
+
+(define-public font-tree-node?
+ (record-predicate font-tree-record))
+(define-public font-tree-default
+ (record-accessor font-tree-record 'default))
+(define-public font-tree-qualifier
+ (record-accessor font-tree-record 'qualifier))
+(define-public font-tree-children
+ (record-accessor font-tree-record 'children))
+
+
+(define (make-font-tree-node
+ qualifier default)
+ ((record-constructor font-tree-record)
+ qualifier
+ default
+ (make-hash-table 11))) ;ugh. hardcoded.
+
+(define default-qualifier-order
+ '(font-encoding font-family font-shape font-series))
+
+
+(define-public (add-font node fprops size-family)
+ (define (assoc-delete key alist)
+ (assoc-remove! (list-copy alist) key))
+ (define (make-node fprops size-family)
+ (if (null? fprops)
+ size-family
+ (let*
+ ((qual (next-qualifier default-qualifier-order fprops)))
+ (make-font-tree-node qual
+ (assoc-get qual fprops)))
+ ))
+ (define (next-qualifier order props)
+ (cond
+ ((and (null? props) (null? order))
+ #f)
+ ((null? props) (car order))
+ ((null? order) (caar props))
+ (else
+ (if (assoc-get (car order) props)
+ (car order)
+ (next-qualifier (cdr order) props))
+ )))
+
+ (if (font-tree-node? node)
+ (let*
+ ((q (font-tree-qualifier node))
+ (d (font-tree-default node))
+ (v (assoc-get q fprops d))
+ (new-fprops (assoc-delete q fprops))
+ (child (hashq-ref (font-tree-children node)
+ v #f)))
+
+
+ (if (not child)
+ (begin
+ (set! child (make-node new-fprops size-family))
+ (hashq-set! (font-tree-children node) v child)))
+
+ (add-font child new-fprops size-family))
+ (if (not (equal? size-family node))
+ (throw 'invalid-font props size-family)))
+ )
+
+(define-public (display-font-node node . rest)
+ (let*
+ ((port (if (pair? rest) (car rest) (current-output-port)))
+ )
+ (cond
+ ((font-tree-node? node)
+ (map
+ (lambda (x)
+ (display x port))
+
+ (list
+ "Font_node { \nqual: "
+ (font-tree-qualifier node)
+ "(def: "
+ (font-tree-default node)
+ ") {\n"))
+ (for-each
+ (lambda (x)
+ (display "\n")
+ (display (car x) port)
+ (display "=" port)
+ (display-font-node (cdr x) port))
+ (hash-table->alist (font-tree-children node)))
+ (display "} } \n"))
+
+ (else
+ (display node port))))
+ )
+
+(define-public (scale-font-node node factor)
+ (cond
+ ((font-tree-node? node)
+ (hash-for-each (lambda (k v)
+ (scale-font-tree v factor)
+ (font-tree-children node))))
+ (else
+ (cons (* factor (car node))
+ (cdr node)))))
+
+(define-public (lookup-font node alist-chain)
+ (cond
+ ((font-tree-node? node)
+ (let*
+ ((qual (font-tree-qualifier node))
+ (def (font-tree-default node))
+ (val (chain-assoc-get qual alist-chain def))
+ (desired-font (lookup-font
+ (hashq-ref (font-tree-children node)
+ val) alist-chain))
+ (font (if desired-font
+ desired-font
+ (lookup-font (hashq-ref (font-tree-children node)
+ def) alist-chain)))
+
+ )
+
+ font))
+ (else node))
+ )
+
+
+(define-public paper20-font-tree (make-font-tree-node 'font-encoding 'music))
+
+
+
+(add-font
+ paper20-font-tree
+ '((font-encoding . number))
+ '(10 . #((4.0 . "feta-nummer4")
+ (6.0 . "feta-nummer6")
+ (8.0 . "feta-nummer8")
+ (10.0 . "feta-nummer10")
+ (12.0 . "feta-nummer12")
+ (16.0 . "feta-nummer16"))))
+
+(add-font
+ paper20-font-tree
+ '((font-encoding . dynamic))
+ '(14.0 . #((6.0 . "feta-din6")
+ (8.0 . "feta-din8")
+ (10.0 . "feta-din10")
+ (12.0 . "feta-din12")
+ (14.0 . "feta-din14")
+ (17.0 . "feta-din17")
+ )))
+
+ (use-modules (ice-9 readline))
+
+
+
+(for-each
+ (lambda (x)
+ (add-font
+ paper20-font-tree
+ `((font-encoding . text)
+ (font-series . ,(vector-ref (car x) 0))
+ (font-shape . ,(vector-ref (car x) 1))
+ (font-family . ,(vector-ref (car x) 2)))
+ (cdr x))
+ )
+ '(
+ (#(roman upright medium) .
+ (10.0 . #((6.0 . "cmr6")
+ (8.0 . "cmr8")
+ (10.0 . "cmr10")
+ (17.0 . "cmr17")
+ )))
+
+
+
+ (#(roman upright bold) .
+ (10.0 . #((6.0 . "cmbx6")
+ (8.0 . "cmbx8")
+ (10.0 . "cmbx10")
+ (12.0 . "cmbx12")
+ )))
+
+ (#(roman italic medium) .
+ (10.0 . #((7.0 . "cmti7")
+ (10.0 . "cmti10")
+ (12.0 . "cmti12")
+ )))
+ (#(roman italic bold) .
+ (10.0 . #((8.0 . "cmbxti8")
+ (10.0 . "cmbxti10")
+ (14.0 . "cmbxti14")
+ )))
+
+ (#(roman caps medium) .
+ (10.0 . #((10.0 . "cmcsc10"))))
+
+ (#(roman upright bold-narrow ) .
+ (10.0 . #((10.0 . "cmb10")
+ )))
+
+ (#(sans upright medium) .
+ (10.0 . #((8.0 . "cmss8")
+ (10.0 . "cmss10")
+ (12.0 . "cmss12")
+ (17.0 . "cmss17")
+ )))
+ (#(typewriter upright medium) .
+ (10.0 . #((8.0 . "cmtt8")
+ (10.0 . "cmtt10")
+ (12.0 . "cmtt12")
+ )))
+ ))
+
+
+
+(add-font
+ paper20-font-tree
+ '((font-encoding . math))
+ '(10.0 . #((10.0 . "msam10"))))
+
+(add-font
+ paper20-font-tree
+ '((font-encoding . music))
+ '(20.0 . #((11.22 . ("feta11" "parmesan11"))
+ (12.60 . ("feta13" "parmesan13"))
+ (14.14 . ("feta14" "parmesan14"))
+ (15.87 . ("feta16" "parmesan16"))
+ (17.82 . ("feta18" "parmesan18"))
+ (20.0 . ("feta20" "parmesan20"))
+ (22.45 . ("feta23" "parmesan23"))
+ (25.20 . ("feta26" "parmesan26"))
+ )))
+
+(add-font
+ paper20-font-tree
+ '((font-encoding . braces))
+ '(10 . #((10.0 . ("feta-braces00"
+ "feta-braces10"
+ "feta-braces20"
+ "feta-braces30"
+ "feta-braces40"
+ "feta-braces50"
+ "feta-braces60"
+ "feta-braces70"
+ "feta-braces80"))
+ )))
+
+
+(display-font-node paper20-font-tree )
+
+(if #f
+ (begin
+ (newline)
+ (display
+ (lookup-font
+ paper20-font-tree
+ '(((font-encoding . text)
+ (font-shape . italic)
+ ))))
+ (newline)
+ ))
+
+
+
+
+
+(define (scale-font-tree root factor)
+ "Scale ROOT with FACTOR."
+ (cond
+ ((and (font-tree-node? node)
+ (equal? (font-tree-qualifier node) 'font-encoding))
+ (hash-for-each (lambda (k v)
+ (if (not (equal? k 'braces))
+ (scale-font-node v factor))
+ (font-tree-children node))))
+ (else
+ (scale-font-node node))))
+
+
+
(step . step)
))
-(define (assoc-get-default key alist default)
- "Return value if KEY in ALIST, else DEFAULT."
- (let ((entry (assoc key alist)))
- (if entry (cdr entry) default)))
-
(define (musicxml-node->string node)
- (let ((xml-name (assoc-get-default (node-name node) node-names #f)))
+ (let ((xml-name (assoc-get (node-name node) node-names #f)))
(string-append
(if xml-name (open-tag xml-name '() '()) "")
(if (equal? (node-value node) "")
projects / lilypond.git / commitdiff