scm/clip-region.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2006--2010 Han-Wen Nienhuys <hanwen@lilypond.org>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define-module (scm clip-region))
  19
  20 (use-modules (lily))
  21
  22
  23 (define-public (make-rhythmic-location bar-num num den)
  24   (cons
  25    bar-num (ly:make-moment num den)))
  26
  27 (define-public (rhythmic-location? a)
  28   (and (pair? a)
  29        (integer? (car a))
  30        (ly:moment? (cdr a))))
  31
  32 (define-public (make-graceless-rhythmic-location loc)
  33   (make-rhythmic-location
  34    (car loc)
  35    (ly:moment-main-numerator (rhythmic-location-measure-position loc))
  36    (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
  37
  38
  39 (define-public rhythmic-location-measure-position cdr)
  40 (define-public rhythmic-location-bar-number car)
  41
  42 (define-public (rhythmic-location<? a b)
  43   (cond
  44    ((< (car a) (car b)) #t)
  45    ((> (car a) (car b)) #f)
  46    (else
  47     (ly:moment<? (cdr a) (cdr b)))))
  48
  49 (define-public (rhythmic-location<=? a b)
  50   (not (rhythmic-location<? b a)))
  51 (define-public (rhythmic-location>=? a b)
  52   (rhythmic-location<? a b))
  53 (define-public (rhythmic-location>? a b)
  54   (rhythmic-location<? b a))
  55
  56 (define-public (rhythmic-location=? a b)
  57   (and (rhythmic-location<=? a b)
  58        (rhythmic-location<=? b a)))
  59
  60
  61 (define-public (rhythmic-location->file-string a)
  62   (ly:format "~a.~a.~a"
  63           (car a)
  64           (ly:moment-main-numerator (cdr a))
  65           (ly:moment-main-denominator (cdr a))))
  66
  67 (define-public (rhythmic-location->string a)
  68   (ly:format "bar ~a ~a"
  69           (car a)
  70           (ly:moment->string  (cdr a))))
  71
  72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73 ;;  Actual clipping logic.
  74
  75 ;;
  76 ;; the total of this will be
  77 ;; O(#systems * #regions)
  78 ;;
  79 ;; we can actually do better by sorting the regions as well,
  80 ;; but let's leave that for future extensions.
  81 ;;
  82 (define-public (system-clipped-x-extent system-grob clip-region)
  83   "Return the X-extent of the SYSTEM-GROB when clipped with
  84 CLIP-REGION. Return #f if not appropriate."
  85
  86   (let*
  87       ((region-start (car clip-region))
  88        (columns (ly:grob-object system-grob 'columns))
  89        (region-end (cdr clip-region))
  90        (found-grace-end  #f)
  91        (candidate-columns
  92         (filter
  93          (lambda (j)
  94            (let*
  95                ((column (ly:grob-array-ref columns j))
  96                 (loc (ly:grob-property column 'rhythmic-location))
  97                 (grace-less (make-graceless-rhythmic-location loc))
  98                 )
  99
 100              (and (rhythmic-location? loc)
 101                   (rhythmic-location<=? region-start loc)
 102                   (or (rhythmic-location<? grace-less region-end)
 103                       (and (rhythmic-location=? grace-less region-end)
 104                            (eq? #t (ly:grob-property column 'non-musical))
 105
 106                            )))
 107
 108              ))
 109
 110          (iota (ly:grob-array-length columns))))
 111
 112        (column-range
 113         (if (>= 1 (length candidate-columns))
 114             #f
 115             (cons (car candidate-columns)
 116                   (car (last-pair candidate-columns)))))
 117
 118        (clipped-x-interval
 119         (if column-range
 120             (cons
 121
 122              (interval-start
 123               (ly:grob-robust-relative-extent
 124                (if (= 0 (car column-range))
 125                    system-grob
 126                    (ly:grob-array-ref columns (car column-range)))
 127                system-grob X))
 128
 129              (interval-end
 130               (ly:grob-robust-relative-extent
 131               (if (= (1- (ly:grob-array-length columns)) (cdr column-range))
 132                   system-grob
 133                   (ly:grob-array-ref columns (cdr column-range)))
 134               system-grob X)))
 135
 136
 137             #f
 138             )))
 139
 140     clipped-x-interval))