extra/flatland/flatland.factor

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