\version "2.24.0"

%% ──────────────────────────────────────────────────────────────────
%% soft-justify.ily
%% Justified paragraph with explicit soft hyphens (\-).
%%
%% Usage:
%%   \markup \soft-justify #58 #"LilyPond came about when two..."
%%
%% The number is the line width in staff spaces (same unit as the
%% built-in \justify uses).  Soft-hyphen positions are marked with
%% the two-character sequence backslash-hyphen (\-) in the string.
%% Hard hyphens (plain -) are kept as-is and are NOT break points.
%% ──────────────────────────────────────────────────────────────────

#(use-modules (ice-9 regex)
              (srfi srfi-1))

%% ── 1. String utilities ──────────────────────────────────────────

%% Split STR into a list of substrings at every occurrence of DELIM
%% (a plain string, not a regex).
#(define (string-split-on str delim)
   (let* ((dl (string-length delim))
          (sl (string-length str)))
     (let loop ((start 0) (acc '()))
       (let ((pos (string-contains str delim start)))
         (if pos
             (loop (+ pos dl)
                   (cons (substring str start pos) acc))
             (reverse (cons (substring str start sl) acc)))))))

%% ── 2b. Heuristic English auto-hyphenator ────────────────────────
%%
%% Applies simple prefix/suffix rules to inject \- markers.
%% Rules are tried in order; the FIRST matching rule wins for each
%% end of the word, so put more-specific patterns before less-specific
%% ones.  A word must be at least MIN-WORD-LENGTH characters long to
%% be eligible for hyphenation at all.
%%
%% Each rule is:  (type  pattern  break-offset)
%%
%%   type = 'suffix  → match at the END of the word
%%   type = 'prefix  → match at the START of the word
%%
%%   break-offset (for suffixes) = how many chars from the LEFT of the
%%   pattern to place the break.  E.g. pattern "tion", offset 0 means
%%   the break goes BEFORE "tion": root\-tion.
%%   Positive offset moves the break rightward into the suffix.
%%
%%   break-offset (for prefixes) = length of the prefix itself,
%%   so the break goes after the prefix: pre\-fix.
%%
%% Multiple rules can fire on the same word (one suffix + one prefix),
%% giving two break points.  Only one suffix rule and one prefix rule
%% fire per word (first match wins in each category).

#(define min-hyphen-word-length 6)

#(define hyphen-rules
   ;;  type      pattern      break-offset
   '(
     ;; ── Suffixes (ordered: longer / more-specific first) ──────────
     ;; Verb / gerund / participial
     (suffix  "inging"     0)   ;; singing → sing\-ing? no — handled below
     (suffix  "ating"      0)   ;; creating → creat\-ing (caught by -ing below)
     (suffix  "inging"     0)
     ;; The big three endings
     (suffix  "tion"       0)   ;; na\-tion, ac\-tion
     (suffix  "sion"       0)   ;; vi\-sion
     (suffix  "cion"       0)   ;; sus\-pi\-cion
     ;; -ing: only break before it if ≥2 chars remain before it
     (suffix  "ming"       0)   ;; swim\-ming
     (suffix  "ning"       0)   ;; run\-ning
     (suffix  "ring"       0)   ;; stir\-ring
     (suffix  "ling"       0)   ;; call\-ing
     (suffix  "ting"       0)   ;; writ\-ing
     (suffix  "ding"       0)   ;; read\-ing
     (suffix  "king"       0)   ;; work\-ing
     (suffix  "sing"       0)   ;; clos\-ing
     (suffix  "ving"       0)   ;; giv\-ing
     (suffix  "ing"        0)   ;; general -ing catch-all
     ;; Past tense / adjective
     (suffix  "tted"       0)   ;; permitted → permit\-ted
     (suffix  "nned"       0)   ;; planned → plan\-ned
     (suffix  "lled"       0)   ;; filled → fill\-ed (2-char break)
     (suffix  "rred"       0)   ;; occurred → occur\-red
     (suffix  "ssed"       0)   ;;ressed → re\-ssed
     (suffix  "ched"       0)   ;; reached
     (suffix  "shed"       0)   ;; finished
     (suffix  "ged"        0)   ;; managed
     (suffix  "ned"        0)   ;; opened
     (suffix  "led"        0)   ;; compiled
     (suffix  "red"        0)   ;; rendered
     (suffix  "ted"        0)   ;; wanted
     (suffix  "sed"        0)   ;; used
     (suffix  "ed"         0)   ;; general -ed
     ;; Noun / adjective suffixes
     (suffix  "ment"       0)   ;; move\-ment
     (suffix  "ness"       0)   ;; kind\-ness
     (suffix  "ance"       0)   ;; bal\-ance
     (suffix  "ence"       0)   ;; pres\-ence
     (suffix  "ible"       0)   ;; pos\-si\-ble (catches the -ible)
     (suffix  "able"       0)   ;; read\-able
     (suffix  "ful"        0)   ;; care\-ful
     (suffix  "less"       0)   ;; care\-less
     (suffix  "ness"       0)
     (suffix  "ward"       0)   ;; for\-ward
     (suffix  "wards"      0)
     (suffix  "ly"         0)   ;; quick\-ly
     (suffix  "al"         0)   ;; musi\-cal
     (suffix  "ous"        0)   ;; fa\-mous
     (suffix  "ive"        0)   ;; act\-ive
     (suffix  "ure"        0)   ;; pres\-sure (only helps if stem is long)
     (suffix  "er"         0)   ;; play\-er
     (suffix  "ers"         0)   ;; play\-ers
     (suffix  "est"        0)   ;; quick\-est
     (suffix  "ry"         0)   ;; bak\-ery (long words only)

     ;; ── Prefixes ──────────────────────────────────────────────────
     ;; break-offset = length of the prefix (break goes after it)
     (prefix  "under"      5)   ;; un\-der\-stand
     (prefix  "over"       4)   ;; o\-ver\-ture
     (prefix  "inter"      5)   ;; in\-ter\-act
     (prefix  "super"      5)   ;; su\-per\-man
     (prefix  "trans"      5)   ;; trans\-late
     (prefix  "extra"      5)   ;; ex\-tra
     (prefix  "micro"      5)
     (prefix  "macro"      5)
     (prefix  "anti"       4)   ;; an\-ti
     (prefix  "auto"       4)
     (prefix  "semi"       4)
     (prefix  "post"       4)
     (prefix  "pre"        3)   ;; pre\-pare
     (prefix  "pro"        3)   ;; pro\-gram
     (prefix  "dis"        3)   ;; dis\-play
     (prefix  "mis"        3)   ;; mis\-take
     (prefix  "sub"        3)   ;; sub\-ject
     (prefix  "out"        3)   ;; out\-put
     (prefix  "com"        3)   ;; com\-pute
     (prefix  "con"        3)   ;; con\-sole
     (prefix  "per"        3)   ;; per\-form
     (prefix  "re"         2)   ;; re\-turn
     (prefix  "de"         2)   ;; de\-sign
     (prefix  "un"         2)   ;; un\-lock
     (prefix  "ex"         2)   ;; ex\-port
     (prefix  "in"         2)   ;; in\-put
     ))

