lib/60-libtext.scm

   1 ;------------------------------------------------------------------;\r
   2 ; opus_libre -- 60-libtext.scm                                     ;\r
   3 ;                                                                  ;\r
   4 ; (c) 2008-2010 Valentin Villenave <valentin@villenave.net>        ;\r
   5 ;                                                                  ;\r
   6 ;     opus_libre is a free framework for GNU LilyPond: you may     ;\r
   7 ; redistribute it and/or modify it under the terms of the GNU      ;\r
   8 ; General Public License, version 3 or later: gnu.org/licenses     ;\r
   9 ;                                                                  ;\r
  10 ;------------------------------------------------------------------;\r
  11 \r
  12 ; Text functions.\r
  13 \r
  14 \r
  15 ;; Charset definitions (completing standard guile defs)\r
  16 \r
  17 (define-public (char-punctuation? ch)\r
  18   (char-set-contains? char-set:punctuation ch))\r
  19 \r
  20 (define-public char-set:dynamics\r
  21   (char-set #\f #\m #\p #\r #\s #\z))\r
  22 \r
  23 \r
  24 ;; smallCaps helper -- This code was provided by Nicolas Sceaux.\r
  25 ;; an accented character is seen as two characters by guile\r
  26 \r
  27 (define-public string-upper-case #f)\r
  28 (define accented-char-upper-case? #f)\r
  29 (define accented-char-lower-case? #f)\r
  30 \r
  31 (let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")\r
  32       (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))\r
  33  (define (group-by-2 chars result)\r
  34   (if (or (null? chars) (null? (cdr chars)))\r
  35    (reverse! result)\r
  36    (group-by-2 (cddr chars)\r
  37     (cons (string (car chars) (cadr chars))\r
  38      result))))\r
  39  (let ((lower-case-accented-chars\r
  40         (group-by-2 (string->list lower-case-accented-string) (list)))\r
  41        (upper-case-accented-chars\r
  42         (group-by-2 (string->list upper-case-accented-string) (list))))\r
  43   (set! string-upper-case\r
  44    (lambda (str)\r
  45     (define (replace-chars str froms tos)\r
  46      (if (null? froms)\r
  47       str\r
  48       (replace-chars (regexp-substitute/global #f (car froms) str\r
  49                       'pre (car tos) 'post)\r
  50        (cdr froms)\r
  51        (cdr tos))))\r
  52     (string-upcase (replace-chars str\r
  53                     lower-case-accented-chars\r
  54                     upper-case-accented-chars))))\r
  55   (set! accented-char-upper-case?\r
  56    (lambda (char1 char2)\r
  57     (member (string char1 char2) upper-case-accented-chars string=?)))\r
  58   (set! accented-char-lower-case?\r
  59    (lambda (char1 char2)\r
  60     (member (string char1 char2) lower-case-accented-chars string=?)))))\r
  61 \r
  62 (define (string-list->markup strings lower)\r
  63   (let ((final-string (string-upper-case\r
  64                        (apply string-append (reverse strings)))))\r
  65    (if lower\r
  66     (markup #:fontsize -2 final-string)\r
  67     final-string)))\r
  68 \r
  69 (define (make-small-caps rest-chars currents current-is-lower prev-result)\r
  70   (if (null? rest-chars)\r
  71    (make-concat-markup (reverse! (cons (string-list->markup\r
  72                                         currents current-is-lower)\r
  73                                   prev-result)))\r
  74    (let* ((ch1 (car rest-chars))\r
  75           (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))\r
  76           (this-char-string (string ch1))\r
  77           (is-lower (char-lower-case? ch1))\r
  78           (next-rest-chars (cdr rest-chars)))\r
  79     (cond ((and ch2 (accented-char-lower-case? ch1 ch2))\r
  80            (set! this-char-string (string ch1 ch2))\r
  81            (set! is-lower #t)\r
  82            (set! next-rest-chars (cddr rest-chars)))\r
  83      ((and ch2 (accented-char-upper-case? ch1 ch2))\r
  84       (set! this-char-string (string ch1 ch2))\r
  85       (set! is-lower #f)\r
  86       (set! next-rest-chars (cddr rest-chars))))\r
  87     (if (or (and current-is-lower is-lower)\r
  88          (and (not current-is-lower) (not is-lower)))\r
  89      (make-small-caps next-rest-chars\r
  90       (cons this-char-string currents)\r
  91       is-lower\r
  92       prev-result)\r
  93      (make-small-caps next-rest-chars\r
  94       (list this-char-string)\r
  95       is-lower\r
  96       (if (null? currents)\r
  97        prev-result\r
  98        (cons (string-list->markup\r
  99               currents current-is-lower)\r
 100         prev-result)))))))\r
 101 \r
 102 \r
 103 \r
 104 ;; rounded-whiteout: this allows us to override\r
 105 ;; the standard whiteout markup definition.\r
 106 \r
 107 (define-public (rounded-whiteout-stencil stencil blot)\r
 108   (let*\r
 109       ((x-ext (ly:stencil-extent stencil X))\r
 110        (y-ext (ly:stencil-extent stencil Y)))\r
 111     (ly:stencil-add\r
 112      (stencil-with-color (ly:round-filled-box x-ext y-ext blot)\r
 113        white)\r
 114      stencil)))\r