X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Flily-library.scm;h=d21e292ccf2b7f2ecc97856da3895aa182dd3d8f;hb=e67a1c03095902d20cf16a5eb907000a9640b180;hp=eb537a8e7183b66238158bc047e92b5c85206dda;hpb=569714401fbe0e814f0282059f157aa36a54c706;p=lilypond.git

diff --git a/scm/lily-library.scm b/scm/lily-library.scm
index eb537a8e71..d21e292ccf 100644
--- a/scm/lily-library.scm
+++ b/scm/lily-library.scm
@@ -257,6 +257,125 @@ bookoutput function"
                      parser
 		     music))
 
+(define-public (context-mod-from-music parser music)
+  (let ((warn #t) (mods (ly:make-context-mod)))
+    (let loop ((m music))
+      (if (music-is-of-type? m 'layout-instruction-event)
+	  (let ((symbol (ly:music-property m 'symbol)))
+	    (ly:add-context-mod
+	     mods
+	     (case (ly:music-property m 'name)
+	       ((PropertySet)
+		(list 'assign
+		      symbol
+		      (ly:music-property m 'value)))
+	       ((PropertyUnset)
+		(list 'unset symbol))
+	       ((OverrideProperty)
+		(cons* 'push
+		       symbol
+		       (ly:music-property m 'grob-value)
+                       (cond
+                        ((ly:music-property m 'grob-property #f) => list)
+                        (else
+                         (ly:music-property m 'grob-property-path)))))
+               ((RevertProperty)
+		(cons* 'pop
+		       symbol
+                       (cond
+                        ((ly:music-property m 'grob-property #f) => list)
+                        (else
+                         (ly:music-property m 'grob-property-path))))))))
+	  (case (ly:music-property m 'name)
+	    ((ApplyContext)
+	     (ly:add-context-mod mods
+				 (list 'apply
+				       (ly:music-property m 'procedure))))
+	    ((ContextSpeccedMusic)
+	     (loop (ly:music-property m 'element)))
+	    (else
+	     (let ((callback (ly:music-property m 'elements-callback)))
+	       (if (procedure? callback)
+		   (for-each loop (callback m))
+		   (if (and warn (ly:duration? (ly:music-property m 'duration)))
+		       (begin
+			 (ly:music-warning
+			  music
+			  (_ "Music unsuitable for context-mod"))
+			 (set! warn #f)))))))))
+    mods))
+
+(define-public (context-defs-from-music parser output-def music)
+  (let ((warn #t))
+    (let loop ((m music) (mods #f))
+      ;; The parser turns all sets, overrides etc into something
+      ;; wrapped in ContextSpeccedMusic.  If we ever get a set,
+      ;; override etc that is not wrapped in ContextSpeccedMusic, the
+      ;; user has created it in Scheme himself without providing the
+      ;; required wrapping.  In that case, using #f in the place of a
+      ;; context modification results in a reasonably recognizable
+      ;; error.
+      (if (music-is-of-type? m 'layout-instruction-event)
+	  (ly:add-context-mod
+	   mods
+	   (case (ly:music-property m 'name)
+	     ((PropertySet)
+	      (list 'assign
+		    (ly:music-property m 'symbol)
+		    (ly:music-property m 'value)))
+	     ((PropertyUnset)
+	      (list 'unset
+		    (ly:music-property m 'symbol)))
+	     ((OverrideProperty)
+	      (cons* 'push
+		     (ly:music-property m 'symbol)
+		     (ly:music-property m 'grob-value)
+                     (cond
+                      ((ly:music-property m 'grob-property #f) => list)
+                      (else
+                       (ly:music-property m 'grob-property-path)))))
+	     ((RevertProperty)
+	      (cons* 'pop
+		     (ly:music-property m 'symbol)
+                     (cond
+                      ((ly:music-property m 'grob-property #f) => list)
+                      (else
+                       (ly:music-property m 'grob-property-path)))))))
+	  (case (ly:music-property m 'name)
+	    ((ApplyContext)
+	     (ly:add-context-mod mods
+				 (list 'apply
+				       (ly:music-property m 'procedure))))
+	    ((ContextSpeccedMusic)
+	     ;; Use let* here to let defs catch up with modifications
+	     ;; to the context defs made in the recursion
+	     (let* ((mods (loop (ly:music-property m 'element)
+				(ly:make-context-mod)))
+		    (defs (ly:output-find-context-def
+			   output-def (ly:music-property m 'context-type))))
+	       (if (null? defs)
+		   (ly:music-warning
+		    music
+		    (ly:format (_ "Cannot find context-def \\~a")
+			       (ly:music-property m 'context-type)))
+		   (for-each
+		    (lambda (entry)
+		      (ly:output-def-set-variable!
+		       output-def (car entry)
+		       (ly:context-def-modify (cdr entry) mods)))
+		    defs))))
+	    (else
+	     (let ((callback (ly:music-property m 'elements-callback)))
+	       (if (procedure? callback)
+		   (fold loop mods (callback m))
+		   (if (and warn (ly:duration? (ly:music-property m 'duration)))
+		       (begin
+			 (ly:music-warning
+			  music
+			  (_ "Music unsuitable for output-def"))
+			 (set! warn #f))))))))
+      mods)))
+
 
 ;;;;;;;;;;;;;;;;
 ;; alist
@@ -543,6 +662,10 @@ right (@var{dir}=+1)."
 (define (other-axis a)
   (remainder (+ a 1) 2))
 
+(define-public (interval-scale iv factor)
+  (cons (* (car iv) factor)
+    (* (cdr iv) factor)))
+
 (define-public (interval-widen iv amount)
   (cons (- (car iv) amount)
     (+ (cdr iv) amount)))