extra/flatland/flatland.factor

   1
   2 USING: accessors arrays fry kernel math math.vectors sequences
   3        math.intervals
   4        multi-methods
   5        combinators.cleave.enhanced
   6        multi-method-syntax ;
   7
   8 IN: flatland
   9
  10 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  11
  12 ! Two dimensional world protocol
  13
  14 GENERIC: x ( obj -- x )
  15 GENERIC: y ( obj -- y )
  16
  17 GENERIC: (x!) ( x obj -- )
  18 GENERIC: (y!) ( y obj -- )
  19
  20 : x! ( obj x -- obj ) over (x!) ;
  21 : y! ( obj y -- obj ) over (y!) ;
  22
  23 GENERIC: width  ( obj -- width  )
  24 GENERIC: height ( obj -- height )
  25
  26 GENERIC: (width!)  ( width  obj -- )
  27 GENERIC: (height!) ( height obj -- )
  28
  29 : width!  ( obj width  -- obj ) over (width!) ;
  30 : height! ( obj height -- obj ) over (width!) ;
  31
  32 ! Predicates on relative placement
  33
  34 GENERIC: to-the-left-of?  ( obj obj -- ? )
  35 GENERIC: to-the-right-of? ( obj obj -- ? )
  36
  37 GENERIC: below? ( obj obj -- ? )
  38 GENERIC: above? ( obj obj -- ? )
  39
  40 GENERIC: in-between-horizontally? ( obj obj -- ? )
  41
  42 GENERIC: horizontal-interval ( obj -- interval )
  43
  44 GENERIC: move-to ( obj obj -- )
  45
  46 GENERIC: move-by ( obj delta -- )
  47
  48 GENERIC: move-left-by  ( obj obj -- )
  49 GENERIC: move-right-by ( obj obj -- )
  50
  51 GENERIC: left   ( obj -- left   )
  52 GENERIC: right  ( obj -- right  )
  53 GENERIC: bottom ( obj -- bottom )
  54 GENERIC: top    ( obj -- top    )
  55
  56 GENERIC: distance ( a b -- c )
  57
  58 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  59
  60 ! Some of the above methods work on two element sequences.
  61 ! A two element sequence may represent a point in space or describe
  62 ! width and height.
  63
  64 METHOD: x ( sequence -- x ) first  ;
  65 METHOD: y ( sequence -- y ) second ;
  66
  67 METHOD: (x!) ( number sequence -- ) set-first  ;
  68 METHOD: (y!) ( number sequence -- ) set-second ;
  69
  70 METHOD: width  ( sequence -- width  ) first  ;
  71 METHOD: height ( sequence -- height ) second ;
  72
  73 : changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
  74 : changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
  75
  76 METHOD: move-to ( sequence sequence -- )         [ x x! ] [ y y! ] bi drop ;
  77 METHOD: move-by ( sequence sequence -- ) dupd v+ [ x x! ] [ y y! ] bi drop ;
  78
  79 METHOD: move-left-by  ( sequence number -- ) '[ _ - ] changed-x ;
  80 METHOD: move-right-by ( sequence number -- ) '[ _ + ] changed-x ;
  81
  82 ! METHOD: move-left-by  ( sequence number -- ) neg 0 2array move-by ;
  83 ! METHOD: move-right-by ( sequence number -- )     0 2array move-by ;
  84
  85 ! METHOD:: move-left-by  ( SEQ:sequence X:number -- )
  86 !   SEQ { X 0 } { -1 0 } v* move-by ;
  87
  88 METHOD: distance ( sequence sequence -- dist ) v- norm ;
  89
  90 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  91
  92 ! A class for objects with a position
  93
  94 TUPLE: <pos> pos ;
  95
  96 METHOD: x ( <pos> -- x ) pos>> first  ;
  97 METHOD: y ( <pos> -- y ) pos>> second ;
  98
  99 METHOD: (x!) ( number <pos> -- ) pos>> set-first  ;
 100 METHOD: (y!) ( number <pos> -- ) pos>> set-second ;
 101
 102 METHOD: to-the-left-of?  ( <pos> number -- ? ) [ x ] dip < ;
 103 METHOD: to-the-right-of? ( <pos> number -- ? ) [ x ] dip > ;
 104
 105 METHOD: move-left-by  ( <pos> number -- ) [ pos>> ] dip move-left-by  ;
 106 METHOD: move-right-by ( <pos> number -- ) [ pos>> ] dip move-right-by ;
 107
 108 METHOD: above? ( <pos> number -- ? ) [ y ] dip > ;
 109 METHOD: below? ( <pos> number -- ? ) [ y ] dip < ;
 110
 111 METHOD: move-by ( <pos> sequence -- ) '[ _ v+ ] change-pos drop ;
 112
 113 METHOD: distance ( <pos> <pos> -- dist ) [ pos>> ] bi@ distance ;
 114
 115 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 116
 117 ! A class for objects with velocity. It inherits from <pos>. Hey, if
 118 ! it's moving it has a position right? Unless it's some alternate universe...
 119
 120 TUPLE: <vel> < <pos> vel ;
 121
 122 : moving-up?   ( obj -- ? ) vel>> y 0 > ;
 123 : moving-down? ( obj -- ? ) vel>> y 0 < ;
 124
 125 : step-size ( vel time -- dist ) [ vel>> ] dip v*n      ;
 126 : move-for  ( vel time --      ) dupd step-size move-by ;
 127
 128 : reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
 129
 130 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 131
 132 ! The 'pos' slot indicates the lower left hand corner of the
 133 ! rectangle. The 'dim' is holds the width and height.
 134
 135 TUPLE: <rectangle> < <pos> dim ;
 136
 137 METHOD: width  ( <rectangle> -- width  ) dim>> first  ;
 138 METHOD: height ( <rectangle> -- height ) dim>> second ;
 139
 140 METHOD: left   ( <rectangle> -- x )    x             ;
 141 METHOD: right  ( <rectangle> -- x ) \\ x width  bi + ;
 142 METHOD: bottom ( <rectangle> -- y )    y             ;
 143 METHOD: top    ( <rectangle> -- y ) \\ y height bi + ;
 144
 145 : bottom-left ( rectangle -- pos ) pos>> ;
 146
 147 : center-x ( rectangle -- x ) [ left   ] [ width  2 / ] bi + ;
 148 : center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
 149
 150 : center ( rectangle -- seq ) \\ center-x center-y bi 2array ;
 151
 152 METHOD: to-the-left-of?  ( <pos> <rectangle> -- ? ) \\ x left  bi* < ;
 153 METHOD: to-the-right-of? ( <pos> <rectangle> -- ? ) \\ x right bi* > ;
 154
 155 METHOD: below? ( <pos> <rectangle> -- ? ) \\ y bottom bi* < ;
 156 METHOD: above? ( <pos> <rectangle> -- ? ) \\ y top    bi* > ;
 157
 158 METHOD: horizontal-interval ( <rectangle> -- interval )
 159   \\ left right bi [a,b] ;
 160
 161 METHOD: in-between-horizontally? ( <pos> <rectangle> -- ? )
 162   \\ x horizontal-interval bi* interval-contains? ;
 163
 164 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 165
 166 TUPLE: <extent> left right bottom top ;
 167
 168 METHOD: left   ( <extent> -- left   ) left>>   ;
 169 METHOD: right  ( <extent> -- right  ) right>>  ;
 170 METHOD: bottom ( <extent> -- bottom ) bottom>> ;
 171 METHOD: top    ( <extent> -- top    ) top>>    ;
 172
 173 METHOD: width  ( <extent> -- width  ) \\ right>> left>>   bi - ;
 174 METHOD: height ( <extent> -- height ) \\ top>>   bottom>> bi - ;
 175
 176 ! METHOD: to-extent ( <rectangle> -- <extent> )
 177 !   { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;
 178
 179 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 180
 181 METHOD: to-the-left-of?  ( sequence <rectangle> -- ? ) \\ x left  bi* < ;
 182 METHOD: to-the-right-of? ( sequence <rectangle> -- ? ) \\ x right bi* > ;
 183
 184 METHOD: below? ( sequence <rectangle> -- ? ) \\ y bottom bi* < ;
 185 METHOD: above? ( sequence <rectangle> -- ? ) \\ y top    bi* > ;
 186
 187 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 188
 189 ! Some support for the' 'rect' class from math.geometry.rect'
 190
 191 ! METHOD: width  ( rect -- width  ) dim>> first  ;
 192 ! METHOD: height ( rect -- height ) dim>> second ;
 193
 194 ! METHOD: left  ( rect -- left  ) loc>> x
 195 ! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
 196
 197 ! METHOD: to-the-left-of?  ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
 198 ! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
 199
 200 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 201
 202 USING: locals combinators ;
 203
 204 :: wrap ( POINT RECT -- POINT )
 205
 206   {
 207       { [ POINT RECT to-the-left-of?  ] [ RECT right ] }
 208       { [ POINT RECT to-the-right-of? ] [ RECT left  ] }
 209       { [ t                           ] [ POINT x    ] }
 210   }
 211   cond
 212
 213   {
 214       { [ POINT RECT below? ] [ RECT top    ] }
 215       { [ POINT RECT above? ] [ RECT bottom ] }
 216       { [ t                 ] [ POINT y     ] }
 217   }
 218   cond
 219
 220   2array ;