From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Sat, 13 Mar 2004 17:01:57 +0000 (+0000)
Subject: * scm/new-font.scm: new file. Tree based font lookup.
X-Git-Tag: release/2.1.31~16
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=d98c876a6e6f699e71fbb3a3fe5af882b4274223;p=lilypond.git

* 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.
---

diff --git a/ChangeLog b/ChangeLog
index ff1106ae30..b2e0dc286f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,11 @@
 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.
 
diff --git a/elisp/lilypond-mode.el b/elisp/lilypond-mode.el
index b389086858..fb53bb0358 100644
--- a/elisp/lilypond-mode.el
+++ b/elisp/lilypond-mode.el
@@ -1163,6 +1163,17 @@ LilyPond-xdvi-command\t\tcommand to display dvi files -- bit superfluous"
 (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
 
diff --git a/input/test/cue-notes.ly b/input/test/cue-notes.ly
index 2b3f4fbad6..9d63c56293 100644
--- a/input/test/cue-notes.ly
+++ b/input/test/cue-notes.ly
@@ -15,9 +15,8 @@ Cue notes are typeset in a smaller font. "
        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
diff --git a/scm/chord-generic-names.scm b/scm/chord-generic-names.scm
index 5b8e064184..c51b8c7438 100644
--- a/scm/chord-generic-names.scm
+++ b/scm/chord-generic-names.scm
@@ -196,15 +196,15 @@ input/test/dpncnt.ly).
        ;;    + 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
@@ -234,16 +234,16 @@ input/test/dpncnt.ly).
        ;;    + 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
diff --git a/scm/define-markup-commands.scm b/scm/define-markup-commands.scm
index 114cdf5a43..6d765b7182 100644
--- a/scm/define-markup-commands.scm
+++ b/scm/define-markup-commands.scm
@@ -40,8 +40,8 @@
 					  (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)
@@ -64,7 +64,7 @@
   "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?)
@@ -218,24 +218,24 @@ recommend font for this is bold and italic"
 (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)))
@@ -415,7 +415,7 @@ a shortened down stem."
   (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?)
@@ -442,7 +442,7 @@ Raising and lowering texts can be done with @code{\\super} and
     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?)
@@ -467,7 +467,7 @@ that.
     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?)
@@ -475,7 +475,7 @@ that.
 
   (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?)
@@ -602,10 +602,7 @@ the elements marked in @var{indices}, which is a list of numbers."
      (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))
@@ -649,7 +646,7 @@ the elements marked in @var{indices}, which is a list of numbers."
 		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 '()))
        )
diff --git a/scm/lily.scm b/scm/lily.scm
index cdbc6e8ad3..60fbcf744b 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -106,16 +106,13 @@
 	  (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
@@ -137,15 +134,17 @@
 	    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)
@@ -397,7 +396,7 @@ L1 is copied, L2 not.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other files.
 
-(map ly:load
+(for-each ly:load
      ;; load-from-path
      '("define-music-types.scm"
        "output-lib.scm"
@@ -423,6 +422,7 @@ L1 is copied, L2 not.
        "clef.scm"
        "slur.scm"
        "font.scm"
+       "new-font.scm"
        
        "define-markup-commands.scm"
        "define-grob-properties.scm"
diff --git a/scm/new-font.scm b/scm/new-font.scm
new file mode 100644
index 0000000000..e131ea4256
--- /dev/null
+++ b/scm/new-font.scm
@@ -0,0 +1,289 @@
+
+
+;; 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))))
+
+    
+
diff --git a/scm/to-xml.scm b/scm/to-xml.scm
index d97f2682ac..7d0a400cc1 100644
--- a/scm/to-xml.scm
+++ b/scm/to-xml.scm
@@ -50,13 +50,8 @@ is then separated.
     (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) "")