lib/libtext.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- libtext.scm                                        ;
   3 ;                                                                  ;
   4 ; (c) 2008-2010 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
  32 ;; smallCaps helper -- This code was provided by Nicolas Sceaux.
  33 ;; an accented character is seen as two characters by guile
  34
  35 (define-public string-upper-case #f)
  36 (define accented-char-upper-case? #f)
  37 (define accented-char-lower-case? #f)
  38
  39 (let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
  40       (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
  41   (define (group-by-2 chars result)
  42     (if (or (null? chars) (null? (cdr chars)))
  43         (reverse! result)
  44         (group-by-2 (cddr chars)
  45                     (cons (string (car chars) (cadr chars))
  46                           result))))
  47   (let ((lower-case-accented-chars
  48          (group-by-2 (string->list lower-case-accented-string) (list)))
  49         (upper-case-accented-chars
  50          (group-by-2 (string->list upper-case-accented-string) (list))))
  51     (set! string-upper-case
  52           (lambda (str)
  53             (define (replace-chars str froms tos)
  54               (if (null? froms)
  55                   str
  56                   (replace-chars (regexp-substitute/global #f (car froms) str
  57                                                            'pre (car tos) 'post)
  58                                  (cdr froms)
  59                                  (cdr tos))))
  60             (string-upcase (replace-chars str
  61                                           lower-case-accented-chars
  62                                           upper-case-accented-chars))))
  63     (set! accented-char-upper-case?
  64           (lambda (char1 char2)
  65             (member (string char1 char2) upper-case-accented-chars string=?)))
  66     (set! accented-char-lower-case?
  67           (lambda (char1 char2)
  68             (member (string char1 char2) lower-case-accented-chars string=?)))))
  69
  70 (define (string-list->markup strings lower)
  71   (let ((final-string (string-upper-case
  72                        (apply string-append (reverse strings)))))
  73     (if lower
  74         (markup #:fontsize -2 final-string)
  75         final-string)))
  76
  77 (define (make-small-caps rest-chars currents current-is-lower prev-result)
  78   (if (null? rest-chars)
  79       (make-concat-markup (reverse! (cons (string-list->markup
  80                                            currents current-is-lower)
  81                                           prev-result)))
  82       (let* ((ch1 (car rest-chars))
  83              (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
  84              (this-char-string (string ch1))
  85              (is-lower (char-lower-case? ch1))
  86              (next-rest-chars (cdr rest-chars)))
  87         (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
  88                (set! this-char-string (string ch1 ch2))
  89                (set! is-lower #t)
  90                (set! next-rest-chars (cddr rest-chars)))
  91               ((and ch2 (accented-char-upper-case? ch1 ch2))
  92                (set! this-char-string (string ch1 ch2))
  93                (set! is-lower #f)
  94                (set! next-rest-chars (cddr rest-chars))))
  95         (if (or (and current-is-lower is-lower)
  96                 (and (not current-is-lower) (not is-lower)))
  97             (make-small-caps next-rest-chars
  98                              (cons this-char-string currents)
  99                              is-lower
 100                              prev-result)
 101             (make-small-caps next-rest-chars
 102                              (list this-char-string)
 103                              is-lower
 104                              (if (null? currents)
 105                                  prev-result
 106                                  (cons (string-list->markup
 107                                         currents current-is-lower)
 108                                        prev-result)))))))
 109
 110
 111
 112 ;; overriding the standard whiteout markup definition
 113 ;; allows us to add an optional radius argument.
 114
 115 (define-public (stencil-whiteout stencil . rad)
 116   (let*
 117       ((x-ext (ly:stencil-extent stencil X))
 118        (y-ext (ly:stencil-extent stencil Y))
 119        (def (ly:parser-lookup parser 'conf:rounded-whiteout))
 120        (radius (if (number? def) def 0))
 121        (blot (if (list? rad) (car rad) radius)))
 122     (ly:stencil-add
 123      (stencil-with-color (ly:round-filled-box x-ext y-ext blot)
 124                          white)
 125      stencil)))
 126
 127
 128 (define (make-text-span str)
 129 "Make a TextSpanner that begins with the given STR."
 130   (let* ((m (make-music 'TextSpanEvent
 131              'span-direction -1))
 132          (details (assoc-get 'bound-details
 133                    (assoc-get 'TextSpanner
 134                     all-grob-descriptions)))
 135          (left-details (assoc-get 'left
 136                         details)))
 137    (ly:music-set-property! m 'tweaks
 138     (acons 'bound-details
 139      (acons 'left
 140       (acons 'text str
 141        left-details)
 142       details)
 143      (ly:music-property m 'tweaks)))
 144    m))