From a0163f6b9e33e304d6f8a2c196c873d880c37d1f Mon Sep 17 00:00:00 2001
From: Valentin Villenave <valentin@villenave.net>
Date: Sun, 22 Dec 2013 00:33:13 +0100
Subject: [PATCH] New feature: untainted text

This new feature allows to easily replace textual elements
(typically lyrics) with random, harmless words.  It may
be activated at complation time through a command-line
option (-duntainted) that optionally accepts a string
to specify _which_ score, or even which part, must
be treated.  In case of multiple scores, their
names must be separated with "+" chars.
---
 bin/text.scm                   |  4 ++++
 etc/locale/fr.conf             |  3 +++
 etc/ly.conf.d/lang.conf        |  4 ++++
 lib/40-loadmacros.scm          |  1 -
 lib/80-buildskel.scm           | 27 ++++++++++++++++-----
 lib/90-makescore.scm           |  5 +++-
 lib/include.ly                 |  1 +
 lib/init.scm                   |  4 +++-
 lib/libtext.scm                | 54 ++++++++++++++++++++++++++++++++++++++++++
 share/themes/default/paper.ily |  6 +++++
 10 files changed, 100 insertions(+), 9 deletions(-)

diff --git a/bin/text.scm b/bin/text.scm
index aa9f7a8..7a44712 100644
--- a/bin/text.scm
+++ b/bin/text.scm
@@ -172,3 +172,7 @@
          \once \override Fingering #'X-extent = #'(-2.0 . 0.0)
          $(add-bracket current-staff-position #f text music)
          $music #})))
+
+(define untaint
+   (define-music-function (parser location expr) (ly:music?)
+     #{ $(untaint-this expr) #}))
diff --git a/etc/locale/fr.conf b/etc/locale/fr.conf
index cbeacea..7ecf91e 100644
--- a/etc/locale/fr.conf
+++ b/etc/locale/fr.conf
@@ -24,6 +24,7 @@ instr-suffix = "Instr"
 short-instr-suffix = "ShortInstr"
 lyrics-suffix = "Texte"
 timeline-suffix = "Mesures"
+author-suffix = "Auteur"
 
 numbers = '("un" "deux" "trois" "quatre" "cinq" "six" "sept" "huit")
 
@@ -40,3 +41,5 @@ tuplet-letter-quad = "tttt"
 upper-hand = "md"
 lower-hand = "mg"
 
+word-list = '("pa" "ta" "touille")
+untaint-disclaimer = "d’après"
diff --git a/etc/ly.conf.d/lang.conf b/etc/ly.conf.d/lang.conf
index bd1cd47..3354ac2 100644
--- a/etc/ly.conf.d/lang.conf
+++ b/etc/ly.conf.d/lang.conf
@@ -23,6 +23,7 @@ short-instr-suffix = "ShortInstr"
 lyrics-suffix = "Words"
 dynamics-suffix = "Dynamics"
 timeline-suffix = "Bars"
+author-suffix = "Author"
 
 numbers = '("one" "two" "three" "four" "five" "six" "seven" "eight")
 
@@ -39,3 +40,6 @@ tuplet-letter-quad = "tttt"
 upper-hand = "rh"
 lower-hand = "lh"
 both = "both"
+
+word-list = '("foo" "bar" "baz")
+untaint-disclaimer = "after"
diff --git a/lib/40-loadmacros.scm b/lib/40-loadmacros.scm
index 6ac44df..bb0179d 100644
--- a/lib/40-loadmacros.scm
+++ b/lib/40-loadmacros.scm
@@ -24,7 +24,6 @@
 		  token)))
     `(define-public ,sym ,funct)))
 
-
 (defmacro staff-change-command (token)
   (let* ((str (primitive-eval token))
          (sym (if (defined-string? token)
diff --git a/lib/80-buildskel.scm b/lib/80-buildskel.scm
index 3556e75..2a9e54e 100644
--- a/lib/80-buildskel.scm
+++ b/lib/80-buildskel.scm
@@ -21,6 +21,7 @@
 (scm-load "libtext.scm")
 
 (define *has-timeline* (make-parameter #f))
+(define *untainted* (make-parameter #f))
 
 (define (assoc-name alist name)
   "If NAME begins with a lower case letter, then
@@ -39,13 +40,19 @@ try to find a matching entry in ALIST."
         (begin (ly:debug-message "Variable ~a doesn't exist." name)
                (make-music 'Music 'void #t)))))
 
-(define (make-this-text name suffix)
+(define (make-this-text name suffix . disclaimer)
   "Associate NAME with SUFFIX, and check if a suitable
 markup exists."
   (let ((mark (ly:parser-lookup parser
                                 (string->symbol
                                  (string-append name suffix)))))
-    (if (markup? mark) mark
+    (if (markup? mark)
+        (if (and (not-null? disclaimer) (*untainted*))
+            (markup
+             #:concat ("(" (car disclaimer))
+            ; #:hspace 1
+             #:concat (mark ".)"))
+            mark)
         (begin
           (ly:debug-message "No text found in ~a~a" name suffix)
           (if (ly:get-option 'use-variable-names)
@@ -148,7 +155,9 @@ exists with that name.  If so, parse it."
 ;; Create Lyrics contexts accordingly."
   (define-music-function (parser location name) (string?)
     (let* ((name (assoc-name lang:instruments name))
-           (current-name (string-append (*current-part*) name)))
+           (current-name (string-append (*current-part*) name))
+           (tainted? (or (is-this-tainted? (*current-part*))
+                         (is-this-tainted? current-name))))
       #{
         $(let* ((musiclist (list #{ {} #}))
                 (numlist (if (ly:get-option 'only-suffixed-varnames)
@@ -157,10 +166,16 @@ exists with that name.  If so, parse it."
           (map (lambda (x)
                   (let* ((lyr-name (string-append current-name lang:lyrics-suffix
                                                   (string-capitalize x)))
-                        (lyrics (ly:parser-lookup parser (string->symbol lyr-name))))
+                         (lyrics (ly:parser-lookup parser (string->symbol lyr-name))))
                     (if (ly:music? lyrics)
-                        (append! musiclist (list
-                                            #{ \new Lyrics \lyricsto $name $lyrics #})))))
+                        (append! musiclist
+                          (list
+                           #{
+                             \new Lyrics \lyricsto $name
+                               $(if tainted?
+                                    (untaint-this lyrics)
+                                    lyrics)
+                           #})))))
                 numlist)
           (make-simultaneous-music musiclist))
       #})))
diff --git a/lib/90-makescore.scm b/lib/90-makescore.scm
index 3fa8a8e..fb3e201 100644
--- a/lib/90-makescore.scm
+++ b/lib/90-makescore.scm
@@ -127,9 +127,11 @@ current-part music."
                       (local-layout (make-this-layout part lang:layout))
                       (layout $defaultlayout)
                       (header (make-module))
-                      (title (make-this-text part lang:title-suffix)))
+                      (title (make-this-text part lang:title-suffix))
+                      (author (make-this-text part lang:author-suffix lang:untaint-disclaimer)))
 
                  (module-define! header 'piece title)
+                 (module-define! header 'author author)
                  (ly:score-set-header! score header)
                  (ly:score-add-output-def! score (if local-layout local-layout layout))
                  (if (*pagebreak-before*) (add-music parser pagebreak))
@@ -138,6 +140,7 @@ current-part music."
                  (*has-timeline* #f)
                  (*pagebreak-before* #f)
                  (*pagebreak-after* #f)
+                 (*untainted* #f)
                  output-redirect))))
 
            struct)
diff --git a/lib/include.ly b/lib/include.ly
index 316ac7a..de59b4a 100644
--- a/lib/include.ly
+++ b/lib/include.ly
@@ -26,6 +26,7 @@
 %#(ly:set-option 'allow-suffixless-varnames #t)
 %#(ly:set-option 'no-auto-piano-dynamics#t)
 %#(ly:set-option 'git-branch-as-score-name #t)
+%#(ly:set-option 'untainted #t)
 
 %%%%%%%%%%%%%%%%%%%%%%%%%% Base includes %%%%%%%%%%%%%%%%%%%%%%%%%%%
 
diff --git a/lib/init.scm b/lib/init.scm
index f3c236b..d6f80a5 100644
--- a/lib/init.scm
+++ b/lib/init.scm
@@ -29,7 +29,9 @@
  ; command pipe
  (ice-9 popen)
  ; parameters
- (srfi srfi-39))
+ (srfi srfi-39)
+ ; *->lily-string
+ (scm display-lily))
 
 (define-public (not-null? x) (not (null? x)))
 (define-public (false-or-null? x) (or (not x) (null? x)))
diff --git a/lib/libtext.scm b/lib/libtext.scm
index bdd519c..c07015e 100644
--- a/lib/libtext.scm
+++ b/lib/libtext.scm
@@ -60,3 +60,57 @@
       details)
      (ly:music-property m 'tweaks)))
    m))
+
+;; Untainted text (lyrics)
+(define-public (untaint-string str wordlist)
+  "Replace all words in STR with harmless
+words randomly taken from WORDLIST."
+  (*untainted* #t)
+  (regexp-substitute/global #f "[\\#a-zA-Z'’]+" str
+       'pre
+       (lambda (x)
+            (let* ((word (match:substring x))
+                   (prior (match:prefix x))
+                   (rand (list-ref wordlist
+                           (random (length wordlist))))
+                   (result (if (or (string-prefix? "\\" word)
+                                   (string-prefix? "#" word))
+                               word
+                               rand)))
+              (if (string-match
+"[\\](set|unset|override|revert|tweak) \
+([A-Z][a-z]+[.])?\
+([A-Za-z]+[.])?\
+([a-z]+[-])?$"
+                   prior)
+                  (set! result word))
+              (if (string-any char-set:upper-case
+                    (string-take word 1))
+                  (string-capitalize result)
+                  result)))
+       'post))
+
+(define-public (untaint-this expr)
+ "Take EXPR, a variable containing a
+\\lyricmode expression and replace it with a
+similar, untainted expression."
+  (let* ((tainted-string (music->lily-string expr parser))
+         (untainted-string
+          (untaint-string tainted-string lang:word-list)))
+    (ly:debug-message
+     "Untainted expression translated into:\n ~a" untainted-string)
+    (ly:parser-include-string parser untainted-string)))
+
+(define-public (is-this-tainted? name)
+  (let ((cmd-arg (ly:get-option 'untainted)))
+    (if cmd-arg
+        (if (boolean? cmd-arg)
+            #t
+            (if (symbol? cmd-arg)
+                (let* ((str-arg (symbol->string cmd-arg))
+                       (ls-arg (string-split str-arg #\+)))
+                  (if (member name ls-arg)
+                      #t
+                      #f))
+                #f))
+        #f)))
diff --git a/share/themes/default/paper.ily b/share/themes/default/paper.ily
index b350edc..6d9bc6d 100644
--- a/share/themes/default/paper.ily
+++ b/share/themes/default/paper.ily
@@ -74,12 +74,18 @@
 
   scoreTitleMarkup = \markup {
     \column {
+      \vspace #2
       \on-the-fly #print-all-headers { \bookTitleMarkup \hspace #1 }
       \fill-line {
         \huge \bold % default was regular size and weight
         \fromproperty #'header:piece
     %      \fromproperty #'paper:papersizename
       }
+      \vspace #1
+      \fill-line {
+        \fromproperty #'header:instrument
+        \fromproperty #'header:author
+      }
     }
   }
 
-- 
2.11.4.GIT