X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fnew-markup.scm;h=e59c4bcc709a8a2f7f96a9afd80f4ef1a35a73a4;hb=3ce32cf251bf7b05cc34363d797d3e1ad9ede48b;hp=07f6d11f34c6de8d84b7b0887b43eec734b7a091;hpb=8b2bd9e355a71c9bb8388fd25e7cc958eee26fe7;p=lilypond.git

diff --git a/scm/new-markup.scm b/scm/new-markup.scm
index 07f6d11f34..e59c4bcc70 100644
--- a/scm/new-markup.scm
+++ b/scm/new-markup.scm
@@ -45,13 +45,15 @@ for the reader.
 
 " ; " 
 
-;; debugging.
 
-(define (mydisplay x) (display x) (newline) x)
+;;;;;;;;;;;;;;;;;
+;; TODO:
+;; each markup function should have a doc string with
+;; syntax, description and example. 
+;;
 
 (define-public (simple-markup grob props . rest)
-  (Text_item::text_to_molecule grob props (car rest))
-  )
+  (Text_item::interpret_markup grob props (car rest)))
 
 (define-public (stack-molecule-line space molecules)
   (if (pair? molecules)
@@ -59,10 +61,10 @@ for the reader.
 	  (let* (
 		 (tail (stack-molecule-line  space (cdr molecules)))
 		 (head (car molecules))
-		 (xoff (+ space (cdr (ly:get-molecule-extent head X))))
+		 (xoff (+ space (cdr (ly:molecule-get-extent head X))))
 		 )
 	    
-	    (ly:add-molecule
+	    (ly:molecule-add
 	     head
 	     (ly:molecule-translate-axis tail xoff X))
 	  )
@@ -71,23 +73,21 @@ for the reader.
   )
 
 (define-public (line-markup grob 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)))
   )
 
-(define (combine-molecule-list lst)
-  (if (null? (cdr lst)) (car lst)
-      (ly:add-molecule (car lst) (combine-molecule-list (cdr lst)))
-      ))
 
 (define-public (combine-markup grob props . rest)
-  (ly:add-molecule
+  (ly:molecule-add
    (interpret-markup grob props (car rest))
    (interpret-markup grob 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))
@@ -103,6 +103,12 @@ for the reader.
 		      (cadr rest))
     ))
 
+(define-public (finger-markup grob props . rest)
+  (interpret-markup grob
+		    (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))
@@ -111,6 +117,8 @@ for the reader.
   (font-markup 'font-series 'bold))
 (define-public number-markup
   (font-markup 'font-family 'number))
+(define-public roman-markup
+  (font-markup 'font-family 'roman))
 
 
 (define-public huge-markup
@@ -127,6 +135,8 @@ 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.
@@ -136,12 +146,54 @@ for the reader.
    (map (lambda (x) (interpret-markup grob props x)) (car rest)))
   )
 
+(define-public (dir-column-markup grob props . rest)
+  "Make a column of args, going up or down, depending on DIRECTION."
+  (let*
+      (
+       (dir (cdr (chain-assoc 'direction props)))
+       )
+    (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)))
+    ))
+
+(define-public (center-markup grob props . rest)
+  (let*
+    (
+     (mols (map (lambda (x) (interpret-markup grob props x)) (car rest)))
+     (cmols (map (lambda (x) (ly:molecule-align-to! x X CENTER)) mols))
+     )
+    
+    (stack-lines
+     -1 0.0 (cdr (chain-assoc 'baseline-skip props))
+     mols)
+    ))
+
+(define-public (right-align-markup grob props . rest)
+  (let* ((m (interpret-markup grob props (car rest))))
+    (ly:molecule-align-to! m X RIGHT)
+    m))
+
+(define-public (halign-markup grob 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 grob props (cadr rest))))
+    (ly:molecule-align-to! m X (car rest))
+    m))
+
+(define-public (left-align-markup grob props . rest)
+  (let* ((m (interpret-markup grob props (car rest))))
+    (ly:molecule-align-to! m X RIGHT)
+    m))
+
 (define-public (musicglyph-markup grob props . rest)
   (ly:find-glyph-by-name
    (ly:get-font grob (cons '((font-family . music)) props))
    (car rest))
   )
 
+
 (define-public (lookup-markup grob props . rest)
   "Lookup a glyph by name."
   (ly:find-glyph-by-name
@@ -160,10 +212,111 @@ for the reader.
 			       grob
 			       props
 			       (cadr rest))
-			      (car rest) Y)
-  )
+			      (car rest) Y))
+
+(define-public (fraction-markup grob props . rest)
+  "Make a fraction of two markups.
+
+Syntax: \\fraction MARKUP1 MARKUP2."
+
+  (let*
+      ((m1 (interpret-markup grob props (car rest)))
+       (m2 (interpret-markup grob 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 (normal-size-superscript-markup grob props . rest)
+(define-public (note-markup grob props . rest)
+  "Syntax: \\note #LOG #DOTS #DIR. "
+  (let*
+      (
+       (log (car rest))
+       (dot-count (cadr rest))
+       (dir (caddr rest))
+       (font (ly:get-font grob (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 grob props . rest)
   (ly:molecule-translate-axis (interpret-markup
 			       grob
 			       props (car rest))
@@ -197,6 +350,37 @@ for the reader.
 			      Y)
   )
 
+(define-public (normal-size-sub-markup grob props . rest)
+  (ly:molecule-translate-axis (interpret-markup
+			       grob
+			       props (car rest))
+			      (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
+			      Y)
+  )
+
+(define-public (hbracket-markup grob 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)))
+       )
+
+    (bracketify-molecule m X th (* 2.5 th) th)  
+))
+
+(define-public (bracket-markup grob 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)))
+       )
+
+    (bracketify-molecule m Y th (* 2.5 th) th)  
+))
+
 ;; todo: fix negative space
 (define (hspace-markup grob props . rest)
   "Syntax: \\hspace NUMBER."
@@ -224,11 +408,10 @@ for the reader.
        (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
+     grob (cons (list entry) props)
+     (car rest))
+    ))
 
 (define-public (bigger-markup  grob props . rest)
   "Syntax: \\bigger MARKUP"
@@ -242,6 +425,34 @@ for the reader.
    (car rest))
   ))
 
