\version "2.14.2"

% -> http://www.lilypondforum.de/index.php?topic=1152.msg6323#msg6323

#(define (utf-8-string->wide-char-list str)
  "Convert a UTF-8 byte string into an list with integer representing the UNICODE character codes"
  (let
   ((erg '())
    (len (string-length str))
    (mult 1)
    (sum 0))
   (do ((ct (- len 1) (1- ct))) ((< ct 0)) ; process backward
    (let ((numeric (char->integer (string-ref str ct))))
     (if (< numeric #x80)
      (begin ; 7-Bit-ASCII stand alone character
       (if (not (equal? mult 1)) (begin
         (ly:warning "utf-8-string->wide-char-list: UTF-8-string out of sequence!")
         (set! mult 1) (set! sum 0)))
       (set! erg (cons numeric erg)))
      (if (< numeric #xc0)
       (begin ; 10. ..... = UTF-8 expansion byte
        (set! sum (+ sum (* mult (- numeric #x80))))
        (set! mult (* 64 mult)))
       (if (< numeric #xe0)
        (begin ; 110. .... = UTF-8 start of two byte sequence
         (if (not (equal? mult 64))
          (ly:warning "utf-8-string->wide-char-list: UTF-8-string out of sequence!")
          (begin
           (set! sum (+ sum (* mult (- numeric #xc0))))
           (set! erg (cons sum erg))))
         (set! mult 1) (set! sum 0))
        (if (< numeric #xf0)
         (begin ; 1110 .... = UTF-8 start of three byte sequence
          (if (not (equal? mult 4096))
           (ly:warning "utf-8-string->wide-char-list: UTF-8-string out of sequence!")
           (begin
            (set! sum (+ sum (* mult (- numeric #xe0))))
            (set! erg (cons sum erg))))
          (set! mult 1) (set! sum 0))
         (if (< numeric #xf8)
          (begin ; 1111 0... = UTF-8 start of four byte sequence
           (if (not (equal? mult 262144))
            (ly:warning "utf-8-string->wide-char-list: UTF-8-string out of sequence!")
            (begin
             (set! sum (+ sum (* mult (- numeric #xf0))))
             (set! erg (cons sum erg))))
           (set! mult 1) (set! sum 0))
          (begin ; This would be the header of a UTF-8 encoding of an UNICODE character
                 ; with more than 21 bits - this does not exist!
           (ly:warning "utf-8-string->wide-char-list: UTF-8-string out of sequence!")
           (set! mult 1) (set! sum 0)))))))))
   erg))

#(define unicode-diacritics ; these are the UNICODE ranges of the diacritical symbols, which
                            ; should not be insulated form their predestinating glyph.
  '(                        ; this list (ascending order) tends to be incomplete
   ( #x0300 . #x036f )
   ( #x0483 . #x0489 )
   ( #x20d0 . #x20ff )
 ))

#(define (int-in-regions num reglist)
  (if (not (pair? reglist)) #f
   (if (not (pair? (car reglist))) #f
    (if (< num (caar reglist)) #f
     (if (<= num (cdar reglist)) #t
      (int-in-regions num (cdr reglist)))))))

#(define (wide-char-diacritic? codepoint)
 ; does this UNICODE codepoint refer to a diacrity modifyer?
  (int-in-regions codepoint unicode-diacritics))


#(define (wide-char-list->utf-8-glyphlist wcl)
 ; convert a list of UNICODE codepoint integers
 ; into a list of one character UTF-8 strings,
 ; but do not separate the combining diacritical modifyers
 ; (append them to the character strings)
  (let ((erg '()) (add-to-current #f))
   (for-each (lambda (u)
     (let ((us (if (eq? u 0) "\0" (ly:wide-char->utf-8 u))))
      (if add-to-current
       (set-car! erg (string-append us (car erg)))
       (set! erg (cons us erg)))
      (set! add-to-current (wide-char-diacritic? u)))) 
    (reverse wcl))
   erg))

#(define (wide-char-list->utf-8 wcl)
 ; Helper function to define utf-8 strings with a few special characters in it
  (let ((erg ""))
   (for-each (lambda (x)
     (if (string? x)
      (set! erg (string-append erg x))
      (if (integer? x)
       (if (eq? x 0)
        (set! erg (string-append erg "\0"))
        (set! erg (string-append erg (ly:wide-char->utf-8 x))))
       (if (list? x)
        (set! erg (string-append erg (wide-char-list->utf-8 x)))))))
    wcl)
   erg))

#(define (string->string-list strg)
  (wide-char-list->utf-8-glyphlist (utf-8-string->wide-char-list strg)))
  
#(define (string-list->string lst)
  (wide-char-list->utf-8 lst))

#(define (proc l1 l2)
    "
    l1 is supposed to be a list of strings.
    proc will return a new list l2, build of the 
    elements of l1.
    Every string of l2 a one character-string
    e.g '("12" "34") -> '("1" "2" "3" "4")
    "
  (if (null? l1)
     l2
     (begin
       (set! l2 (append l2 (string->string-list (car l1))))
       (proc (cdr l1) l2))))
       
#(define (stack-chars stencil stils kern)
  (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT (car stils) kern))
   (if (null? (cdr stils))
     stencil
     (stack-chars stencil (cdr stils) kern)))
         
#(define-markup-command (char-space layout props nmbr args)(number? markup-list?)
#:properties ((word-space 0.6) (word-space-left #f) (word-space-right #f))
  (let* ((args-rev (remove (lambda (x) (string=? "" x)) args))
         (new-args (list-join args-rev " "))
         (argls (proc new-args '()))
         (pos-nmbr (max nmbr 0.0)) ; 'nmbr' limited to be not below 0.0
         (stils (map (lambda (x)(interpret-markup layout props x)) argls))
         (first-stil (if (eq? argls '()) point-stencil (car stils))))

 (ly:stencil-combine-at-edge  
   (ly:stencil-combine-at-edge
      (ly:make-stencil "" (cons 0 (abs (* pos-nmbr 3 (if (number? word-space-left) word-space-left word-space)))) (cons 0 0))
         X RIGHT
         (if (<= (length argls) 1)
           first-stil
           (stack-chars first-stil (cdr stils) nmbr))
         0)
           X RIGHT
            (ly:make-stencil "" (cons 0 (abs (* pos-nmbr 3 (if (number? word-space-right) word-space-right word-space)))) (cons 0 0))
            0)))
            
% testing functions
  
#(define strg "asdäöüព្រះជាម្ចាស់")
     
#(let* ((l1 (utf-8-string->wide-char-list strg))
        (l2 (wide-char-list->utf-8-glyphlist l1))
        (new-strg (wide-char-list->utf-8 l1))
        (strg? (string? new-strg)))
  (newline)
  (newline)(display "\"The string\"__")(display strg)
  (newline)(display "\"List of integers, \n  representing the UNICODE character codes\"__")(display l1)
  (newline)(display "\"List of one character UTF-8 strings\"__")(display l2)
  (newline)(display "\"Back to string\"__")(display new-strg)
  (newline)(display "\"string?\"__")(display strg?))
  
#(let* ((strg-lst (string->string-list strg))
        (new-strg (string-list->string strg-lst))
        (strg? (string? new-strg)))
     (newline)
     (newline)(display "\"The string\"__")(display strg)
     (newline)(display "\"The string-list\"__")(display strg-lst)
     (newline)(display "\"Back to string\"__")(display new-strg)
     (newline)(display "\"string?\"__")(display strg?)
     (newline))
  
%------------ test
     
\markup \column {
        "Tests for paranoiacs"
        \char-space #0.5 {  }
        xy
        \char-space #0.5 { "" }
        xy
        \override #'(word-space-left . 0)
        \char-space #0.5 { a "" a }
        xy
        \char-space #0.5 { "" "" }
        \override #'(word-space-left . 0)
        \char-space #0.5 { "" a "" }
        xy
        \override #'(word-space-left . 0)
        \char-space #0.5 { a }
        xy
        \override #'(word-space-left . 0)
        \char-space #0.8 { "់" }
        xy
        \override #'(word-space-left . 0)
        \char-space #0.8 { "asdäöüព្រះជាម្ចាស់" }
        \vspace #3
}
   
\markup \override #'(line-width . 90)
\wordwrap {
    Der Zwischenraum
    \override #'(word-space-left . 2.5) \char-space #0.5 { links }
    und
    \override #'(word-space-right . 2.5) \char-space #0.5 { rechts }
    des gesperrten Textes kann individuell skaliert werden,
    aber natürlich auch
    \override #'(word-space . 2.5) \char-space #0.5 { beide }
    Seiten gemeinsam.
    Dies kann vor allem dann nötig werden, wenn
    \override #'(word-space-right . 0.0) \char-space #0.35 { unterschiedlich }
    \char-space #0.85 { gesperrte }
    Texte direkt aufeinander folgen.
    
    It is possible to 
    \char-space #-0.25 { compress }
    the text, too.
}