From 1222fdf55b76c1880151dbb74e5f1cb03bf85870 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 29 Nov 2008 12:10:06 -0600 Subject: [PATCH] flatland: Library for two dimensional worlds --- extra/flatland/flatland.factor | 178 +++++++++++++++++++++++++++++++++ 1 file changed, 178 insertions(+) create mode 100644 extra/flatland/flatland.factor diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor new file mode 100644 index 0000000000..a33da32908 --- /dev/null +++ b/extra/flatland/flatland.factor @@ -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 ; + +METHOD: x ( -- x ) pos>> first ; +METHOD: y ( -- y ) pos>> second ; + +METHOD: (x!) ( number -- ) pos>> set-first ; +METHOD: (y!) ( number -- ) pos>> set-second ; + +METHOD: to-the-left-of? ( number -- ? ) [ x ] dip < ; +METHOD: to-the-right-of? ( number -- ? ) [ x ] dip > ; + +METHOD: move-left-by ( number -- ) [ pos>> ] dip move-left-by ; +METHOD: move-right-by ( number -- ) [ pos>> ] dip move-right-by ; + +METHOD: above? ( number -- ? ) [ y ] dip > ; +METHOD: below? ( number -- ? ) [ y ] dip < ; + +METHOD: move-by ( sequence -- ) '[ _ v+ ] change-pos drop ; + +METHOD: distance ( -- dist ) [ pos>> ] bi@ distance ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! A class for objects with velocity. It inherits from . Hey, if +! it's moving it has a position right? Unless it's some alternate universe... + +TUPLE: < 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: < dim ; + +METHOD: width ( -- width ) dim>> first ; +METHOD: height ( -- height ) dim>> second ; + +METHOD: left ( -- x ) x ; +METHOD: right ( -- x ) \\ x width bi + ; +METHOD: bottom ( -- y ) y ; +METHOD: top ( -- 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? ( -- ? ) \\ x left bi* < ; +METHOD: to-the-right-of? ( -- ? ) \\ x right bi* > ; + +METHOD: below? ( -- ? ) \\ y bottom bi* < ; +METHOD: above? ( -- ? ) \\ y top bi* > ; + +METHOD: horizontal-interval ( -- interval ) + \\ left right bi [a,b] ; + +METHOD: in-between-horizontally? ( -- ? ) + \\ x horizontal-interval bi* interval-contains? ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: left right bottom top ; + +METHOD: left ( -- left ) left>> ; +METHOD: right ( -- right ) right>> ; +METHOD: bottom ( -- bottom ) bottom>> ; +METHOD: top ( -- top ) top>> ; + +METHOD: width ( -- width ) \\ right>> left>> bi - ; +METHOD: height ( -- height ) \\ top>> bottom>> bi - ; + +! METHOD: to-extent ( -- ) +! { [ left>> ] [ right>> ] [ bottom>> ] [ top>> ] } cleave boa ; +