%% Strip any trailing punctuation from a word before pattern matching,
%% then reattach it to the final syllable.
#(define punct-chars (string->list ".,;:!?\"')]}"))

#(define (strip-trailing-punct w)
   (let loop ((i (1- (string-length w))) (trail ""))
     (if (or (< i 0)
             (not (member (string-ref w i) punct-chars)))
         (cons (substring w 0 (1+ i)) trail)
         (loop (1- i)
               (string (string-ref w i))))))   % only last punct char kept

%% Find the first matching suffix rule for word W (lowercase).
%% Returns (break-position . #f) or #f.
#(define (find-suffix-break w)
   (let ((wl (string-length w)))
     (let loop ((rules hyphen-rules))
       (if (null? rules)
           #f
           (let* ((rule    (car rules))
                  (type    (car rule))
                  (pattern (cadr rule))
                  (offset  (caddr rule))
                  (pl      (string-length pattern)))
             (if (and (eq? type 'suffix)
                      (>= wl (+ pl 2))           ;; ≥2 chars must remain before suffix
                      (string-suffix? pattern w))
                 (let ((break-pos (+ (- wl pl) offset)))
                   (if (and (>= break-pos 2)     ;; don't break in first 2 chars
                            (<= break-pos (- wl 2))) ;; or last 2 chars
                       (cons break-pos #f)
                       (loop (cdr rules))))
                 (loop (cdr rules))))))))

%% Find the first matching prefix rule for word W (lowercase).
%% Returns (break-position . #f) or #f.
#(define (find-prefix-break w)
   (let ((wl (string-length w)))
     (let loop ((rules hyphen-rules))
       (if (null? rules)
           #f
           (let* ((rule    (car rules))
                  (type    (car rule))
                  (pattern (cadr rule))
                  (offset  (caddr rule)))
             (if (and (eq? type 'prefix)
                      (string-prefix? pattern w)
                      (>= (- wl offset) 3))      ;; ≥3 chars must follow prefix
                 (if (and (>= offset 2)
                          (<= offset (- wl 2)))
                     (cons offset #f)
                     (loop (cdr rules)))
                 (loop (cdr rules))))))))

%% Insert a \- marker into string W at position POS.
#(define (insert-soft-hyphen w pos)
   (string-append (substring w 0 pos) "\\-" (substring w pos)))

%% Auto-hyphenate a single word (no punctuation, already lowercased for
%% pattern matching, but we apply breaks to the original-case version).
#(define (auto-hyphenate-word w)
   (if (< (string-length w) min-hyphen-word-length)
       w
       (let* ((wl    (string-length w))
              (wlow  (string-downcase w))
              (pfx   (find-prefix-break wlow))
              (sfx   (find-suffix-break wlow))
              ;; We may get both a prefix break and a suffix break.
              ;; Only use both if they don't overlap (gap ≥ 2 chars).
              (use-pfx (and pfx (or (not sfx)
                                    (>= (- (car sfx) (car pfx)) 2))))
              (use-sfx sfx))
         (cond
           ((and use-pfx use-sfx)
            ;; Insert suffix break first (higher index), then prefix break,
            ;; so the prefix index remains valid.
            (let* ((w1 (insert-soft-hyphen w (car sfx)))
                   (w2 (insert-soft-hyphen w1 (car pfx))))
              w2))
           (use-sfx
            (insert-soft-hyphen w (car sfx)))
           (use-pfx
            (insert-soft-hyphen w (car pfx)))
           (else w)))))

%% ── 2. Tokeniser (updated to include auto-hyphenation) ───────────
%%
%% Words that already contain an explicit \- are left untouched.
%% Everything else is passed through the auto-hyphenator.

#(define (tokenise-paragraph str)
   (let* ((raw-words (string-tokenize str))
          (tokens
           (map (lambda (w)
                  ;; If the user already put in explicit \-, respect it.
                  (let* ((explicit? (string-contains w "\\-"))
                         (w-hyph   (if explicit? w (auto-hyphenate-word w)))
                         (parts    (string-split-on w-hyph "\\-")))
                    (if (null? (cdr parts))
                        w-hyph     ;; no break points → plain string
                        parts)))   ;; has break points → list of syllables
                raw-words)))
     tokens))

%% ── 3. Stencil helpers ───────────────────────────────────────────

#(define (stencil-width s)
   (interval-length (ly:stencil-extent s X)))

