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
7 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
9 : <rect> ( loc dim -- rect ) rect boa ; inline
11 SYNTAX: RECT: scan-object scan-object <rect> suffix! ;
13 : <zero-rect> ( -- rect ) rect new ; inline
15 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
17 : rect-bounds ( rect -- loc dim ) [ loc>> ] [ dim>> ] bi ;
19 : rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
21 : rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
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
26 : <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
28 : offset-rect ( rect loc -- newrect )
29 over loc>> v+ swap dim>> <rect> ;
31 : (rect-intersect) ( rect rect -- array array )
32 [ vmax ] [ vmin ] with-rect-extents ;
34 : rect-intersect ( rect1 rect2 -- newrect )
35 (rect-intersect) <extent-rect> ;
37 GENERIC: contains-rect? ( rect1 rect2 -- ? )
39 M: rect contains-rect?
40 (rect-intersect) [v-] { 0 0 } = ;
42 GENERIC: contains-point? ( point rect -- ? )
44 M: rect contains-point?
45 [ point>rect ] dip contains-rect? ;
47 : (rect-union) ( rect rect -- array array )
48 [ vmin ] [ vmax ] with-rect-extents ;
50 : rect-union ( rect1 rect2 -- newrect )
51 (rect-union) <extent-rect> ;
53 : rect-containing ( points -- rect )
54 [ vsupremum ] [ vinfimum ] bi
55 [ nip ] [ v- ] 2bi <rect> ;
57 : rect-min ( rect dim -- rect' )
58 [ rect-bounds ] dip vmin <rect> ;
60 : set-rect-bounds ( rect1 rect -- )
61 [ [ loc>> ] dip (>>loc) ]
62 [ [ dim>> ] dip (>>dim) ]
65 USING: vocabs vocabs.loader ;
67 "prettyprint" vocab [ "math.rectangles.prettyprint" require ] when