basis/math/rectangles/rectangles.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: kernel arrays sequences math math.vectors accessors
   4 parser ;
   5 IN: math.rectangles
   6
   7 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
   8
   9 : <rect> ( loc dim -- rect ) rect boa ; inline
  10
  11 SYNTAX: RECT: scan-object scan-object <rect> suffix! ;
  12
  13 : <zero-rect> ( -- rect ) rect new ; inline
  14
  15 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
  16
  17 : rect-bounds ( rect -- loc dim ) [ loc>> ] [ dim>> ] bi ;
  18
  19 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
  20
  21 : rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
  22
  23 : with-rect-extents ( ..a+b rect1 rect2 loc-quot: ( ..a loc1 loc2 -- ..c ) ext-quot: ( ..b ext1 ext2 -- ..d ) -- ..c+d )
  24     [ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
  25
  26 : <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
  27
  28 : offset-rect ( rect loc -- newrect )
  29     over loc>> v+ swap dim>> <rect> ;
  30
  31 : (rect-intersect) ( rect rect -- array array )
  32     [ vmax ] [ vmin ] with-rect-extents ;
  33
  34 : rect-intersect ( rect1 rect2 -- newrect )
  35     (rect-intersect) <extent-rect> ;
  36
  37 GENERIC: contains-rect? ( rect1 rect2 -- ? )
  38
  39 M: rect contains-rect?
  40     (rect-intersect) [v-] { 0 0 } = ;
  41
  42 GENERIC: contains-point? ( point rect -- ? )
  43
  44 M: rect contains-point?
  45     [ point>rect ] dip contains-rect? ;
  46
  47 : (rect-union) ( rect rect -- array array )
  48     [ vmin ] [ vmax ] with-rect-extents ;
  49
  50 : rect-union ( rect1 rect2 -- newrect )
  51     (rect-union) <extent-rect> ;
  52
  53 : rect-containing ( points -- rect )
  54     [ vsupremum ] [ vinfimum ] bi
  55     [ nip ] [ v- ] 2bi <rect> ;
  56
  57 : rect-min ( rect dim -- rect' )
  58     [ rect-bounds ] dip vmin <rect> ;
  59
  60 : set-rect-bounds ( rect1 rect -- )
  61     [ [ loc>> ] dip loc<< ]
  62     [ [ dim>> ] dip dim<< ]
  63     2bi ; inline
  64
  65 USE: vocabs.loader
  66
  67 { "math.rectangles" "prettyprint" } "math.rectangles.prettyprint" require-when