From: David Nalesnik <david.nalesnik@gmail.com>
Date: Sat, 26 May 2012 18:41:20 +0000 (-0500)
Subject: Add \shape function to LilyPond
X-Git-Tag: release/2.15.40-1~9
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=8ffeb1bd519d051394624b6b24503c7082893808;p=lilypond.git

Add \shape function to LilyPond

\shape allows bezier curves to be modified
by altering their control points.
---

diff --git a/input/regression/shape-other-curves.ly b/input/regression/shape-other-curves.ly
new file mode 100644
index 0000000000..68d9820e24
--- /dev/null
+++ b/input/regression/shape-other-curves.ly
@@ -0,0 +1,46 @@
+\version "2.15.39"
+
+\header {
+  texidoc = "In addition to @code{Slur}, the music function @code{\\shape} works
+with @code{PhrasingSlur}, @code{Tie}, @code{LaissezVibrerTie}, and @code{RepeatTie}.
+Each is shown below, first unmodified and then (in blue) after application of the
+function."
+}
+
+\layout {
+  indent = 0
+  ragged-right = ##t
+}
+
+\relative c'' {
+  % PhrasingSlur
+  d4\( d' b g g,8 f' e d c2\)
+  \override PhrasingSlur #'color = #blue
+  \shape PhrasingSlur #'((0 . -2) (-1 . 3.5) (0.5 . 0.5) (0 . -2.5))
+  d4\( d' b g g,8 f' e d c2\)
+  \break
+
+  % Tie
+  cis1~
+  \break
+  cis
+  \override Tie #'color = #blue
+  \shape Tie #'(() ((0 . -0.9) (0 . -0.5) (0 . -0.5) (0 . -0.9)))
+  cis~
+  \break
+  cis
+  \break
+
+  % LaissezVibrerTie
+  c\laissezVibrer
+  \override LaissezVibrerTie #'color = #blue
+  \shape LaissezVibrerTie #'((0 . 0) (0.5 . 0.2) (1.5 . 0.2) (2 . 0))
+  c\laissezVibrer
+  \break
+
+  % RepeatTie
+  c\repeatTie
+  \override RepeatTie #'color = #blue
+  \shape RepeatTie #'((-1 . 0) (-0.7 . 0) (-0.3 . 0) (0 . 0))
+  c\repeatTie
+}
diff --git a/input/regression/shape-slurs.ly b/input/regression/shape-slurs.ly
new file mode 100644
index 0000000000..c9cd97a876
--- /dev/null
+++ b/input/regression/shape-slurs.ly
@@ -0,0 +1,34 @@
+\version "2.15.39"
+
+\header {
+  texidoc = "The control points of a broken or unbroken slur may be offset by
+@code{\\shape}.  The blue slurs are modified from the default slurs shown first."
+}
+
+\layout {
+  indent = 0
+  ragged-right = ##t
+}
+
+% unmodified
+\relative c'' {
+  d4( d' b g
+  g,8 f' e d c2)
+  d4( d' b g
+  \break
+  g,8 f' e d c2)
+}
+
+% modified
+\relative c'' {
+  \override Slur #'color = #blue
+  \shape Slur #'((0 . -2) (-1 . 3.5) (0.5 . 0.5) (0 . -2.5))
+  d4( d' b g g,8  f' e d c2)
+  \shape Slur #'(
+   ((0 . -2.5) (0 . 1.5) (0 . 1) (0 . -0.5))
+   ((1 . 2.5) (0 . 1.5) (0 . 1) (0 . 0))
+  )
+  d4( d' b g
+  \break
+  g,8 f' e d c2)
+}
diff --git a/ly/music-functions-init.ly b/ly/music-functions-init.ly
index 21f6c51fd7..f8274cfbc4 100644
--- a/ly/music-functions-init.ly
+++ b/ly/music-functions-init.ly
@@ -1035,6 +1035,48 @@ a context modification duplicating their effect.")
      (musicop music)
      mods))
 
+shape =
+#(define-music-function (parser location grob offsets)
+   (string? list?)
+   (_i "Offset control-points of @var{grob} by @var{offsets}.  The argument
+is a list of number pairs or list of such lists.  Each element of a pair
+represents an offset to one of the coordinates of a control-point.")
+   (define ((shape-curve offsets) grob)
+     (let* ((orig (ly:grob-original grob))
+            (siblings (if (ly:spanner? grob)
+                          (ly:spanner-broken-into orig) '()))
+            (total-found (length siblings))
+            (function (assoc-get 'control-points
+                                 (reverse (ly:grob-basic-properties grob))))
+            (coords (function grob)))
+
+       (define (offset-control-points offsets)
+         (if (null? offsets)
+             coords
+             (map
+               (lambda (x y) (coord-translate x y))
+               coords offsets)))
+
+       (define (helper sibs offs)
+         (if (pair? offs)
+             (if (eq? (car sibs) grob)
+                 (offset-control-points (car offs))
+                 (helper (cdr sibs) (cdr offs)))
+             coords))
+
+       ;; we work with lists of lists
+       (if (or (null? offsets)
+               (not (list? (car offsets))))
+           (set! offsets (list offsets)))
+
+       (if (>= total-found 2)
+           (helper siblings offsets)
+           (offset-control-points (car offsets)))))
+
+   #{
+     \once \override $grob #'control-points = #(shape-curve offsets)
+   #})
+
 shiftDurations =
 #(define-music-function (parser location dur dots arg)
    (integer? integer? ly:music?)