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   (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   (format "bar ~a ~a"
  60           (car a)
  61           (ly:moment->string  (cdr a))))
  62
  63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64 ;;  Actual clipping logic.
  65
  66 (define-public (system-clipped-x-extent system-grob clip-region)
  67   "Return the X-extent of the SYSTEM-GROB when clipped with
  68 CLIP-REGION. Return #f if not appropriate."
  69
  70   (let*
  71       ((region-start (car clip-region))
  72        (columns (ly:grob-object system-grob 'columns))
  73        (region-end (cdr clip-region))
  74        (found-grace-end  #f)
  75        (candidate-columns
  76         (filter
  77          (lambda (j)
  78            (let*
  79                ((column (ly:grob-array-ref columns j))
  80                 (loc (ly:grob-property column 'rhythmic-location))
  81                 (grace-less (make-graceless-rhythmic-location loc))
  82                 )
  83
  84              (and (rhythmic-location? loc)
  85                   (rhythmic-location<=? region-start loc)
  86                   (or (rhythmic-location<? grace-less region-end)
  87                       (and (rhythmic-location=? grace-less region-end)
  88                            (eq? #t (ly:grob-property column 'non-musical))
  89
  90                            )))
  91
  92              ))
  93
  94          (iota (ly:grob-array-length columns))))
  95
  96        (column-range
  97         (if (>= 1 (length candidate-columns))
  98             #f
  99             (cons (car candidate-columns)
 100                   (car (last-pair candidate-columns)))))
 101
 102        (clipped-x-interval
 103         (if column-range
 104             (cons
 105
 106              (interval-start
 107               (ly:grob-robust-relative-extent
 108                (if (= 0 (car column-range))
 109                    system-grob
 110                    (ly:grob-array-ref columns (car column-range)))
 111                system-grob X))
 112
 113              (interval-end
 114               (ly:grob-robust-relative-extent
 115               (if (= (1- (ly:grob-array-length columns)) (cdr column-range))
 116                   system-grob
 117                   (ly:grob-array-ref columns (cdr column-range)))
 118               system-grob X)))
 119
 120
 121             #f
 122             )))
 123
 124     clipped-x-interval))