diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor deleted file mode 100644 index 5b68158f1a..0000000000 --- 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&& ;