flatland/flatland.factor

   1
   2 USING: accessors arrays combinators combinators.short-circuit
   3 fry kernel locals math math.intervals math.vectors multi-methods
   4 sequences ;
   5 FROM: multi-methods => GENERIC: ;
   6 IN: flatland
   7
   8 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   9
  10 ! Two dimensional world protocol
  11
  12 GENERIC: x ( obj -- x )
  13 GENERIC: y ( obj -- y )
  14
  15 GENERIC: (x!) ( x obj -- )
  16 GENERIC: (y!) ( y obj -- )
  17
  18 : x! ( obj x -- obj ) over (x!) ;
  19 : y! ( obj y -- obj ) over (y!) ;
  20
  21 GENERIC: width  ( obj -- width  )
  22 GENERIC: height ( obj -- height )
  23
  24 GENERIC: (width!)  ( width  obj -- )
  25 GENERIC: (height!) ( height obj -- )
  26
  27 : width!  ( obj width  -- obj ) over (width!) ;
  28 : height! ( obj height -- obj ) over (width!) ;
  29
  30 ! Predicates on relative placement
  31
  32 GENERIC: to-the-left-of?  ( obj obj -- ? )
  33 GENERIC: to-the-right-of? ( obj obj -- ? )
  34
  35 GENERIC: below? ( obj obj -- ? )
  36 GENERIC: above? ( obj obj -- ? )
  37
  38 GENERIC: in-between-horizontally? ( obj obj -- ? )
  39
  40 GENERIC: horizontal-interval ( obj -- interval )
  41
  42 GENERIC: move-to ( obj obj -- )
  43
  44 GENERIC: move-by ( obj delta -- )
  45
  46 GENERIC: move-left-by  ( obj obj -- )
  47 GENERIC: move-right-by ( obj obj -- )
  48
  49 GENERIC: left   ( obj -- left   )
  50 GENERIC: right  ( obj -- right  )
  51 GENERIC: bottom ( obj -- bottom )
  52 GENERIC: top    ( obj -- top    )
  53
  54 GENERIC: distance ( a b -- c )
  55
  56 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  57
  58 ! Some of the above methods work on two element sequences.
  59 ! A two element sequence may represent a point in space or describe
  60 ! width and height.
  61
  62 METHOD: x { sequence } first  ;
  63 METHOD: y { sequence } second ;
  64
  65 METHOD: (x!) { number sequence } set-first  ;
  66 METHOD: (y!) { number sequence } set-second ;
  67
  68 METHOD: width  { sequence } first  ;
  69 METHOD: height { sequence } second ;
  70
  71 : changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
  72 : changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
  73
  74 METHOD: move-to { sequence sequence }         [ x x! ] [ y y! ] bi drop ;
  75 METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
  76
  77 METHOD: move-left-by  { sequence number } '[ _ - ] changed-x ;
  78 METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
  79
  80 ! METHOD: move-left-by  { sequence number } neg 0 2array move-by ;
  81 ! METHOD: move-right-by { sequence number }     0 2array move-by ;
  82
  83 ! METHOD:: move-left-by  { SEQ:sequence X:number -- )
  84 !   SEQ { X 0 } { -1 0 } v* move-by ;
  85
  86 METHOD: distance { sequence sequence } v- norm ;
  87
  88 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  89
  90 ! A class for objects with a position
  91
  92 TUPLE: pos pos ;
  93
  94 METHOD: x { pos } pos>> first  ;
  95 METHOD: y { pos } pos>> second ;
  96
  97 METHOD: (x!) { number pos } pos>> set-first  ;
  98 METHOD: (y!) { number pos } pos>> set-second ;
  99
 100 METHOD: to-the-left-of?  { pos number } [ x ] dip < ;
 101 METHOD: to-the-right-of? { pos number } [ x ] dip > ;
 102
 103 METHOD: move-left-by  { pos number } [ pos>> ] dip move-left-by  ;
 104 METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ;
 105
 106 METHOD: above? { pos number } [ y ] dip > ;
 107 METHOD: below? { pos number } [ y ] dip < ;
 108
 109 METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ;
 110
 111 METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
 112
 113 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 114
 115 ! A class for objects with velocity. It inherits from pos. Hey, if
 116 ! it's moving it has a position right? Unless it's some alternate universe...
 117
 118 TUPLE: vel < pos vel ;
 119
 120 : moving-up?   ( obj -- ? ) vel>> y 0 > ;
 121 : moving-down? ( obj -- ? ) vel>> y 0 < ;
 122
 123 : step-size ( vel time -- dist ) [ vel>> ] dip v*n      ;
 124 : move-for  ( vel time --      ) dupd step-size move-by ;
 125
 126 : reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
 127
 128 : reverse-vertical-velocity ( vel -- ) vel>> [ y neg ] [ ] bi (y!) ;
 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 } dim>> first  ;
 138 METHOD: height { rectangle } dim>> second ;
 139
 140 METHOD: left   { rectangle }    x             ;
 141 METHOD: right  { rectangle } [ x ] [ width ] bi + ;
 142 METHOD: bottom { rectangle }    y             ;
 143 METHOD: top    { rectangle } [ 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 }
 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>>   ;
 169 METHOD: right  { extent } right>>  ;
 170 METHOD: bottom { extent } bottom>> ;
 171 METHOD: top    { extent } top>>    ;
 172
 173 METHOD: width  { extent } [ right>> ] [ left>>   ] bi - ;
 174 METHOD: height { extent } [ 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 :: wrap ( POINT RECT -- POINT )
 203   {
 204       { [ POINT RECT to-the-left-of?  ] [ RECT right ] }
 205       { [ POINT RECT to-the-right-of? ] [ RECT left  ] }
 206       { [ t                           ] [ POINT x    ] }
 207   }
 208   cond
 209
 210   {
 211       { [ POINT RECT below? ] [ RECT top    ] }
 212       { [ POINT RECT above? ] [ RECT bottom ] }
 213       { [ t                 ] [ POINT y     ] }
 214   }
 215   cond
 216
 217   2array ;
 218
 219 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 220
 221 GENERIC: within? ( a b -- ? )
 222
 223 METHOD: within? { pos rectangle }
 224   {
 225     [ left   to-the-right-of? ]
 226     [ right  to-the-left-of?  ]
 227     [ bottom above?           ]
 228     [ top    below?           ]
 229   }
 230   2&& ;