scm/paper-system.scm

   1 ;;
   2 ;; paper-system.scm -- implement paper-system objects.
   3 ;;
   4 ;; source file of the GNU LilyPond music typesetter
   5 ;;
   6 ;; (c) 2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
   7 ;;
   8
   9 (define-module (scm paper-system))
  10
  11 (use-modules (lily))
  12
  13 (define-public (paper-system-title? system)
  14   (equal? #t (ly:prob-property system 'is-title)
  15           ))
  16
  17 (define-public (paper-system-stencil system)
  18   (ly:prob-property system 'stencil))
  19
  20 (define-public (paper-system-system-grob paper-system)
  21   (ly:prob-property paper-system 'system-grob))
  22
  23 (define-public (paper-system-extent system axis)
  24   (ly:stencil-extent (paper-system-stencil system) axis))
  25
  26 (define-public (paper-system-staff-extents ps)
  27   (ly:prob-property ps 'refpoint-Y-extent '(0 . 0)))
  28
  29 (define-public (paper-system-annotate-last system layout)
  30   (let*
  31       ((bottomspace (ly:prob-property system 'bottom-space))
  32        (y-extent (paper-system-extent system Y))
  33        (x-extent (paper-system-extent system X))
  34        (stencil (ly:prob-property system 'stencil))
  35
  36        (arrow (if (number? bottomspace)
  37                (annotate-y-interval layout
  38                                     "bottom-space"
  39                                     (cons (- (car y-extent) bottomspace)
  40                                           (car y-extent))
  41                                     #t)
  42                #f)))
  43
  44     (if arrow
  45         (set! stencil
  46               (ly:stencil-add stencil arrow)))
  47
  48     (set! (ly:prob-property system 'stencil)
  49           stencil)
  50   ))
  51
  52 (define-public (paper-system-annotate system next-system layout)
  53   "Add arrows and texts to indicate which lengths are set."
  54   (let* ((annotations (list))
  55          (annotate-extent-and-space
  56           (lambda (extent-accessor next-space
  57                                    extent-name next-space-name after-space-name)
  58             (let* ((extent-annotations (list))
  59                    (this-extent (extent-accessor system))
  60                    (next-extent (and next-system (extent-accessor next-system)))
  61                    (push-annotation (lambda (stil)
  62                                       (set! extent-annotations
  63                                             (cons stil extent-annotations))))
  64                    (color (if (paper-system-title? system) darkblue blue))
  65                    (space-color (if (paper-system-title? system) darkred red)))
  66               (if (and (number-pair? this-extent)
  67                        (not (= (interval-start this-extent)
  68                                (interval-end this-extent))))
  69                   (push-annotation (annotate-y-interval
  70                                     layout extent-name this-extent #f
  71                                     #:color color)))
  72               (if next-system
  73                   (push-annotation (annotate-y-interval
  74                                     layout next-space-name
  75                                     (interval-translate (cons (- next-space) 0)
  76                                                         (if (number-pair? this-extent)
  77                                                             (interval-start this-extent)
  78                                                             0))
  79                                     #t
  80                                     #:color color)))
  81               (if (and next-system
  82                        (number-pair? this-extent)
  83                        (number-pair? next-extent))
  84                   (let ((space-after
  85                          (- (+ (ly:prob-property next-system 'Y-offset)
  86                                (interval-start this-extent))
  87                             (ly:prob-property system 'Y-offset)
  88                             (interval-end next-extent)
  89                             next-space)))
  90                     (if (> space-after 0.01)
  91                         (push-annotation (annotate-y-interval
  92                                           layout
  93                                           after-space-name
  94                                           (interval-translate
  95                                            (cons (- space-after) 0)
  96                                            (- (interval-start this-extent)
  97                                               next-space))
  98                                           #t
  99                                           #:color space-color)))))
 100               (if (not (null? extent-annotations))
 101                   (set! annotations
 102                         (stack-stencils X RIGHT 0.5
 103                                         (list annotations
 104                                               (ly:make-stencil '() (cons 0 1) (cons 0 0))
 105                                               (apply ly:stencil-add
 106                                                      extent-annotations))))))))
 107
 108          (grob (ly:prob-property system 'system-grob))
 109          (estimate-extent (if (ly:grob? grob)
 110                               (annotate-y-interval layout
 111                                                    "extent-estimate"
 112                                                    (ly:grob-property grob 'pure-Y-extent)
 113                                                    #f)
 114                               #f)))
 115     (let ((next-space (ly:prob-property
 116                        system 'next-space
 117                        (cond ((and next-system
 118                                    (paper-system-title? system)
 119                                    (paper-system-title? next-system))
 120                               (ly:output-def-lookup layout 'between-title-space))
 121                              ((paper-system-title? system)
 122                               (ly:output-def-lookup layout 'after-title-space))
 123                              ((and next-system
 124                                    (paper-system-title? next-system))
 125                               (ly:output-def-lookup layout 'before-title-space))
 126                              (else
 127                               (ly:output-def-lookup layout 'between-system-space)))))
 128           (next-padding (ly:prob-property
 129                          system 'next-padding
 130                          (ly:output-def-lookup layout 'between-system-padding))))
 131       (annotate-extent-and-space (lambda (sys)
 132                                    (paper-system-extent sys Y))
 133                                  next-padding
 134                                  "Y-extent" "next-padding" "space after next-padding")
 135       (annotate-extent-and-space paper-system-staff-extents
 136                                  (+ next-space next-padding)
 137                                  "refpoint-Y-extent" "next-space+padding"
 138                                  "space after next-space+padding"))
 139     (if estimate-extent
 140         (set! annotations
 141               (stack-stencils X RIGHT 0.5
 142                               (list annotations
 143                                     estimate-extent))))
 144
 145     (if (not (null? annotations))
 146         (set! (ly:prob-property system 'stencil)
 147               (ly:stencil-add
 148                (ly:prob-property system 'stencil)
 149                (ly:make-stencil
 150                 (ly:stencil-expr annotations)
 151                 (ly:stencil-extent empty-stencil X)
 152                 (ly:stencil-extent empty-stencil Y)))))
 153     (ly:prob-property system 'stencil)))