]> git.donarmstrong.com Git - lilypond.git/blob - scm/paper-system.scm
typo
[lilypond.git] / 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 'refpoint-Y-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                                  "refpoint-Y-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)))