lib/libtext.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- libtext.scm                                        ;
   3 ;                                                                  ;
   4 ; (c) 2008-2011 Valentin Villenave <valentin@villenave.net>        ;
   5 ;                                                                  ;
   6 ;     opus_libre is a free framework for GNU LilyPond: you may     ;
   7 ; redistribute it and/or modify it under the terms of the GNU      ;
   8 ; General Public License as published by the Free Software         ;
   9 ; Foundation, either version 3 of the License, or (at your option) ;
  10 ; any later version.                                               ;
  11 ;     This program is distributed WITHOUT ANY WARRANTY; without    ;
  12 ; even the implied warranty of MERCHANTABILITY or FITNESS FOR A    ;
  13 ; PARTICULAR PURPOSE.  You should have received a copy of the GNU  ;
  14 ; General Public License along with this program (typically in the ;
  15 ; share/doc/ directory).  If not, see http://www.gnu.org/licenses/ ;
  16 ;                                                                  ;
  17 ;------------------------------------------------------------------;
  18
  19
  20 ; Text functions.
  21
  22
  23 ;; Charset definitions (completing standard guile defs)
  24
  25 (define-public (char-punctuation? ch)
  26   (char-set-contains? char-set:punctuation ch))
  27
  28 (define-public char-set:dynamics
  29   (char-set #\f #\m #\p #\r #\s #\z))
  30
  31 ;; overriding the standard whiteout markup definition
  32 ;; allows us to add an optional radius argument.
  33
  34 (define-public (stencil-whiteout stencil . rad)
  35   (let*
  36       ((x-ext (ly:stencil-extent stencil X))
  37        (y-ext (ly:stencil-extent stencil Y))
  38        (def (ly:parser-lookup parser 'conf:rounded-whiteout))
  39        (radius (if (number? def) def 0))
  40        (blot (if (list? rad) (car rad) radius)))
  41     (ly:stencil-add
  42      (stencil-with-color (ly:round-filled-box x-ext y-ext blot)
  43                          white)
  44      stencil)))
  45
  46 (define (make-text-span str)
  47 "Make a TextSpanner that begins with the given STR."
  48   (let* ((m (make-music 'TextSpanEvent
  49              'span-direction -1))
  50          (details (assoc-get 'bound-details
  51                    (assoc-get 'TextSpanner
  52                     all-grob-descriptions)))
  53          (left-details (assoc-get 'left
  54                         details)))
  55    (ly:music-set-property! m 'tweaks
  56     (acons 'bound-details
  57      (acons 'left
  58       (acons 'text str
  59        left-details)
  60       details)
  61      (ly:music-property m 'tweaks)))
  62    m))
  63
  64 ;; Untainted text (lyrics)
  65 (define-public (untaint-string str wordlist)
  66   "Replace all words in STR with harmless
  67 words randomly taken from WORDLIST."
  68   (*untainted* #t)
  69   (regexp-substitute/global #f "[\\#a-zA-Z'’]+" str
  70        'pre
  71        (lambda (x)
  72             (let* ((word (match:substring x))
  73                    (prior (match:prefix x))
  74                    (rand (list-ref wordlist
  75                            (random (length wordlist))))
  76                    (result (if (or (string-prefix? "\\" word)
  77                                    (string-prefix? "#" word))
  78                                word
  79                                rand)))
  80               (if (string-match
  81 "[\\](set|unset|override|revert|tweak) \
  82 ([A-Z][a-z]+[.])?\
  83 ([A-Za-z]+[.])?\
  84 ([a-z]+[-])?$"
  85                    prior)
  86                   word
  87                   (if (string-any char-set:upper-case
  88                         (string-take word 1))
  89                       (string-capitalize result)
  90                       result))))
  91        'post))
  92
  93 (define-public (untaint-this expr)
  94  "Take EXPR, a variable containing a
  95 \\lyricmode expression and replace it with a
  96 similar, untainted expression."
  97   (let* ((tainted-string (music->lily-string expr parser))
  98          (untainted-string
  99           (untaint-string tainted-string lang:word-list)))
 100     (ly:debug-message
 101      "Untainted expression translated into:\n ~a" untainted-string)
 102     (ly:parser-include-string parser untainted-string)))
 103
 104 (define-public (is-this-tainted? name)
 105   (let ((cmd-arg (ly:get-option 'untainted)))
 106     (if cmd-arg
 107         (if (boolean? cmd-arg)
 108             #t
 109             (if (symbol? cmd-arg)
 110                 (let* ((str-arg (symbol->string cmd-arg))
 111                        (ls-arg (string-split str-arg #\+)))
 112                   (if (member name ls-arg)
 113                       #t
 114                       #f))
 115                 #f))
 116         #f)))