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 layout)
  53   "Add arrows and texts to indicate which lengths are set."
  54
  55   (let*
  56       ((annotations (ly:make-stencil '() (cons 0 2) (cons 0 0)))
  57        (append-stencil
  58         (lambda (a b)
  59           (ly:stencil-combine-at-edge a X RIGHT b 0.5 0)))
  60
  61        (annotate-property
  62         (lambda (name extent is-length?)
  63           (set! annotations
  64                 (append-stencil annotations
  65                                 (annotate-y-interval layout
  66                                                      name extent is-length?)))))
  67
  68        (bbox-extent (paper-system-extent system Y))
  69        (refp-extent (ly:prob-property system 'refpoint-Y-extent))
  70        (next-space (ly:prob-property system 'next-space
  71                                              (ly:output-def-lookup layout 'between-system-space)
  72                                              ))
  73        (next-padding (ly:prob-property system 'next-padding
  74                                                (ly:output-def-lookup layout 'between-system-padding)
  75                                                ))
  76        )
  77
  78     (if (number-pair? bbox-extent)
  79         (begin
  80           (annotate-property  "Y-extent"
  81                                bbox-extent #f)
  82           (annotate-property  "next-padding"
  83                              (interval-translate (cons (- next-padding) 0) (car bbox-extent))
  84                              #t)))
  85
  86     ;; titles don't have a refpoint-Y-extent.
  87     (if (number-pair? refp-extent)
  88         (begin
  89           (annotate-property "refpoint-Y-extent"
  90                              refp-extent #f)
  91
  92           (annotate-property "next-space"
  93                              (interval-translate (cons (- next-space) 0) (car refp-extent))
  94                        #t)))
  95
  96     (set! (ly:prob-property system 'stencil)
  97           (ly:stencil-add
  98            (ly:prob-property system 'stencil)
  99            (ly:make-stencil
 100             (ly:stencil-expr annotations)
 101             (ly:stencil-extent empty-stencil X)
 102             (ly:stencil-extent empty-stencil Y)
 103             )))
 104
 105     ))