#(define (word-stencil layout props str)
   (interpret-markup layout props (markup str)))

#(define (hyphen-stencil layout props)
   (word-stencil layout props "-"))

%% Measure the rendered width of a token (without any hyphen).
%% For a list token, that means joining all syllables.
#(define (token-full-width layout props tok)
   (let* ((s (if (string? tok)
                 tok
                 (string-join tok ""))))
     (stencil-width (word-stencil layout props s))))

%% ── 4. Line breaker ──────────────────────────────────────────────
%%
%% Returns a list of "line specs".  Each line spec is a list of
%% "placed tokens": (stencil . is-last-on-line?).
%%
%% We use a simple greedy approach.  At each word, if it fits on the
%% current line, add it.  If not:
%%   a) if the word is hyphenable, try every split point from the
%%      rightmost to the leftmost.  Use the first split that fits.
%%   b) otherwise, start a new line.
%%
%% Each "line" is represented as a list of rendered-word stencils,
%% plus an optional trailing hyphen stencil on the last piece of a
%% broken word.

#(define (break-into-lines layout props tokens line-width word-space)
   (let* ((sp        word-space)
          (hyph-stil (hyphen-stencil layout props))
          (hyph-w    (stencil-width hyph-stil)))

     ;; tok-stencils: cache rendered stencils per token index
     ;; We render the full word for each token (used for measuring).

     ;; Main loop
     (let loop ((toks    tokens)
                (cur-w   0)       ; current line's used width (incl. spaces)
                (cur-line '())    ; list of stencils on the current line (reversed)
                (lines   '()))    ; finished lines (reversed), each is list of stils

       (if (null? toks)
           ;; flush the last (non-justified) line
           (reverse (cons (reverse cur-line) lines))

           (let* ((tok    (car toks))
                  (rest   (cdr toks))
                  (is-hyp (pair? tok))   ; hyphenable token?
                  (full-s (if is-hyp (string-join tok "") tok))
                  (full-w (stencil-width (word-stencil layout props full-s)))
                  ;; width including leading space (unless first word on line)
                  (needed (if (null? cur-line) full-w (+ sp full-w))))

             (cond
               ;; ── Case A: word fits on the current line ──
               ((or (null? cur-line)
                    (<= (+ cur-w needed) line-width))
                (loop rest
                      (+ cur-w needed)
                      (cons (word-stencil layout props full-s) cur-line)
                      lines))

               ;; ── Case B: doesn't fit; try hyphenating ──
               (is-hyp
                (let try-splits ((n-left (1- (length tok))))
                  ;; n-left = number of syllables on this line (try from max to 1)
                  (if (= n-left 0)
                      ;; No split works → push current line, start new with full word
                      (loop toks 0 '() (cons (reverse cur-line) lines))
                      (let* ((left-syls  (list-head tok n-left))
                             (right-syls (list-tail tok n-left))
                             (left-s     (string-join left-syls ""))
                             (right-s    (string-join right-syls ""))
                             (left-w     (stencil-width
                                          (word-stencil layout props left-s)))
                             (needed-left (if (null? cur-line)
                                             (+ left-w hyph-w)
                                             (+ sp left-w hyph-w))))
                        (if (<= (+ cur-w needed-left) line-width)
                            ;; This split fits!  Close line with "left-" then
                            ;; start next line with "right..." (a new plain token
                            ;; or the remaining syllables).
                            (let* ((left-stil
                                    (ly:stencil-add
                                     (word-stencil layout props left-s)
                                     (ly:stencil-translate-axis
                                      hyph-stil left-w X)))
                                   ;; remaining syllables become a new token
                                   (right-tok (if (= (length right-syls) 1)
                                                  (car right-syls)
                                                  right-syls))
                                   (closed-line
                                    (reverse (cons left-stil cur-line))))
                              (loop (cons right-tok rest)
                                    0 '()
                                    (cons closed-line lines)))
                            ;; Doesn't fit; try one fewer syllable on this line
                            (try-splits (1- n-left)))))))

               ;; ── Case C: doesn't fit, not hyphenable → new line ──
               (else
                (loop toks 0 '() (cons (reverse cur-line) lines)))))))))

%% ── 5. Line renderer ─────────────────────────────────────────────
%%
%% Render a list of word-stencils into one justified line stencil.
%% last-line? → left-align instead of stretching.

#(define (render-line word-stils line-width word-space last-line?)
   (if (null? word-stils)
       point-stencil
       (let* ((n       (length word-stils))
              (total-w (apply + (map stencil-width word-stils)))
              (n-gaps  (max 0 (1- n)))
              (gap     (if (or last-line? (= n-gaps 0))
                           word-space
                           (/ (- line-width total-w) n-gaps))))
         (let place ((stils word-stils) (x 0) (result point-stencil))
           (if (null? stils)
               result
               (let* ((s  (car stils))
                      (sw (stencil-width s))
                      (p  (ly:stencil-translate-axis s x X)))
                 (place (cdr stils)
                        (+ x sw gap)
                        (ly:stencil-add result p))))))))

%% ── 6. The markup command ────────────────────────────────────────

#(define-markup-command (soft-justify layout props lw text)
   (number? string?)
   #:properties ((word-space   0.6)
                 (baseline-skip 3.0))
   "Justify TEXT (a string) to line width LW (in staff spaces).
Use \\- in the string to mark optional hyphenation points.
Hard hyphens (-) are left untouched."
   (let* ((tokens  (tokenise-paragraph text))
          (lines   (break-into-lines layout props tokens lw word-space))
          (n-lines (length lines)))
     ;; Stack lines vertically
     (let stack ((ls    lines)
                 (idx   0)
                 (y     0)
                 (result point-stencil))
       (if (null? ls)
           result
           (let* ((last?  (= (1+ idx) n-lines))
                  (lstil  (render-line (car ls) lw word-space last?))
                  (placed (ly:stencil-translate-axis lstil (- y) Y)))
             (stack (cdr ls)
                    (1+ idx)
                    (+ y baseline-skip)
                    (ly:stencil-add result placed)))))))

myParagraph = #"LilyPond came about when two musicians wanted to go
beyond the soulless look of computer-printed sheet music.
Musicians prefer reading beautiful music, so
why couldn’t programmers write software
to produce elegant printed parts?
The result is a program that creates beautiful sheet music
following the best traditions of classical music engraving.
The best thing about LilyPond is that it handles all layout
programmatically, allowing composers, transcribers
and publishers to focus on the music instead of
improving their software’s default output."

myParagraphSoft = #"LilyPond came about when two musicians wanted to go
be\\-yond the soulless look of computer-printed sheet music.
Musicians prefer reading beautiful music, so
why couldn’t pro\\-grammers write software
to produce elegant printed parts?
The result is a program that creates beautiful sheet music
following the best traditions of classical music en\\-graving.
The best thing about LilyPond is that it handles all layout
programmatically, allowing composers, transcribers
and publishers to focus on the music instead of
improving their software’s default output."

\markup \bold "Line width 92:"
\markup \vspace #1
\markup \bold "Default justification:"
\markup \vspace #0.5
\markup \override #'(line-width . 92) \justify-string #myParagraph
\markup \vspace #1
\markup \bold "Soft justification:"
\markup \vspace #0.5
\markup \soft-justify #92 #myParagraphSoft

\markup \vspace #3
\markup \bold "Line width 60:"
\markup \vspace #1
\markup \bold "Default justification:"
\markup \vspace #0.5
\markup \override #'(line-width . 60) \justify-string #myParagraph
\markup \vspace #1
\markup \bold "Soft justification:"
\markup \vspace #0.5
\markup \soft-justify #60 #myParagraphSoft