basis/math/geometry/rect/rect.factor

   1
   2 USING: kernel arrays sequences
   3        math math.points math.vectors math.geometry
   4        accessors ;
   5
   6 IN: math.geometry.rect
   7
   8 TUPLE: rect loc dim ;
   9
  10 GENERIC: rect-loc ( obj -- loc )
  11 GENERIC: rect-dim ( obj -- dim )
  12
  13 : init-rect ( rect -- rect ) { 0 0 } clone >>loc { 0 0 } clone >>dim ;
  14
  15 : <rect> ( loc dim -- rect ) rect boa ;
  16
  17 : <zero-rect> ( -- rect ) rect new init-rect ;
  18
  19 M: array rect-loc ;
  20
  21 M: array rect-dim drop { 0 0 } ;
  22
  23 M: rect rect-loc loc>> ;
  24
  25 M: rect rect-dim dim>> ;
  26
  27 : rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
  28
  29 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
  30
  31 : 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
  32     [ rect-extent ] bi@ swapd ;
  33
  34 : <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
  35
  36 : offset-rect ( rect loc -- newrect )
  37     over rect-loc v+ swap rect-dim <rect> ;
  38
  39 : (rect-intersect) ( rect rect -- array array )
  40     2rect-extent [ vmax ] [ vmin ] 2bi* ;
  41
  42 : rect-intersect ( rect1 rect2 -- newrect )
  43     (rect-intersect) <extent-rect> ;
  44
  45 : intersects? ( rect/point rect -- ? )
  46     (rect-intersect) [v-] { 0 0 } = ;
  47
  48 : (rect-union) ( rect rect -- array array )
  49     2rect-extent [ vmin ] [ vmax ] 2bi* ;
  50
  51 : rect-union ( rect1 rect2 -- newrect )
  52     (rect-union) <extent-rect> ;
  53
  54 M: rect width  ( rect -- width  ) dim>> first  ;
  55 M: rect height ( rect -- height ) dim>> second ;
  56
  57 M: rect set-width!  ( rect width  -- rect ) over dim>> set-first  ;
  58 M: rect set-height! ( rect height -- rect ) over dim>> set-second ;
  59
  60 M: rect set-x! ( rect x -- rect ) over loc>> set-first  ;
  61 M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
  62
  63 : rect-containing ( points -- rect )
  64     [ vleast ] [ vgreatest ] bi
  65     [ drop ] [ swap v- ] 2bi <rect> ;
  66
  67 ! Accessing corners
  68
  69 : top-left     ( rect -- point ) loc>> ;
  70 : top-right    ( rect -- point ) [ loc>> ] [ width  1 - ] bi v+x ;
  71 : bottom-left  ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ;
  72 : bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ;
  73