scm/clip-region.scm

   1 ;;
   2 ;; clip-region.scm -- implement  rhythmic-location and EPS musical clipping
   3 ;;
   4 ;; source file of the GNU LilyPond music typesetter
   5 ;;
   6 ;; (c) 2006 Han-Wen Nienhuys <hanwen@lilypond.org>
   7 ;;
   8
   9 (define-module (scm clip-region))
  10
  11 (use-modules (lily))
  12
  13
  14 (define-public (make-rhythmic-location bar-num num den)
  15   (cons
  16    bar-num (ly:make-moment num den)))
  17
  18 (define-public (rhythmic-location? a)
  19   (and (pair? a)
  20        (integer? (car a))
  21        (ly:moment? (cdr a))))
  22
  23 (define-public (make-graceless-rhythmic-location loc)
  24   (make-rhythmic-location
  25    (car loc)
  26    (ly:moment-main-numerator (rhythmic-location-measure-position loc))
  27    (ly:moment-main-denominator (rhythmic-location-measure-position loc))))
  28
  29
  30 (define-public rhythmic-location-measure-position cdr)
  31 (define-public rhythmic-location-bar-number car)
  32
  33 (define-public (rhythmic-location<? a b)
  34   (cond
  35    ((< (car a) (car b)) #t)
  36    ((> (car a) (car b)) #f)
  37    (else
  38     (ly:moment<? (cdr a) (cdr b)))))
  39
  40 (define-public (rhythmic-location<=? a b)
  41   (not (rhythmic-location<? b a)))
  42 (define-public (rhythmic-location>=? a b)
  43   (rhythmic-location<? a b))
  44 (define-public (rhythmic-location>? a b)
  45   (rhythmic-location<? b a))
  46
  47 (define-public (rhythmic-location=? a b)
  48   (and (rhythmic-location<=? a b)
  49        (rhythmic-location<=? b a)))
  50
  51
  52 (define-public (rhythmic-location->file-string a)
  53   (ly:format "~a.~a.~a"
  54           (car a)
  55           (ly:moment-main-numerator (cdr a))
  56           (ly:moment-main-denominator (cdr a))))
  57
  58 (define-public (rhythmic-location->string a)
  59   (ly:format "bar ~a ~a"
  60           (car a)
  61           (ly:moment->string  (cdr a))))
  62
  63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64 ;;  Actual clipping logic.
  65
  66 ;;
  67 ;; the total of this will be
  68 ;; O(#systems * #regions)
  69 ;;
  70 ;; we can actually do better by sorting the regions as well,
  71 ;; but let's leave that for future extensions.
  72 ;;
  73 (define-public (system-clipped-x-extent system-grob clip-region)
  74   "Return the X-extent of the SYSTEM-GROB when clipped with
  75 CLIP-REGION. Return #f if not appropriate."
  76
  77   (let*
  78       ((region-start (car clip-region))
  79        (columns (ly:grob-object system-grob 'columns))
  80        (region-end (cdr clip-region))
  81        (found-grace-end  #f)
  82        (candidate-columns
  83         (filter
  84          (lambda (j)
  85            (let*
  86                ((column (ly:grob-array-ref columns j))
  87                 (loc (ly:grob-property column 'rhythmic-location))
  88                 (grace-less (make-graceless-rhythmic-location loc))
  89                 )
  90
  91              (and (rhythmic-location? loc)
  92                   (rhythmic-location<=? region-start loc)
  93                   (or (rhythmic-location<? grace-less region-end)
  94                       (and (rhythmic-location=? grace-less region-end)
  95                            (eq? #t (ly:grob-property column 'non-musical))
  96
  97                            )))
  98
  99              ))
 100
 101          (iota (ly:grob-array-length columns))))
 102
 103        (column-range
 104         (if (>= 1 (length candidate-columns))
 105             #f
 106             (cons (car candidate-columns)
 107                   (car (last-pair candidate-columns)))))
 108
 109        (clipped-x-interval
 110         (if column-range
 111             (cons
 112
 113              (interval-start
 114               (ly:grob-robust-relative-extent
 115                (if (= 0 (car column-range))
 116                    system-grob
 117                    (ly:grob-array-ref columns (car column-range)))
 118                system-grob X))
 119
 120              (interval-end
 121               (ly:grob-robust-relative-extent
 122               (if (= (1- (ly:grob-array-length columns)) (cdr column-range))
 123                   system-grob
 124                   (ly:grob-array-ref columns (cdr column-range)))
 125               system-grob X)))
 126
 127
 128             #f
 129             )))
 130
 131     clipped-x-interval))