LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/lilypond/2.24.1/scm/lily/page.scm

@@ -0,0 +1,321 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2006--2022 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (lily page))
+
+(use-modules (lily)
+             (lily paper-system)
+             (srfi srfi-1))
+
+
+(define (annotate? layout)
+  (eq? #t (ly:output-def-lookup layout 'annotate-spacing)))
+
+(define-public (make-page paper-book page-number is-bookpart-last-page)
+  "A page is a prob (Property object). This is because the non-music
+layout elements (title, header, footer) are markups and must be interpreted in context
+of layout settings just like markups inside the music."
+  ;; FIXME: the page breaker sometimes passes page-number as 0.  Is
+  ;; that expected?
+  (let* ((paper (ly:paper-book-paper paper-book))
+         (page (ly:make-prob
+                'page
+                (layout->page-init paper)
+                'paper-book paper-book
+                'page-number page-number
+                'is-last-bookpart (ly:output-def-lookup paper 'is-last-bookpart)
+                'is-bookpart-last-page is-bookpart-last-page))
+         (header-proc (ly:output-def-lookup paper 'make-header))
+         (head-stencil (if (procedure? header-proc)
+                           (header-proc page)
+                           empty-stencil))
+         (footer-proc (ly:output-def-lookup paper 'make-footer))
+         (foot-stencil (if (procedure? footer-proc)
+                           (footer-proc page)
+                           empty-stencil)))
+    (page-set-property! page 'head-stencil head-stencil)
+    (page-set-property! page 'foot-stencil foot-stencil)
+    page))
+
+(define-public page-property ly:prob-property)
+(define-public page-set-property! ly:prob-set-property!)
+
+(define (page-translate-systems page)
+  (for-each
+
+   (lambda (sys off)
+     (if (not (number? (ly:prob-property sys 'Y-offset)))
+         (ly:prob-set-property! sys 'Y-offset off)))
+
+   (page-property page 'lines)
+   (page-property page 'configuration)))
+
+(define (annotate-top-space first-system layout header-stencil stencil)
+  "Add an annotation at the top to STENCIL and return new stencil."
+  (let* ((top-margin (ly:output-def-lookup layout 'top-margin))
+         (sym (if (paper-system-title? first-system)
+                  'top-markup-spacing
+                  'top-system-spacing))
+         (spacing-spec (ly:output-def-lookup layout sym))
+         (X-offset (ly:prob-property first-system 'X-offset 5))
+         (header-extent (ly:stencil-extent header-stencil Y)))
+
+    (set! stencil
+          (ly:stencil-add stencil
+                          (ly:stencil-translate-axis
+                           (annotate-spacing-spec layout
+                                                  (symbol->string sym)
+                                                  spacing-spec
+                                                  (- top-margin)
+                                                  (car header-extent)
+                                                  #:base-color red)
+                           X-offset X)))
+    stencil))
+
+
+(define (annotate-page layout stencil)
+  "add annotations to a stencil, and return result"
+  (let ((top-margin (ly:output-def-lookup layout 'top-margin))
+        (paper-height (ly:output-def-lookup layout 'paper-height))
+        (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
+        (add-stencil (lambda (y)
+                       (set! stencil
+                             (ly:stencil-add stencil
+                                             (ly:stencil-translate-axis y 6 X))))))
+    (add-stencil
+     (ly:stencil-translate-axis
+      (annotate-y-interval layout "paper-height"
+                           (cons (- paper-height) 0)
+                           #t)
+      1 X))
+    (add-stencil
+     (ly:stencil-translate-axis
+      (annotate-y-interval layout "top-margin"
+                           (cons (- top-margin) 0)
+                           #t)
+      2 X))
+    (add-stencil
+     (ly:stencil-translate-axis
+      (annotate-y-interval layout "bottom-margin"
+                           (cons (- paper-height) (- bottom-margin paper-height))
+                           #t)
+      2 X))
+    stencil))
+
+(define (annotate-space-left page)
+  (let*
+      ((paper-book (page-property page 'paper-book))
+       (layout (ly:paper-book-paper paper-book))
+       (arrow (annotate-y-interval layout
+                                   "space left"
+                                   (cons (- 0.0
+                                            (page-property page 'bottom-edge)
+                                            (let ((foot (page-property page 'foot-stencil)))
+                                              (if (and (ly:stencil? foot)
+                                                       (not (ly:stencil-empty? foot)))
+                                                  (car (ly:stencil-extent foot Y))
+                                                  0.0)))
+                                         (page-property page  'bottom-system-edge))
+                                   #t)))
+
+    (set! arrow (ly:stencil-translate-axis arrow 8 X))
+
+    arrow))
+
+(define-public (layout->page-init layout)
+  "Alist of settings for page layout"
+  (let*
+      ((paper-height (ly:output-def-lookup layout 'paper-height))
+       (paper-width (ly:output-def-lookup layout 'paper-width))
+       (left-margin (ly:output-def-lookup layout 'left-margin))
+       (right-margin (ly:output-def-lookup layout 'right-margin))
+       (bottom-edge (- paper-height
+                       (ly:output-def-lookup layout 'bottom-margin)) )
+       (top-margin (ly:output-def-lookup layout 'top-margin))
+       )
+
+    `((paper-height . ,paper-height)
+      (paper-width . ,paper-width)
+      (left-margin . ,left-margin)
+      (right-margin . ,right-margin)
+      (top-margin . ,top-margin)
+      (bottom-edge . ,bottom-edge)
+      )))
+
+(define (make-page-stencil page)
+  "Construct a stencil representing the page from PAGE."
+
+  (page-translate-systems page)
+  (let*
+      ((paper-book (page-property page 'paper-book))
+       (prop (lambda (sym) (page-property page sym)))
+       (layout (ly:paper-book-paper paper-book))
+       (lines (page-property page 'lines))
+       (number (page-property page 'page-number))
+
+       ;; TODO: naming paper-height/paper-width not analogous to TeX.
+
+       (system-xoffset (ly:output-def-lookup layout 'horizontal-shift 0.0))
+       (system-separator-markup (ly:output-def-lookup layout 'system-separator-markup))
+       (system-separator-stencil (if (markup? system-separator-markup)
+                                     (interpret-markup layout
+                                                       (layout-extract-page-properties layout)
+                                                       system-separator-markup)
+                                     #f))
+
+       (page-stencil empty-stencil)
+
+       (last-system #f)
+       (last-y 0.0)
+       (add-to-page (lambda (stencil x y)
+                      (set! page-stencil
+                            (ly:stencil-add page-stencil
+                                            (ly:stencil-translate stencil
+                                                                  (cons
+                                                                   (+ system-xoffset x)
+                                                                   (- 0 y (prop 'top-margin)))
+
+                                                                  )))))
+       (add-system
+        (lambda (system)
+          (let* ((stencil (paper-system-stencil system))
+                 (extra-offset (ly:prob-property system 'extra-offset '(0 . 0)))
+                 (x (+ (ly:prob-property system 'X-offset 0.0)
+                       (car extra-offset)))
+                 (y (+ (ly:prob-property system 'Y-offset 0.0)
+                       (cdr extra-offset)))
+                 (is-title (paper-system-title?
+                            system)))
+            (add-to-page stencil x y)
+            (if (and (ly:stencil? system-separator-stencil)
+                     last-system
+                     (not (paper-system-title? system))
+                     (not (paper-system-title? last-system)))
+                (add-to-page
+                 system-separator-stencil
+                 0
+                 (average (- last-y
+                             (car (paper-system-staff-extents last-system)))
+                          (- y
+                             (cdr (paper-system-staff-extents system))))))
+            (set! last-system system)
+            (set! last-y y))))
+       (head (prop 'head-stencil))
+       (foot (prop 'foot-stencil))
+       )
+
+    (if (and
+         (ly:stencil? head)
+         (not (ly:stencil-empty? head)))
+        (begin
+          ;; Ensure that the top of the header just touches the top margin.
+          (set! head (ly:stencil-translate-axis head
+                                                (- 0 (cdr (ly:stencil-extent head Y)) (prop 'top-margin)) Y))
+          (set! page-stencil (ly:stencil-add page-stencil head))))
+
+    (if (and
+         (annotate? layout)
+         (pair? lines))
+
+        (begin
+          (set! page-stencil (annotate-top-space (car lines) layout head page-stencil))
+
+          (for-each (lambda (sys next-sys)
+                      (paper-system-annotate sys next-sys layout))
+                    lines
+                    (append (cdr lines) (list #f)))
+          (paper-system-annotate-last (car (last-pair lines)) layout)))
+
+    (for-each add-system lines)
+
+
+    (ly:prob-set-property! page 'bottom-system-edge
+                           (car (ly:stencil-extent page-stencil Y)))
+    (ly:prob-set-property! page 'space-left
+                           (+ (prop 'bottom-edge)
+                              (prop 'bottom-system-edge)
+                              (if (and (ly:stencil? foot)
+                                       (not (ly:stencil-empty? foot)))
+                                  (car (ly:stencil-extent foot Y))
+                                  0.0)))
+
+    (if (annotate? layout)
+        (set! page-stencil
+              (ly:stencil-add page-stencil
+                              (annotate-space-left page))))
+
+    (if (and (ly:stencil? foot)
+             (not (ly:stencil-empty? foot)))
+        (set! page-stencil
+              (ly:stencil-add
+               page-stencil
+               (ly:stencil-translate
+                foot
+                (cons 0
+                      (+ (- (prop 'bottom-edge))
+                         (- (car (ly:stencil-extent foot Y)))))))))
+
+    (if (ly:output-def-lookup layout 'two-sided #f)
+        (set! page-stencil
+              (ly:stencil-translate page-stencil
+                                    (cons (prop (if (even? number)
+                                                    'left-margin
+                                                    'right-margin))
+                                          0)))
+        (set! page-stencil
+              (ly:stencil-translate page-stencil (cons (prop 'left-margin) 0))))
+
+    ;; annotation.
+    (if (annotate? layout)
+        (set! page-stencil (annotate-page layout page-stencil)))
+
+    (if (ly:get-option 'use-paper-size-for-page)
+        (set! page-stencil (ly:make-stencil
+                            (ly:stencil-expr page-stencil)
+                            (cons 0 (ly:output-def-lookup layout 'paper-width))
+                            (cons (- (ly:output-def-lookup layout 'paper-height)) 0))
+              ))
+    page-stencil))
+
+(define-public (page-stencil page)
+  (if (not (ly:stencil? (page-property page 'stencil)))
+
+      ;; todo: make tweakable.
+      ;; via property + callbacks.
+
+      (page-set-property! page 'stencil (make-page-stencil page)))
+  (page-property page 'stencil))
+
+(define-public (calc-printable-height page)
+  "Printable area for music and titles."
+  (let*
+      ((paper-book (page-property page 'paper-book))
+       (layout (ly:paper-book-paper paper-book))
+       (h (- (ly:output-def-lookup layout 'paper-height)
+             (ly:output-def-lookup layout 'top-margin)
+             (ly:output-def-lookup layout 'bottom-margin)))
+
+       (head (page-property page 'head-stencil))
+       (foot (page-property page 'foot-stencil))
+       (available
+        (- h (if (ly:stencil? head)
+                 (interval-length (ly:stencil-extent head Y))
+                 0)
+           (if (ly:stencil? foot)
+               (interval-length (ly:stencil-extent foot Y))
+               0))))
+    available))

data/share/lilypond/2.24.1/scm/lily/paper-system.scm

@@ -0,0 +1,271 @@
+;;;; This file is part of LilyPond, the GNU music typesetter.
+;;;;
+;;;; Copyright (C) 2006--2022 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;;
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (lily paper-system))
+
+(use-modules (lily)
+             (srfi srfi-1)
+             (ice-9 optargs))
+
+(define-public (paper-system-title? system)
+  (equal? #t (ly:prob-property system 'is-title)
+          ))
+
+(define (system-stencil system-grob main-stencil)
+  (let* ((padding (ly:grob-property system-grob 'in-note-padding #f))
+         (in-notes (if padding (ly:grob-property system-grob 'in-note-stencil) empty-stencil))
+         (in-notes (if in-notes in-notes empty-stencil))
+         (direction (if padding (ly:grob-property system-grob 'in-note-direction) UP)))
+    (if padding
+        (ly:stencil-combine-at-edge main-stencil Y direction in-notes padding)
+        main-stencil)))
+
+(define-public (paper-system-stencil system)
+  "Add stencils for notes to the main stencil, returning the result."
+  (let ((main-stencil (ly:prob-property system 'stencil))
+        (system-grob (ly:prob-property system 'system-grob)))
+    (if (ly:grob? system-grob)
+        (system-stencil system-grob main-stencil)
+        main-stencil)))
+
+(define-public (paper-system-layout system)
+  (let*
+      ((g (paper-system-system-grob system)))
+
+    (if (ly:grob? g)
+        (ly:grob-layout  g)
+        #f)))
+
+(define-public (paper-system-system-grob paper-system)
+  (ly:prob-property paper-system 'system-grob))
+
+(define-public (paper-system-extent system axis)
+  (ly:stencil-extent (paper-system-stencil system) axis))
+
+(define-public (paper-system-staff-extents ps)
+  (ly:prob-property ps 'staff-refpoint-extent '(0 . 0)))
+
+(define-public (paper-system-annotate-last system layout)
+  (let*
+      ((bottomspace (ly:prob-property system 'bottom-space))
+       (y-extent (paper-system-extent system Y))
+       (x-extent (paper-system-extent system X))
+       (stencil (ly:prob-property system 'stencil))
+
+       (arrow (if (number? bottomspace)
+                  (annotate-y-interval layout
+                                       "bottom-space"
+                                       (cons (- (car y-extent) bottomspace)
+                                             (car y-extent))
+                                       #t)
+                  #f)))
+
+    (if arrow
+        (set! stencil
+              (ly:stencil-add stencil arrow)))
+
+    (set! (ly:prob-property system 'stencil)
+          stencil)
+    ))
+
+
+(define*-public (annotate-padding system-Y system-X Y-ext X-ext
+                                  next-system-Y next-system-X next-Y-ext next-X-ext
+                                  layout horizon-padding padding #:key (base-color blue))
+  "Y-ext and next-Y-ext are either skyline-pairs or extents."
+  (let* ((eps 0.001)
+         (skyline (and (ly:skyline-pair? Y-ext)
+                       (car Y-ext)))
+         (next-skyline (and (ly:skyline-pair? next-Y-ext)
+                            (cdr next-Y-ext)))
+         (annotation-X (cond
+                        ((and skyline next-skyline)
+                         (-
+                          (ly:skyline-touching-point skyline next-skyline horizon-padding)
+                          horizon-padding))
+                        (skyline
+                         (ly:skyline-max-height-position skyline))
+                        (next-skyline
+                         (ly:skyline-max-height-position next-skyline))
+                        (else
+                         (max (cdr X-ext)
+                              (cdr next-X-ext)))))
+         (annotation-Y (if skyline
+                           (ly:skyline-height skyline annotation-X)
+                           (car Y-ext)))
+         (next-annotation-Y (if next-skyline
+                                (- (+ (ly:skyline-height next-skyline
+                                                         (- (+ annotation-X system-X)
+                                                            next-system-X))
+                                      next-system-Y)
+                                   system-Y)
+                                (cdr next-Y-ext)))
+         (padding-blocks (>= next-annotation-Y (- annotation-Y padding eps)))
+         (contrast-color (append (cdr base-color) (list (car base-color))))
+         (color (if padding-blocks contrast-color base-color))
+         (annotation (ly:stencil-translate-axis
+                      (annotate-y-interval
+                       layout
+                       "padding"
+                       `(,(- annotation-Y padding). ,annotation-Y)
+                       #t
+                       #:color color)
+                      annotation-X X)))
+    (if (> padding 0.0)
+        annotation
+        empty-stencil)))
+
+
+(define-public (paper-system-annotate system next-system layout)
+  "Add arrows and texts to indicate which lengths are set."
+
+  (let* ((grob (ly:prob-property system 'system-grob))
+         (paper-height (ly:output-def-lookup layout 'paper-height))
+         (bottom-margin (ly:output-def-lookup layout 'bottom-margin))
+         (top-margin (ly:output-def-lookup layout 'top-margin))
+         (spaceable-staves (if (ly:grob? grob) (ly:system::get-spaceable-staves grob) '()))
+         (all-staves (if (ly:grob? grob) (ly:system::get-staves grob) '()))
+         (spaceable-staff-annotate
+          (lambda (before-staff after-staff)
+            (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
+                  (after-Y (ly:grob-relative-coordinate after-staff grob Y)))
+              (annotate-spacing-spec
+               layout
+               ;; FIXME: Improve `ly:get-spacing-spec' to return the
+               ;; name of the used `XXX-XXX-spacing' property, if
+               ;; possible.  Right now we have to use the empty
+               ;; string.
+               ""
+               (ly:get-spacing-spec before-staff after-staff)
+               before-Y
+               after-Y))))
+
+         (staff-padding-annotate
+          (lambda (before-staff after-staff)
+            (let ((before-Y (ly:grob-relative-coordinate before-staff grob Y))
+                  (before-X (ly:grob-relative-coordinate before-staff grob X))
+                  (before-X-ext (ly:grob-extent before-staff before-staff X))
+                  (after-Y (ly:grob-relative-coordinate after-staff grob Y))
+                  (after-X (ly:grob-relative-coordinate after-staff grob X))
+                  (after-X-ext (ly:grob-extent after-staff after-staff X))
+                  (skylines (ly:grob-property before-staff 'vertical-skylines))
+                  (after-skylines (ly:grob-property after-staff 'vertical-skylines))
+                  (padding (assoc-get 'padding
+                                      (ly:get-spacing-spec before-staff after-staff)
+                                      0.0))
+                  (horizon-padding (ly:grob-property before-staff
+                                                     'skyline-horizontal-padding
+                                                     0.0)))
+              (ly:stencil-translate
+               (annotate-padding
+                before-Y before-X skylines before-X-ext
+                after-Y after-X after-skylines after-X-ext
+                layout horizon-padding padding)
+               (cons before-X before-Y)))))
+
+         (staff-annotations (if (< 1 (length spaceable-staves))
+                                (map spaceable-staff-annotate
+                                     (drop-right spaceable-staves 1)
+                                     (drop spaceable-staves 1))
+                                '()))
+         (staff-padding-annotations (if (< 1 (length all-staves))
+                                        (map staff-padding-annotate
+                                             (drop-right all-staves 1)
+                                             (drop all-staves 1))
+                                        '()))
+         (estimate-extent (if (ly:grob? grob)
+                              (annotate-y-interval layout
+                                                   "extent-estimate"
+                                                   (ly:grob-property grob 'pure-Y-extent)
+                                                   #f)
+                              #f))
+
+         (spacing-spec-sym (cond ((and next-system
+                                       (paper-system-title? system)
+                                       (paper-system-title? next-system))
+                                  'markup-markup-spacing)
+                                 ((paper-system-title? system)
+                                  'markup-system-spacing)
+                                 ((and next-system
+                                       (paper-system-title? next-system))
+                                  'score-markup-spacing)
+                                 ((not next-system)
+                                  'last-bottom-spacing)
+                                 ((ly:prob-property system 'last-in-score #f)
+                                  'score-system-spacing)
+                                 (else
+                                  'system-system-spacing)))
+         (spacing-spec (ly:output-def-lookup layout spacing-spec-sym))
+         (last-staff-Y (car (paper-system-staff-extents system)))
+         (system-Y (ly:prob-property system 'Y-offset 0.0))
+         (system-X (ly:prob-property system 'X-offset 0.0))
+         (next-system-Y (and next-system
+                             (ly:prob-property next-system 'Y-offset 0.0)))
+         (next-system-X (and next-system
+                             (ly:prob-property next-system 'X-offset 0.0)))
+         (first-staff-next-system-Y (if next-system
+                                        (- (+ (cdr (paper-system-staff-extents next-system))
+                                              system-Y)
+                                           next-system-Y)
+                                        (+ system-Y top-margin bottom-margin (- paper-height))))
+
+         (skyline (or
+                   (ly:prob-property system 'vertical-skylines #f)
+                   (paper-system-extent system Y)))
+         (next-skyline (and next-system
+                            (or
+                             (ly:prob-property next-system 'vertical-skylines #f)
+                             (paper-system-extent next-system Y))))
+         (horizon-padding (and
+                           (ly:grob? grob)
+                           (ly:grob-property grob 'skyline-horizontal-padding 0)))
+         (padding-annotation (if (skyline-pair-and-non-empty? next-system)
+                                 (annotate-padding
+                                  (- system-Y) system-X skyline (paper-system-extent system X)
+                                  (- next-system-Y) next-system-X next-skyline (paper-system-extent next-system X)
+                                  layout
+                                  horizon-padding
+                                  (assoc-get 'padding spacing-spec 0.0)
+                                  #:base-color blue)
+                                 empty-stencil))
+
+         (system-annotation (annotate-spacing-spec
+                             layout
+                             (symbol->string spacing-spec-sym)
+                             spacing-spec
+                             last-staff-Y
+                             first-staff-next-system-Y))
+         (annotations (ly:stencil-add
+                       padding-annotation
+                       (stack-stencils Y DOWN 0.0 staff-padding-annotations)
+                       (stack-stencils Y DOWN 0.0 (append staff-annotations (list system-annotation))))))
+
+    (if estimate-extent
+        (set! annotations
+              (stack-stencils X RIGHT 5.5
+                              (list annotations
+                                    estimate-extent))))
+
+    (if (not (null? annotations))
+        (set! (ly:prob-property system 'stencil)
+              (ly:stencil-add
+               (ly:prob-property system 'stencil)
+               (ly:make-stencil
+                (ly:stencil-expr annotations)
+                (ly:stencil-extent empty-stencil X)
+                (ly:stencil-extent empty-stencil Y)))))
+    (ly:prob-property system 'stencil)))