module Wumpus.Basic.Kernel.Objects.Displacement
(
PointDisplace
, ThetaDisplace
, ThetaPointDisplace
, moveStart
, moveStartTheta
, moveStartThetaPoint
, moveStartThetaIncl
, displace
, displaceVec
, displaceH
, displaceV
, disp_up
, disp_down
, disp_left
, disp_right
, disp_up_left
, disp_up_right
, disp_down_left
, disp_down_right
, disp_north
, disp_south
, disp_east
, disp_west
, disp_northeast
, disp_northwest
, disp_southeast
, disp_southwest
, displaceParallel
, displacePerpendicular
, displaceOrtho
, adisp_north
, adisp_south
, adisp_east
, adisp_west
, adisp_northeast
, adisp_northwest
, adisp_southeast
, adisp_southwest
, centerRelative
, left_of
, right_of
, above_left_of
, above_right_of
, below_left_of
, below_right_of
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Objects.Anchors
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Core
import Data.AffineSpace
type PointDisplace u = Point2 u -> Point2 u
type ThetaDisplace = Radian -> Radian
type ThetaPointDisplace u = Radian -> Point2 u -> Point2 u
moveStart :: PointDisplace u -> LocQuery u a -> LocQuery u a
moveStart f ma = domMap1 f ma
moveStartTheta :: ThetaPointDisplace u
-> LocThetaQuery u a -> LocThetaQuery u a
moveStartTheta f cf = consCF $ \ctx ->
(\pt ang -> let f1 = runCF ctx cf in f1 (f ang pt) ang)
moveStartThetaPoint :: PointDisplace u
-> LocThetaQuery u a -> LocThetaQuery u a
moveStartThetaPoint f = domMap2 f id
moveStartThetaIncl :: ThetaDisplace -> LocThetaQuery u a -> LocThetaQuery u a
moveStartThetaIncl f = domMap2 id f
displace :: Num u => u -> u -> PointDisplace u
displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
displaceVec :: Num u => Vec2 u -> PointDisplace u
displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)
displaceH :: Num u => u -> PointDisplace u
displaceH dx (P2 x y) = P2 (x+dx) y
displaceV :: Num u => u -> PointDisplace u
displaceV dy (P2 x y) = P2 x (y+dy)
disp_up :: Num u => u -> PointDisplace u
disp_up = displaceV
disp_down :: Num u => u -> PointDisplace u
disp_down = displaceV . negate
disp_left :: Num u => u -> PointDisplace u
disp_left = displaceH . negate
disp_right :: Num u => u -> PointDisplace u
disp_right = displaceH
disp_up_left :: Num u => u -> PointDisplace u
disp_up_left u = displaceVec (V2 (u) u)
disp_up_right :: Num u => u -> PointDisplace u
disp_up_right u = displaceVec (V2 u u)
disp_down_left :: Num u => u -> PointDisplace u
disp_down_left u = displaceVec (V2 (u) (u))
disp_down_right :: Num u => u -> PointDisplace u
disp_down_right u = displaceVec (V2 u (u))
disp_north :: Num u => u -> PointDisplace u
disp_north = displaceV
disp_south :: Num u => u -> PointDisplace u
disp_south = displaceV . negate
disp_east :: Num u => u -> PointDisplace u
disp_east = displaceH
disp_west :: Num u => u -> PointDisplace u
disp_west = displaceH . negate
disp_northeast :: Floating u => u -> PointDisplace u
disp_northeast = displaceVec . avec (0.25 * pi)
disp_northwest :: Floating u => u -> PointDisplace u
disp_northwest = displaceVec . avec (0.75 * pi)
disp_southeast :: Floating u => u -> PointDisplace u
disp_southeast = displaceVec . avec (1.75 * pi)
disp_southwest :: Floating u => u -> PointDisplace u
disp_southwest = displaceVec . avec (1.25 * pi)
displaceParallel :: Floating u => u -> ThetaPointDisplace u
displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d
displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
displacePerpendicular d =
\theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d
displaceOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u
displaceOrtho (V2 x y) = \theta ->
displaceParallel x theta . displacePerpendicular y theta
adisp_north :: Floating u => u -> ThetaPointDisplace u
adisp_north = displacePerpendicular
adisp_south :: Floating u => u -> ThetaPointDisplace u
adisp_south = displacePerpendicular . negate
adisp_east :: Floating u => u -> ThetaPointDisplace u
adisp_east = displaceParallel
adisp_west :: Floating u => u -> ThetaPointDisplace u
adisp_west = displaceParallel . negate
adisp_northeast :: Floating u => u -> ThetaPointDisplace u
adisp_northeast d = \ang pt -> pt .+^ avec (ang + (0.25*pi)) d
adisp_northwest :: Floating u => u -> ThetaPointDisplace u
adisp_northwest d = \ang pt -> pt .+^ avec (ang + (0.75*pi)) d
adisp_southeast :: Floating u => u -> ThetaPointDisplace u
adisp_southeast d = \ang pt -> pt .+^ avec (ang + (1.75*pi)) d
adisp_southwest :: Floating u => u -> ThetaPointDisplace u
adisp_southwest d = \ang pt -> pt .+^ avec (ang + (1.25*pi)) d
centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> (Int,Int) -> a -> Query (Anchor u)
centerRelative coord a = snapmove coord >>= \v -> return $ center a .+^ v
right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
right_of = centerRelative (1,0)
left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
left_of = centerRelative ((1),0)
above_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
above_right_of = centerRelative (1,1)
below_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
below_right_of = centerRelative (1, (1))
above_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
above_left_of = centerRelative ((1),1)
below_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a)
=> a -> Query (Anchor u)
below_left_of = centerRelative ((1),(1))