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