steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

flatland: Library for two dimensional worlds

db4
Eduardo Cavazos 2008-11-29 12:10:06 -06:00
parent 536b412d2e
commit 1222fdf55b
1 changed files with 178 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
extra/flatland/flatland.factor Normal file
View File

@ -0,0 +1,178 @@
USING: accessors arrays fry kernel math math.vectors sequences
math.intervals
multi-methods
combinators.cleave.enhanced
multi-method-syntax ;
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 -- x ) first ;
METHOD: y ( sequence -- y ) second ;
METHOD: (x!) ( number sequence -- ) set-first ;
METHOD: (y!) ( number sequence -- ) set-second ;
METHOD: width ( sequence -- width ) first ;
METHOD: height ( sequence -- height ) 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 -- dist ) v- norm ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A class for objects with a position
TUPLE: <pos> pos ;
METHOD: x ( <pos> -- x ) pos>> first ;
METHOD: y ( <pos> -- y ) 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> -- dist ) [ 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> -- width ) dim>> first ;
METHOD: height ( <rectangle> -- height ) dim>> second ;
METHOD: left ( <rectangle> -- x ) x ;
METHOD: right ( <rectangle> -- x ) \\ x width bi + ;
METHOD: bottom ( <rectangle> -- y ) y ;
METHOD: top ( <rectangle> -- y ) \\ 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> -- interval )
\\ 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 ) left>> ;
METHOD: right ( <extent> -- right ) right>> ;
METHOD: bottom ( <extent> -- bottom ) bottom>> ;
METHOD: top ( <extent> -- top ) top>> ;
METHOD: width ( <extent> -- width ) \\ right>> left>> bi - ;
METHOD: height ( <extent> -- height ) \\ top>> bottom>> bi - ;
! METHOD: to-extent ( <rectangle> -- <extent> )
! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave <extent> boa ;