X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fnew-markup.scm;h=1e585aa7ba40c39fc404ef4dd1637b57c5a0bc71;hb=c242304638b8cb73b702b29bc37cfca15d0eb397;hp=5cccdc2697756ef1d555d386a91e8cbb100d5440;hpb=66354f084f87e23fe64863952a4ab18cd0c5e82b;p=lilypond.git

diff --git a/scm/new-markup.scm b/scm/new-markup.scm
index 5cccdc2697..1e585aa7ba 100644
--- a/scm/new-markup.scm
+++ b/scm/new-markup.scm
@@ -1,4 +1,3 @@
-
 "
 Internally markup is stored as lists, whose head is a function.
 
@@ -45,10 +44,15 @@ for the reader.
 
 " ; " 
 
-(define-public (simple-markup grob props . rest)
-  (Text_item::text_to_molecule grob props (car rest))
-  )
 
+;;;;;;;;;;;;;;;;;
+;; TODO:
+;; each markup function should have a doc string with
+;; syntax, description and example. 
+;;
+
+(define-public (simple-markup paper props . rest)
+  (Text_item::interpret_markup paper props (car rest)))
 
 (define-public (stack-molecule-line space molecules)
   (if (pair? molecules)
@@ -67,48 +71,44 @@ for the reader.
       '())
   )
 
-(define-public (line-markup grob props . rest)
+(define-public (line-markup paper props . rest)
+  "A horizontal line of markups. Syntax:
+\\line << MARKUPS >>
+"
+  
   (stack-molecule-line
    (cdr (chain-assoc 'word-space props))
-   (map (lambda (x) (interpret-markup grob props x)) (car rest)))
+   (map (lambda (x) (interpret-markup paper props x)) (car rest)))
   )
 
-(define (combine-molecule-list lst)
-  (if (null? (cdr lst)) (car lst)
-      (ly:molecule-add (car lst) (combine-molecule-list (cdr lst)))
-      ))
 
-(define-public (combine-markup grob props . rest)
+(define-public (combine-markup paper props . rest)
   (ly:molecule-add
-   (interpret-markup grob props (car rest))
-   (interpret-markup grob props (cadr rest))))
+   (interpret-markup paper props (car rest))
+   (interpret-markup paper props (cadr rest))))
   
-;   (combine-molecule-list (map (lambda (x) (interpret-markup grob props x)) (car rest))))
-
 (define (font-markup qualifier value)
-  (lambda (grob props . rest)
-    (interpret-markup grob (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
+  (lambda (paper props . rest)
+    (interpret-markup paper (cons (cons `(,qualifier . ,value) (car props)) (cdr props)) (car rest))
   
   ))
 
 
 (define-public (set-property-markup qualifier)
-  (lambda (grob props . rest  )
-    (interpret-markup grob
+  (lambda (paper props . rest  )
+    (interpret-markup paper
 		      (cons (cons `(,qualifier . ,(car rest))
 				  (car props)) (cdr props))
 		      (cadr rest))
     ))
 
-
-(define-public (finger-markup grob props . rest)
-  (interpret-markup grob
+(define-public (finger-markup paper props . rest)
+  (interpret-markup paper
 		    (cons (list '(font-relative-size . -3)
 				'(font-family . number))
 				props)
 		    (car rest)))
 
-
 (define-public fontsize-markup (set-property-markup 'font-relative-size))
 (define-public magnify-markup (set-property-markup 'font-magnification))
 
@@ -134,16 +134,18 @@ for the reader.
   (font-markup 'font-family 'dynamic))
 (define-public italic-markup
   (font-markup 'font-shape 'italic))
+(define-public typewriter-markup
+  (font-markup 'font-family 'typewriter))
 
 
 ;; TODO: baseline-skip should come from the font.
-(define-public (column-markup grob props . rest)
+(define-public (column-markup paper props . rest)
   (stack-lines
    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
-   (map (lambda (x) (interpret-markup grob props x)) (car rest)))
+   (map (lambda (x) (interpret-markup paper props x)) (car rest)))
   )
 
-(define-public (dir-column-markup grob props . rest)
+(define-public (dir-column-markup paper props . rest)
   "Make a column of args, going up or down, depending on DIRECTION."
   (let*
       (
@@ -152,13 +154,13 @@ for the reader.
     (stack-lines
      (if (number? dir) dir -1)
      0.0 (cdr (chain-assoc 'baseline-skip props))
-     (map (lambda (x) (interpret-markup grob props x)) (car rest)))
+     (map (lambda (x) (interpret-markup paper props x)) (car rest)))
     ))
 
-(define-public (center-markup grob props . rest)
+(define-public (center-markup paper props . rest)
   (let*
     (
-     (mols (map (lambda (x) (interpret-markup grob props x)) (car rest)))
+     (mols (map (lambda (x) (interpret-markup paper props x)) (car rest)))
      (cmols (map (lambda (x) (ly:molecule-align-to! x X CENTER)) mols))
      )
     
@@ -167,99 +169,221 @@ for the reader.
      mols)
     ))
 
-(define-public (musicglyph-markup grob props . rest)
+(define-public (right-align-markup paper props . rest)
+  (let* ((m (interpret-markup paper props (car rest))))
+    (ly:molecule-align-to! m X RIGHT)
+    m))
+
+(define-public (halign-markup paper props . rest)
+  "Set horizontal alignment. Syntax: haling A MARKUP. A=-1 is LEFT,
+A=1 is right, values in between vary alignment accordingly."
+  (let* ((m (interpret-markup paper props (cadr rest))))
+    (ly:molecule-align-to! m X (car rest))
+    m))
+
+(define-public (left-align-markup paper props . rest)
+  (let* ((m (interpret-markup paper props (car rest))))
+    (ly:molecule-align-to! m X RIGHT)
+    m))
+
+(define-public (musicglyph-markup paper props . rest)
   (ly:find-glyph-by-name
-   (ly:get-font grob (cons '((font-family . music)) props))
+   (ly:paper-get-font paper (cons '((font-name . ()) (font-family . music)) props))
    (car rest))
   )
 
 
-(define-public (lookup-markup grob props . rest)
+(define-public (lookup-markup paper props . rest)
   "Lookup a glyph by name."
   (ly:find-glyph-by-name
-   (ly:get-font grob props)
+   (ly:paper-get-font paper  props)
    (car rest))
   )
 
-(define-public (char-markup grob props . rest)
+(define-public (char-markup paper props . rest)
   "Syntax: \\char NUMBER. "
-  (ly:get-glyph  (ly:get-font grob props) (car rest))
+  (ly:get-glyph  (ly:paper-get-font paper props) (car rest))
   )
 
-(define-public (raise-markup grob props  . rest)
+(define-public (raise-markup paper props  . rest)
   "Syntax: \\raise AMOUNT MARKUP. "
   (ly:molecule-translate-axis (interpret-markup
-			       grob
+			       paper
 			       props
 			       (cadr rest))
-			      (car rest) Y)
-  )
+			      (car rest) Y))
+
+(define-public (fraction-markup paper props . rest)
+  "Make a fraction of two markups.
+
+Syntax: \\fraction MARKUP1 MARKUP2."
 
-(define-public (normal-size-super-markup grob props . rest)
+  (let*
+      ((m1 (interpret-markup paper props (car rest)))
+       (m2 (interpret-markup paper props (cadr rest))))
+
+    (ly:molecule-align-to! m1 X CENTER)
+    (ly:molecule-align-to! m2 X CENTER)
+    
+    (let*
+	((x1 (ly:molecule-get-extent m1 X))
+	 (x2 (ly:molecule-get-extent m2 X))
+	 (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0))
+
+	 ;; should stack mols separately, to maintain LINE on baseline
+	 (stack (stack-lines -1 0.2 0.6 (list m1 line m2))))
+
+      (ly:molecule-align-to! stack Y CENTER)
+      (ly:molecule-align-to! stack X LEFT)
+      ;; should have EX dimension
+      ;; empirical anyway
+      (ly:molecule-translate-axis stack 0.75 Y) 
+      )))
+
+
+(define-public (note-markup paper props . rest)
+  "Syntax: \\note #LOG #DOTS #DIR.  By using fractional values
+for DIR, you can obtain longer or shorter stems."
+ 
+  (let*
+      (
+       (log (car rest))
+       (dot-count (cadr rest))
+       (dir (caddr rest))
+       (font (ly:paper-get-font paper (cons '((font-family .  music)) props)))
+       (stemlen (max 3 (- log 1)))
+       (headgl
+	(ly:find-glyph-by-name font (string-append "noteheads-" (number->string (min log 2)))))
+
+       (stemth 0.13)
+       (stemy (* dir stemlen))
+       (attachx (if (> dir 0) (- (cdr (ly:molecule-get-extent headgl X)) stemth)
+		    0))
+       (attachy (* dir 0.28))
+       (stemgl (if (> log 0)
+		   (ly:round-filled-box
+				     (cons attachx (+ attachx  stemth))
+				     (cons (min stemy attachy)
+					   (max stemy attachy))
+				    (/ stemth 3)
+				    ) #f))
+       (dot (ly:find-glyph-by-name font "dots-dot"))
+       (dotwid  (interval-length (ly:molecule-get-extent dot X)))
+       (dots (if (> dot-count 0)
+		 (apply ly:molecule-add
+		  (map (lambda (x)
+			 (ly:molecule-translate-axis
+			  dot  (* (+ 1 (* 2 x)) dotwid) X) )
+		       (iota dot-count 1)))
+		 #f))
+       
+       (flaggl (if (> log 2)
+		   (ly:molecule-translate
+		    (ly:find-glyph-by-name
+		     font
+		     (string-append "flags-"
+				    (if (> dir 0) "u" "d")
+				    (number->string log)
+				    ))
+		    (cons (+ attachx (/ stemth 2)) stemy))
+
+		    #f)))
+    
+    (if flaggl
+	(set! stemgl (ly:molecule-add flaggl stemgl)))
+
+    (if (ly:molecule? stemgl)
+	(set! stemgl (ly:molecule-add stemgl headgl))
+        (set! stemgl headgl)
+	)
+    
+    (if (ly:molecule? dots)
+	(set! stemgl
+	      (ly:molecule-add
+	       (ly:molecule-translate-axis
+		dots
+		(+
+		 (if (and (> dir 0) (> log 2))
+		     (* 1.5 dotwid) 0)
+		 ;; huh ? why not necessary?
+		;(cdr (ly:molecule-get-extent headgl X))
+		      dotwid
+		 )
+		X)
+	       stemgl 
+	       )
+	      ))
+
+    stemgl
+    ))
+
+(define-public (normal-size-super-markup paper props . rest)
   (ly:molecule-translate-axis (interpret-markup
-			       grob
+			       paper
 			       props (car rest))
 			      (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 			      Y)
   )
 
-(define-public (super-markup grob props  . rest)
+(define-public (super-markup paper props  . rest)
   "Syntax: \\super MARKUP. "
   (ly:molecule-translate-axis (interpret-markup
-			       grob
+			       paper
 			       (cons '((font-relative-size . -2)) props) (car rest))
 			      (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 			      Y)
   )
 
-(define-public (translate-markup grob props . rest)
+(define-public (translate-markup paper props . rest)
   "Syntax: \\translate OFFSET MARKUP. "
-  (ly:molecule-translate (interpret-markup  grob props (cadr rest))
+  (ly:molecule-translate (interpret-markup  paper props (cadr rest))
 			 (car rest))
 
   )
 
-(define-public (sub-markup grob props  . rest)
+(define-public (sub-markup paper props  . rest)
   "Syntax: \\sub MARKUP."
   (ly:molecule-translate-axis (interpret-markup
-			       grob
+			       paper
 			       (cons '((font-relative-size . -2)) props)
 			       (car rest))
 			      (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 			      Y)
   )
 
-(define-public (normal-size-sub-markup grob props . rest)
+(define-public (normal-size-sub-markup paper props . rest)
   (ly:molecule-translate-axis (interpret-markup
-			       grob
+			       paper
 			       props (car rest))
 			      (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 			      Y)
   )
 
-(define-public (hbracket-markup grob props . rest)
+(define-public (hbracket-markup paper props . rest)
+  "Horizontal brackets around its single argument. Syntax \\hbracket MARKUP."  
+  
   (let*
       (
        (th 0.1) ;; todo: take from GROB.
-       (m (interpret-markup grob props (car rest)))
+       (m (interpret-markup paper props (car rest)))
        )
 
     (bracketify-molecule m X th (* 2.5 th) th)  
 ))
 
-(define-public (bracket-markup grob props . rest)
+(define-public (bracket-markup paper props . rest)
+  "Vertical brackets around its single argument. Syntax \\bracket MARKUP."  
   (let*
       (
        (th 0.1) ;; todo: take from GROB.
-       (m (interpret-markup grob props (car rest)))
+       (m (interpret-markup paper props (car rest)))
        )
 
     (bracketify-molecule m Y th (* 2.5 th) th)  
 ))
 
-
 ;; todo: fix negative space
-(define (hspace-markup grob props . rest)
+(define (hspace-markup paper props . rest)
   "Syntax: \\hspace NUMBER."
   (let*
       ((amount (car rest)))
@@ -268,30 +392,29 @@ for the reader.
 	(ly:make-molecule "" (cons amount amount) '(-1 . 1)))
   ))
 
-(define-public (override-markup grob props . rest)
+(define-public (override-markup paper props . rest)
   "Tack the 1st arg in REST onto PROPS, e.g.
 
 \override #'(font-family . married) \"bla\"
 
 "
   
-  (interpret-markup grob (cons (list (car rest)) props)
+  (interpret-markup paper (cons (list (car rest)) props)
 		    (cadr rest)))
 
-(define-public (smaller-markup  grob props . rest)
+(define-public (smaller-markup  paper props . rest)
   "Syntax: \\smaller MARKUP"
   (let*
       (
        (fs (cdr (chain-assoc 'font-relative-size props)))
        (entry (cons 'font-relative-size (- fs 1)))
        )
-  (interpret-markup
-   grob (cons (list entry) props)
-   (car rest))
-
-  ))
+    (interpret-markup
+     paper (cons (list entry) props)
+     (car rest))
+    ))
 
-(define-public (bigger-markup  grob props . rest)
+(define-public (bigger-markup  paper props . rest)
   "Syntax: \\bigger MARKUP"
   (let*
       (
@@ -299,10 +422,38 @@ for the reader.
        (entry (cons 'font-relative-size (+ fs 1)))
        )
   (interpret-markup
-   grob (cons (list entry) props)
+   paper (cons (list entry) props)
    (car rest))
   ))
 
+(define-public (box-markup paper props . rest)
+  "Syntax: \\box MARKUP"
+  (let*
+      (
+       (th 0.1)
+       (pad 0.2)
+       (m (interpret-markup paper props (car rest)))
+       )
+    (box-molecule m th pad)
+  ))
+
+
+(define-public (strut-markup paper props . rest)
+  "Syntax: \strut
+
+ A box of the same height as the space.
+"
+
+  (let*
+      ((m (Text_item::interpret_markup paper props " ")))
+
+    (ly:molecule-set-extent! m 0 '(1000 . -1000))
+    m))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 (define (markup-signature-to-keyword sig)
   " (A B C) -> a0-b1-c2 "
   
@@ -411,7 +562,7 @@ for the reader.
 ;; 
 (define markup?  cheap-markup?)
 
-(define markup-function-list
+(define markup-functions-and-signatures
   (list
 
    ;; abs size
@@ -426,7 +577,8 @@ for the reader.
    ;; size
    (cons smaller-markup (list markup?))
    (cons bigger-markup (list markup?))
-
+;   (cons char-number-markup (list string?))
+   
    ;; 
    (cons sub-markup (list markup?))
    (cons normal-size-sub-markup (list markup?))
@@ -437,16 +589,23 @@ for the reader.
    (cons finger-markup (list markup?))
    (cons bold-markup (list markup?))
    (cons italic-markup (list markup?))
+   (cons typewriter-markup (list markup?))
    (cons roman-markup (list markup?))
    (cons number-markup (list markup?))
    (cons hbracket-markup  (list markup?))
    (cons bracket-markup  (list markup?))
+   (cons note-markup (list integer? integer? ly:dir?))
+   (cons fraction-markup (list markup? markup?))
    
    (cons column-markup (list markup-list?))
    (cons dir-column-markup (list markup-list?))
    (cons center-markup (list markup-list?))
    (cons line-markup  (list markup-list?))
 
+   (cons right-align-markup (list markup?))
+   (cons left-align-markup (list markup?))   
+   (cons halign-markup (list number? markup?))
+   
    (cons combine-markup (list markup? markup?))
    (cons simple-markup (list string?))
    (cons musicglyph-markup (list scheme?))
@@ -460,8 +619,10 @@ for the reader.
    (cons raise-markup (list number? markup?))
    (cons magnify-markup (list number? markup?))
    (cons fontsize-markup (list number? markup?))
-   )
-  )
+
+   (cons box-markup  (list markup?))
+   (cons strut-markup '())
+   ))
 
 
 (define markup-module (current-module))
@@ -470,7 +631,9 @@ for the reader.
        (set-object-property! (car x) 'markup-signature (cdr x))
        (set-object-property! (car x) 'markup-keyword (markup-signature-to-keyword (cdr x)))
        )
-     markup-function-list)
+     markup-functions-and-signatures)
+
+(define-public markup-function-list (map car markup-functions-and-signatures))
 
 
 ;; construct a
@@ -525,13 +688,12 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 "
 
   (let*
-      (
-       (arglen (length args))
+      ((arglen (length args))
        (siglen (length signature))
        (error-msg
 	(if (and (> siglen 0) (> arglen 0))
-	    (markup-argument-list-error signature args 1)))
-       )
+	    (markup-argument-list-error signature args 1)
+	    #f)))
 
 
     (if (or (not (= arglen siglen)) (< siglen 0) (< arglen 0))
@@ -560,15 +722,19 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   )
 
 (eval
- (cons 'begin (map make-markup-maker markup-function-list))
+ (cons 'begin (map make-markup-maker markup-functions-and-signatures))
  markup-module
  )
 
+;;
+;; TODO: add module argument so user-defined markups can also be 
+;; processed.
+;;
 (define-public (lookup-markup-command code)
   (let*
-      ( (sym (string->symbol (string-append code "-markup")))
-	(var (module-local-variable markup-module sym))
-	)
+      ((sym (string->symbol (string-append code "-markup")))
+       (var (module-local-variable markup-module sym))
+       )
     (if (eq? var #f)
 	#f   
 	(cons (variable-ref var) (object-property  (variable-ref var) 'markup-keyword))
@@ -576,31 +742,11 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   ))
 
 
-(define-public (brew-new-markup-molecule grob)
-  (let*
-      ((t     (ly:get-grob-property grob 'text))
-       )
-    (if (null? t)
-	'()
-	(interpret-markup grob
-			  (Font_interface::get_property_alist_chain grob)
-			  t
-			  ))
-  ))
+(define-public brew-new-markup-molecule Text_item::brew_molecule)
 
-(define-public empty-markup `(,simple-markup ""))
+(define-public empty-markup (make-simple-markup ""))
 
-(define (interpret-markup  grob props markup)
-  (if (string? markup)
-      (simple-markup grob props markup)
-      (let*
-	  (
-	   (func (car markup))
-	   (args (cdr markup))
-	   )
-	
-	(apply func (cons grob (cons props args)) )
-	)))
+(define-public interpret-markup Text_item::interpret_markup)
 
 
 ;;;;;;;;;;;;;;;;