flatland: moving back to unmaintained.

has some confusing bugs with "above?" and "below?".

needs to be cleaned up and tested better.

diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor
deleted file mode 100644 (file)
index 5b68158..0000000
--- a/extra/flatland/flatland.factor
+++ /dev/null
@@ -1,228 +0,0 @@
-
-USING: accessors arrays combinators combinators.short-circuit
-fry kernel locals math math.intervals math.vectors multi-methods
-sequences ;
-FROM: multi-methods => GENERIC: ;
-IN: flatland
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Two dimensional world protocol
-
-GENERIC: x ( obj -- x )
-GENERIC: y ( obj -- y )
-
-GENERIC: (x!) ( x obj -- )
-GENERIC: (y!) ( y obj -- )
-
-: x! ( obj x -- obj ) over (x!) ;
-: y! ( obj y -- obj ) over (y!) ;
-
-GENERIC: width  ( obj -- width  )
-GENERIC: height ( obj -- height )
-
-GENERIC: (width!)  ( width  obj -- )
-GENERIC: (height!) ( height obj -- )
-
-: width!  ( obj width  -- obj ) over (width!) ;
-: height! ( obj height -- obj ) over (width!) ;
-
-! Predicates on relative placement
-
-GENERIC: to-the-left-of?  ( obj obj -- ? )
-GENERIC: to-the-right-of? ( obj obj -- ? )
-
-GENERIC: below? ( obj obj -- ? )
-GENERIC: above? ( obj obj -- ? )
-
-GENERIC: in-between-horizontally? ( obj obj -- ? )
-
-GENERIC: horizontal-interval ( obj -- interval )
-
-GENERIC: move-to ( obj obj -- )
-
-GENERIC: move-by ( obj delta -- )
-
-GENERIC: move-left-by  ( obj obj -- )
-GENERIC: move-right-by ( obj obj -- )
-
-GENERIC: left   ( obj -- left   )
-GENERIC: right  ( obj -- right  )
-GENERIC: bottom ( obj -- bottom )
-GENERIC: top    ( obj -- top    )
-
-GENERIC: distance ( a b -- c )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some of the above methods work on two element sequences.
-! A two element sequence may represent a point in space or describe
-! width and height.
-
-METHOD: x { sequence } first  ;
-METHOD: y { sequence } second ;
-
-METHOD: (x!) { number sequence } set-first  ;
-METHOD: (y!) { number sequence } set-second ;
-
-METHOD: width  { sequence } first  ;
-METHOD: height { sequence } second ;
-
-: changed-x ( seq quot -- ) over [ [ x ] dip call ] dip (x!) ; inline
-: changed-y ( seq quot -- ) over [ [ y ] dip call ] dip (y!) ; inline
-
-METHOD: move-to { sequence sequence }         [ x x! ] [ y y! ] bi drop ;
-METHOD: move-by { sequence sequence } dupd v+ [ x x! ] [ y y! ] bi drop ;
-
-METHOD: move-left-by  { sequence number } '[ _ - ] changed-x ;
-METHOD: move-right-by { sequence number } '[ _ + ] changed-x ;
-
-! METHOD: move-left-by  { sequence number } neg 0 2array move-by ;
-! METHOD: move-right-by { sequence number }     0 2array move-by ;
-
-! METHOD:: move-left-by  { SEQ:sequence X:number -- )
-!   SEQ { X 0 } { -1 0 } v* move-by ;
-
-METHOD: distance { sequence sequence } v- norm ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with a position
-
-TUPLE: pos pos ;
-
-METHOD: x { pos } pos>> first  ;
-METHOD: y { pos } pos>> second ;
-
-METHOD: (x!) { number pos } pos>> set-first  ;
-METHOD: (y!) { number pos } pos>> set-second ;
-
-METHOD: to-the-left-of?  { pos number } [ x ] dip < ;
-METHOD: to-the-right-of? { pos number } [ x ] dip > ;
-
-METHOD: move-left-by  { pos number } [ pos>> ] dip move-left-by  ;
-METHOD: move-right-by { pos number } [ pos>> ] dip move-right-by ;
-
-METHOD: above? { pos number } [ y ] dip > ;
-METHOD: below? { pos number } [ y ] dip < ;
-
-METHOD: move-by { pos sequence } '[ _ v+ ] change-pos drop ;
-
-METHOD: distance { pos pos } [ pos>> ] bi@ distance ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A class for objects with velocity. It inherits from pos. Hey, if
-! it's moving it has a position right? Unless it's some alternate universe...
-
-TUPLE: vel < pos vel ;
-
-: moving-up?   ( obj -- ? ) vel>> y 0 > ;
-: moving-down? ( obj -- ? ) vel>> y 0 < ;
-
-: step-size ( vel time -- dist ) [ vel>> ] dip v*n      ;
-: move-for  ( vel time --      ) dupd step-size move-by ;
-
-: reverse-horizontal-velocity ( vel -- ) vel>> [ x neg ] [ ] bi (x!) ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! The 'pos' slot indicates the lower left hand corner of the
-! rectangle. The 'dim' is holds the width and height.
-
-TUPLE: rectangle < pos dim ;
-
-METHOD: width  { rectangle } dim>> first  ;
-METHOD: height { rectangle } dim>> second ;
-
-METHOD: left   { rectangle }    x             ;
-METHOD: right  { rectangle } [ x ] [ width ] bi + ;
-METHOD: bottom { rectangle }    y             ;
-METHOD: top    { rectangle } [ y ] [ height ] bi + ;
-
-: bottom-left ( rectangle -- pos ) pos>> ;
-
-: center-x ( rectangle -- x ) [ left   ] [ width  2 / ] bi + ;
-: center-y ( rectangle -- y ) [ bottom ] [ height 2 / ] bi + ;
-
-: center ( rectangle -- seq ) [ center-x ] [ center-y ] bi 2array ;
-
-METHOD: to-the-left-of?  { pos rectangle } [ x ] [ left  ] bi* < ;
-METHOD: to-the-right-of? { pos rectangle } [ x ] [ right ] bi* > ;
-
-METHOD: below? { pos rectangle } [ y ] [ bottom ] bi* < ;
-METHOD: above? { pos rectangle } [ y ] [ top    ] bi* > ;
-
-METHOD: horizontal-interval { rectangle }
-  [ left ] [ right ] bi [a,b] ;
-
-METHOD: in-between-horizontally? { pos rectangle }
-  [ x ] [ horizontal-interval ] bi* interval-contains? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: extent left right bottom top ;
-
-METHOD: left   { extent } left>>   ;
-METHOD: right  { extent } right>>  ;
-METHOD: bottom { extent } bottom>> ;
-METHOD: top    { extent } top>>    ;
-
-METHOD: width  { extent } [ right>> ] [ left>>   ] bi - ;
-METHOD: height { extent } [ top>>   ] [ bottom>> ] bi - ;
-
-! METHOD: to-extent ( rectangle -- extent )
-!   { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave extent boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: to-the-left-of?  { sequence rectangle } [ x ] [ left ] bi* < ;
-METHOD: to-the-right-of? { sequence rectangle } [ x ] [ right ] bi* > ;
-
-METHOD: below? { sequence rectangle } [ y ] [ bottom ] bi* < ;
-METHOD: above? { sequence rectangle } [ y ] [ top    ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Some support for the' 'rect' class from math.geometry.rect'
-
-! METHOD: width  ( rect -- width  ) dim>> first  ;
-! METHOD: height ( rect -- height ) dim>> second ;
-
-! METHOD: left  ( rect -- left  ) loc>> x
-! METHOD: right ( rect -- right ) [ loc>> x ] [ width ] bi + ;
-
-! METHOD: to-the-left-of?  ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* < ;
-! METHOD: to-the-right-of? ( sequence rect -- ? ) [ x ] [ loc>> x ] bi* > ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-:: wrap ( POINT RECT -- POINT )
-  {
-      { [ POINT RECT to-the-left-of?  ] [ RECT right ] }
-      { [ POINT RECT to-the-right-of? ] [ RECT left  ] }
-      { [ t                           ] [ POINT x    ] }
-  }
-  cond
-
-  {
-      { [ POINT RECT below? ] [ RECT top    ] }
-      { [ POINT RECT above? ] [ RECT bottom ] }
-      { [ t                 ] [ POINT y     ] }
-  }
-  cond
-
-  2array ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: within? ( a b -- ? )
-
-METHOD: within? { pos rectangle }
-  {
-    [ left   to-the-right-of? ]
-    [ right  to-the-left-of?  ]
-    [ bottom above?           ]
-    [ top    below?           ]
-  }
-  2&& ;