X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Ffont.scm;h=ec561cc5abd66b55c36a4c80449041e2261b2086;hb=15551c56a17c10f2e1eae0766ddc87a62da119a8;hp=15c48da40e9d150a620e0c61f9ceae897831cafc;hpb=5b83265e53c2095a7fdbda95a536b5a98b464ab8;p=lilypond.git

diff --git a/scm/font.scm b/scm/font.scm
index 15c48da40e..ec561cc5ab 100644
--- a/scm/font.scm
+++ b/scm/font.scm
@@ -7,40 +7,74 @@
 ;;
 ;; should dump tree to .texi as internal documentation
 ;; 
-;; * should extract design sizes from fonts.
+;; * should extract design sizes from fonts: fonts should 
+;; be read off the disk, on demand, something like:
+;;  
+;; cmr -> ((font-load "cmr6") (font-load "cmr8")  .. )
+;;
+
+(define-class <Font-tree-element>
+  ()
+  )
 
-(define font-tree-record
-  (make-record-type
-   "font-tree-node"
-   '(qualifier default children)))
+(define-class <Font-tree-leaf> (<Font-tree-element>)
+  (default-size #:init-keyword #:default-size)
+  (size-vector  #:init-keyword #:size-vector))
 
-(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-class <Font-tree-node> (<Font-tree-element>)
+  (qualifier #:init-keyword #:qualifier  #:accessor font-qualifier)
+  (default #:init-keyword #:default #:accessor font-default)
+  (children #:init-keyword #:children #:accessor font-children))
 
+(define (make-font-tree-leaf size size-font-vector)
+  (make <Font-tree-leaf> #:default-size size #:size-vector size-font-vector))
 
 (define (make-font-tree-node
 	 qualifier default)
-  ((record-constructor font-tree-record)
-    qualifier
-    default
-    (make-hash-table 11)))		;ugh. hardcoded.
+  (make <Font-tree-node>
+     #:qualifier qualifier
+     #:default default 
+     #:children (make-hash-table 11)))
+
+(define-method (display (leaf <Font-tree-leaf>) port)
+  (map (lambda (x) (display x port))
+   (list
+    "Font-size-family: \n"
+     (slot-ref leaf 'default-size) 
+     (slot-ref leaf 'size-vector) )))
+  
+(define-method (display (node <Font-tree-node>) port)
+  
+    (map
+     (lambda (x)
+       (display x port))
+     
+     (list
+      "Font_node { \nqual: "
+      (font-qualifier node)
+      "(def: "
+      (font-default node)
+      ") {\n"))
+    (for-each 
+     (lambda (x)
+       (display "\n")
+       (display (car x) port)
+       (display "=" port)
+       (display (cdr x) port))
+     (hash-table->alist (font-children node)))
+    (display "} } \n"))
+
+
 
 (define default-qualifier-order
   '(font-encoding font-family font-shape font-series))
 
-
-(define-public (add-font node fprops size-family)
+(define-method (add-font (node <Font-tree-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
+	(make-font-tree-leaf (car size-family) (cdr size-family))
 	(let*
 	    ((qual (next-qualifier default-qualifier-order fprops)))
 	  (make-font-tree-node qual
@@ -58,72 +92,50 @@
 	  (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)))
+  (let*
+      ((q (font-qualifier node))
+       (d (font-default node))
+       (v (assoc-get q fprops d))
+       (new-fprops (assoc-delete q fprops))
+       (child (hashq-ref (slot-ref node 'children)
+			 v #f)))
 
 
-	(if (not child)
-	    (begin
-	      (set! child (make-node new-fprops size-family))
-	      (hashq-set! (font-tree-children node) v child)))
+    (if (not child)
+	(begin
+	  (set! child (make-node new-fprops size-family))
+	  (hashq-set! (slot-ref node 'children) v child)))
+    (if (pair? new-fprops)
+	(add-font child new-fprops size-family))))
 
-	(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"))
+(define-method (add-font (node <Font-tree-leaf>) fprops size-family)
+  (throw "must add to node, not leaf"))
 
-     (else
-      (display node port))))
-  )
 
-(define-public (lookup-font node alist-chain)
-  (cond
-   ((font-tree-node? node)
-    (let*
-	((qual (font-tree-qualifier node))
-	 (def (font-tree-default node))
+(define-method (g-lookup-font (node <Font-tree-node>) alist-chain)
+  (let*
+	((qual (font-qualifier node))
+	 (def (font-default node))
 	 (val (chain-assoc-get qual alist-chain def))
 	 (desired-font (lookup-font
-			(hashq-ref (font-tree-children node)
+			(hashq-ref (font-children node)
 				   val) alist-chain))
+
+	 (default (hashq-ref (font-children node) def))
 	 (font (if desired-font
 		   desired-font
-		   (lookup-font (hashq-ref (font-tree-children node)
+		   (g-lookup-font (hashq-ref (font-children node)
 					   def) alist-chain)))
 	 )
       font))
-   (else node)))
+
+(define-method (g-lookup-font (node <Font-tree-leaf>) alist-chain)
+  node)
+
+(define (lookup-font node alist-chain)
+  (g-lookup-font node alist-chain))
+
 
 (define-public (make-font-tree factor)
   (let*
@@ -229,5 +241,7 @@
        ))
     n))
 
+; (display (make-font-tree 1.0))
+
 (define-public (magstep x)
   (exp (* (/ x 6) (log 2))))