+(define-public (box-markup grob props . rest)
+  "Syntax: \\box MARKUP"
+  (let*
+      (
+       (th 0.1)
+       (pad 0.2)
+       (m (interpret-markup grob props (car rest)))
+       )
+    (box-molecule m th pad)
+  ))
+
+
+(define-public (strut-markup grob props . rest)
+  "Syntax: \strut
+
+ A box of the same height as the space.
+"
+
+  (let*
+      ((m (Text_item::interpret_markup grob props " ")))
+
+    (ly:molecule-set-extent! m 0 '(1000 . -1000))
+    m))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
 (define (markup-signature-to-keyword sig)
   " (A B C) -> a0-b1-c2 "
   
@@ -307,18 +518,21 @@ for the reader.
 ;; full recursive typecheck.
 ;;
 (define (markup-typecheck? arg)
-  (and (pair? arg)
+  (or (string? arg)
+      (and (pair? arg)
        (markup-function? (car arg))
        (markup-argument-list?
 	(object-property (car arg) 'markup-signature)
 	(cdr arg))
   ))
+)
 
 ;; 
 ;; typecheck, and throw an error when something amiss.
 ;; 
 (define (markup-thrower-typecheck arg)
   (cond
+   ((string? arg) #t)
    ((not (pair? arg))
     (throw 'markup-format "Not a pair" arg)
     )
@@ -333,13 +547,13 @@ for the reader.
    #t
   )
 
-
 ;;
 ;; good enough if you only  use make-XXX-markup functions.
 ;; 
 (define (cheap-markup? x)
-  (and (pair? x)
-       (markup-function? (car x)))
+  (or (string? x)
+      (and (pair? x)
+	   (markup-function? (car x))))
 )
 
 ;;
@@ -347,8 +561,7 @@ for the reader.
 ;; 
 (define markup?  cheap-markup?)
 
-
-(define markup-function-list
+(define markup-functions-and-signatures
   (list
 
    ;; abs size
@@ -363,23 +576,38 @@ 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 super-markup (list markup?))
+   (cons normal-size-sub-markup (list markup?))
    
+   (cons super-markup (list markup?))
+   (cons normal-size-super-markup (list markup?))
+
+   (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?))
-   
    (cons translate-markup (list number-pair? markup?))
    (cons override-markup (list pair? markup?))
    (cons char-markup (list integer?))
@@ -390,8 +618,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))
@@ -400,7 +630,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
@@ -455,13 +687,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))
@@ -484,21 +715,25 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
 	 (signature (object-property (car entry) 'markup-signature))
 	 )
   
-    `(define (,(string->symbol make-name) . args)
+    `(define-public (,(string->symbol make-name) . args)
        (make-markup ,(car entry) ,make-name ,(cons 'list signature)  args)
        ))
   )
 
 (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))
@@ -506,24 +741,21 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
   ))
 
 
-(define-public (brew-new-markup-molecule grob)
-  (interpret-markup grob
-		    (Font_interface::get_property_alist_chain grob)
-		    (ly:get-grob-property grob 'text)
-		    )
-  )
+(define-public brew-new-markup-molecule Text_item::brew_molecule)
 
-(define-public empty-markup `(,simple-markup ""))
+(define-public empty-markup (make-simple-markup ""))
+
+(define-public interpret-markup Text_item::interpret_markup)
 
-(define (interpret-markup  grob props markup)
-  (let*
-      (
-       (func (car markup))
-       (args (cdr markup))
-       )
-    
-    (apply func (cons grob (cons props args)) )
-    ))
+
+;;;;;;;;;;;;;;;;
+;; utility
+
+(define (markup-join markups sep)
+  "Return line-markup of MARKUPS, joining them with markup SEP"
+  (if (pair? markups)
+      (make-line-markup (list-insert-separator markups sep))
+      empty-markup))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -542,7 +774,7 @@ against SIGNATURE, reporting MAKE-NAME as the user-invoked function.
       )))
 
 ;; test make-foo-markup functions
-(if #t
+(if #f
     (begin
       (newline)
       (newline)