basis/math/rectangles/rectangles.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel arrays sequences math math.vectors accessors ;
   4 IN: math.rectangles
   5
   6 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
   7
   8 : <rect> ( loc dim -- rect ) rect boa ; inline
   9
  10 : <zero-rect> ( -- rect ) rect new ; inline
  11
  12 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
  13
  14 : rect-bounds ( rect -- loc dim ) [ loc>> ] [ dim>> ] bi ;
  15
  16 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
  17
  18 : with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
  19     [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
  20
  21 : <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
  22
  23 : offset-rect ( rect loc -- newrect )
  24     over loc>> v+ swap dim>> <rect> ;
  25
  26 : (rect-intersect) ( rect rect -- array array )
  27     [ vmax ] [ vmin ] with-rect-extents ;
  28
  29 : rect-intersect ( rect1 rect2 -- newrect )
  30     (rect-intersect) <extent-rect> ;
  31
  32 GENERIC: contains-rect? ( rect1 rect2 -- ? )
  33
  34 M: rect contains-rect?
  35     (rect-intersect) [v-] { 0 0 } = ;
  36
  37 GENERIC: contains-point? ( point rect -- ? )
  38
  39 M: rect contains-point?
  40     [ point>rect ] dip contains-rect? ;
  41
  42 : (rect-union) ( rect rect -- array array )
  43     [ vmin ] [ vmax ] with-rect-extents ;
  44
  45 : rect-union ( rect1 rect2 -- newrect )
  46     (rect-union) <extent-rect> ;
  47
  48 : rect-containing ( points -- rect )
  49     [ vsupremum ] [ vinfimum ] bi
  50     [ nip ] [ v- ] 2bi <rect> ;