wumpus-basic-0.24.0: src/Wumpus/Basic/Kernel/Drawing/Chain.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Kernel.Drawing.Chain
-- Copyright : (c) Stephen Tetley 2011-2012
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : highly unstable
-- Portability : GHC
--
-- Chaining LocGraphics.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Kernel.Drawing.Chain
(
GenChain
, Chain
, DChain
, ChainScheme(..)
, runGenChain
, evalGenChain
, execGenChain
, stripGenChain
, runChain
, runChain_
, chain1
, chainSkip_
, chainMany
, chainReplicate
, chainCount
, iterationScheme
, sequenceScheme
, catTrailScheme
, countingScheme
, horizontalScheme
, verticalScheme
, rowwiseTableScheme
, columnwiseTableScheme
, distribRowwiseTable
, duplicateRowwiseTable
, distribColumnwiseTable
, duplicateColumnwiseTable
, radialChainScheme
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Drawing.Basis
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Displacement
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Basic.Kernel.Objects.Trail
import Wumpus.Core -- package: wumpus-core
import Control.Applicative
import Data.Monoid
newtype GenChain st u a = GenChain
{ getGenChain :: DrawingContext -> DPoint2 -> ChainSt st u
-> (a, DPoint2, ChainSt st u, CatPrim) }
type instance DUnit (GenChain st u a) = u
type instance UState (GenChain st u a) = st
type Chain u a = GenChain () u a
type DChain a = Chain Double a
-- | scheme_start is a function from the origin to state.
--
-- For instance, we might want to cache the origin - this would
-- not be possible if start was just a pure @cst@ value.
--
data ChainScheme u = forall cst. ChainScheme
{ chain_init :: Point2 u -> cst
, chain_step :: Point2 u -> cst -> (Point2 u,cst)
}
type instance DUnit (ChainScheme u) = u
data ChainSt st u = forall cst. ChainSt
{ chain_count :: Int
, chain_st :: cst
, chain_next :: Point2 u -> cst -> (Point2 u,cst)
, chain_user_state :: st
}
type instance DUnit (ChainSt st u) = u
-- Functor
instance Functor (GenChain st u) where
fmap f ma = GenChain $ \ctx pt s ->
let (a,p1,s1,w) = getGenChain ma ctx pt s in (f a, p1, s1, w)
-- Applicative
instance Applicative (GenChain st u) where
pure a = GenChain $ \_ pt s -> (a, pt, s, mempty)
mf <*> ma = GenChain $ \ctx pt s ->
let (f,p1,s1,w1) = getGenChain mf ctx pt s
(a,p2,s2,w2) = getGenChain ma ctx p1 s1
in (f a, p2, s2, w1 `mappend` w2)
-- Monad
instance Monad (GenChain st u) where
return a = GenChain $ \_ pt s -> (a, pt, s, mempty)
ma >>= k = GenChain $ \ctx pt s ->
let (a,p1,s1,w1) = getGenChain ma ctx pt s
(b,p2,s2,w2) = (getGenChain . k) a ctx p1 s1
in (b, p2, s2, w1 `mappend` w2)
-- DrawingCtxM
instance DrawingCtxM (GenChain st u) where
askDC = GenChain $ \ctx pt s -> (ctx, pt, s, mempty)
asksDC fn = GenChain $ \ctx pt s -> (fn ctx, pt, s, mempty)
localize upd ma = GenChain $ \ctx pt s -> getGenChain ma (upd ctx) pt s
-- UserStateM
instance UserStateM (GenChain st u) where
getState = GenChain $ \_ pt s@(ChainSt _ _ _ ust) ->
(ust, pt, s, mempty)
setState ust = GenChain $ \_ pt (ChainSt i a b _) ->
((), pt, ChainSt i a b ust, mempty)
updateState upd = GenChain $ \_ pt (ChainSt i a b ust) ->
((), pt, ChainSt i a b (upd ust), mempty)
-- LocationM
instance InterpretUnit u => LocationM (GenChain st u) where
location = GenChain $ \ctx pt s ->
let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty)
-- Monoid
instance Monoid a => Monoid (GenChain st u a) where
mempty = GenChain $ \_ pt s -> (mempty, pt, s, mempty)
ma `mappend` mb = GenChain $ \ctx pt s ->
let (a,p1,s1,w1) = getGenChain ma ctx pt s
(b,p2,s2,w2) = getGenChain mb ctx p1 s1
in (a `mappend` b, p2, s2, w1 `mappend` w2)
--------------------------------------------------------------------------------
-- Run functions
runGenChain :: InterpretUnit u
=> ChainScheme u -> st -> GenChain st u a -> LocImage u (a,st)
runGenChain (ChainScheme start step) ust ma = promoteLoc $ \pt ->
askDC >>= \ctx ->
let st_zero = ChainSt { chain_count = 0
, chain_st = start pt
, chain_next = step
, chain_user_state = ust }
dpt = normalizeF (dc_font_size ctx) pt
(a,_,s1,w1) = getGenChain ma ctx dpt st_zero
in replaceAns (a, chain_user_state s1) $ primGraphic w1
-- | Forget the user state LocImage, just return the /answer/.
--
evalGenChain :: InterpretUnit u
=> ChainScheme u -> st -> GenChain st u a -> LocImage u a
evalGenChain cscm st ma = fmap fst $ runGenChain cscm st ma
-- | Forget the /answer/, just return the user state.
--
execGenChain :: InterpretUnit u
=> ChainScheme u -> st -> GenChain st u a -> LocImage u st
execGenChain cscm st ma = fmap snd $ runGenChain cscm st ma
stripGenChain :: InterpretUnit u
=> ChainScheme u -> st -> GenChain st u a -> LocQuery u (a,st)
stripGenChain cscm st ma = stripLocImage $ runGenChain cscm st ma
runChain :: InterpretUnit u
=> ChainScheme u -> Chain u a -> LocImage u a
runChain cscm ma = evalGenChain cscm () ma
runChain_ :: InterpretUnit u
=> ChainScheme u -> Chain u a -> LocGraphic u
runChain_ cscm ma = ignoreAns $ runChain cscm ma
--------------------------------------------------------------------------------
-- Operations
-- | Demand a point on the Chain and draw the LocImage
-- at it.
--
chain1 :: InterpretUnit u
=> LocImage u a -> GenChain st u a
chain1 gf = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) ->
let upt = dinterpF (dc_font_size ctx) pt
(a,w1) = runImage ctx $ applyLoc gf upt
(pt1,st1) = sf upt s0
dpt1 = normalizeF (dc_font_size ctx) pt1
new_st = ChainSt { chain_count = i0 + 1
, chain_st = st1
, chain_next = sf
, chain_user_state = ust }
in (a, dpt1, new_st, w1)
-- | Demand the next position, but draw nothing.
--
chainSkip_ :: InterpretUnit u => GenChain st u ()
chainSkip_ = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) ->
let upt = dinterpF (dc_font_size ctx) pt
(pt1,st1) = sf upt s0
dpt1 = normalizeF (dc_font_size ctx) pt1
new_st = ChainSt { chain_count = i0 + 1
, chain_st = st1
, chain_next = sf
, chain_user_state = ust }
in ((), dpt1, new_st, mempty)
-- | Chain a list of images, each demanding a succesive start
-- point.
--
chainMany :: InterpretUnit u
=> [LocImage u a] -> GenChain st u (UNil u)
chainMany = ignoreAns . mapM_ chain1
-- | Replicate a LocImage @n@ times along a Chain.
--
chainReplicate :: InterpretUnit u
=> Int -> LocImage u a -> GenChain st u (UNil u)
chainReplicate n = chainMany . replicate n
-- | Return the count of chain steps.
--
chainCount :: GenChain st u Int
chainCount = GenChain $ \_ dpt st@(ChainSt i _ _ _) -> (i, dpt, st, mempty)
--------------------------------------------------------------------------------
-- Schemes
-- | General scheme - iterate the next point with the supplied
-- function.
--
iterationScheme :: (Point2 u -> Point2 u) -> ChainScheme u
iterationScheme fn = ChainScheme { chain_init = const ()
, chain_step = \pt _ -> (fn pt, ())
}
-- | General scheme - displace successively by the elements of the
-- list of vectors.
--
-- Note - the list is cycled to make the chain infinite.
--
sequenceScheme :: Num u => [Vec2 u] -> ChainScheme u
sequenceScheme [] = error "sequenceScheme - empty list."
sequenceScheme vs = ChainScheme { chain_init = const $ cycle vs
, chain_step = step
}
where
step _ [] = error "sequenceScheme - unreachable, cycled."
step pt (w:ws) = (displace w pt, ws)
-- | Derive a ChainScheme from a CatTrail.
--
-- Note - this iterates the control points of curves, it does not
-- iterate points on the curve.
--
catTrailScheme :: Num u => CatTrail u -> ChainScheme u
catTrailScheme = sequenceScheme . linear . destrCatTrail
where
linear (TLine v0 :xs) = v0 : linear xs
linear (TCurve v0 v1 v2 :xs) = v0 : v1 : v2 : linear xs
linear [] = []
-- | Build an (infinite) ChainScheme for a prefix list of counted
-- schemes and a final scheme that runs out to infinity.
--
countingScheme :: [(Int, ChainScheme u)] -> ChainScheme u -> ChainScheme u
countingScheme [] rest = rest
countingScheme (x:xs) rest = chainPrefix x (countingScheme xs rest)
-- | Helper - complicated...
--
chainPrefix :: (Int, ChainScheme u) -> ChainScheme u -> ChainScheme u
chainPrefix (ntimes, ChainScheme astart astep) rest@(ChainScheme bstart bstep)
| ntimes < 1 = rest
| otherwise = ChainScheme { chain_init = start, chain_step = next }
where
start pt = (astart pt,ntimes, bstart pt)
next pt (ast,n,bst)
| n > 0 = let (p2,ast1) = astep pt ast in (p2, (ast1,n-1,bst))
| n == 0 = let bst1 = bstart pt
(p2,bst2) = bstep pt bst1
in (p2, (ast,(-1),bst2))
| otherwise = let (p2,bst1) = bstep pt bst in (p2,(ast, (-1), bst1))
horizontalScheme :: Num u => u -> ChainScheme u
horizontalScheme dx = iterationScheme (displace (hvec dx))
verticalScheme :: Num u => u -> ChainScheme u
verticalScheme dy = iterationScheme (displace (vvec dy))
-- | Outer and inner steppers.
--
scStepper :: PointDisplace u -> Int -> PointDisplace u
-> ChainScheme u
scStepper outF n innF =
ChainScheme { chain_init = start, chain_step = step }
where
start pt = (pt,1)
step pt (ogin,i) | i < n = (innF pt, (ogin, i+1))
| otherwise = let o1 = outF ogin
in (o1, (o1,1))
-- | Generate a tabular scheme going rowwise (left-to-right) and
-- downwards.
--
-- TODO - should probably account for the initial position...
--
rowwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u
rowwiseTableScheme num_cols (col_width,row_height) =
scStepper downF num_cols rightF
where
downF = displace $ vvec $ negate row_height
rightF = displace $ hvec col_width
-- | Generate a tabular scheme going columwise (top-to-bottom)
-- and rightwards.
--
-- TODO - should probably account for the initial position...
--
columnwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u
columnwiseTableScheme num_rows (col_width,row_height) =
scStepper rightF num_rows downF
where
downF = displace $ vvec $ negate row_height
rightF = displace $ hvec col_width
distribRowwiseTable :: (Monoid a, InterpretUnit u)
=> Int -> (u,u) -> [LocImage u a] -> LocImage u a
distribRowwiseTable num_cols dims gs = fmap mconcat $
runChain (rowwiseTableScheme num_cols dims) $ mapM chain1 gs
duplicateRowwiseTable :: (Monoid a, InterpretUnit u)
=> Int -> Int -> (u,u) -> LocImage u a -> LocImage u a
duplicateRowwiseTable i num_cols dims gf =
distribRowwiseTable num_cols dims (replicate i gf)
distribColumnwiseTable :: (Monoid a, InterpretUnit u)
=> Int -> (u,u) -> [LocImage u a] -> LocImage u a
distribColumnwiseTable num_rows dims gs = fmap mconcat $
runChain (columnwiseTableScheme num_rows dims) $ mapM chain1 gs
duplicateColumnwiseTable :: (Monoid a, InterpretUnit u)
=> Int -> Int -> (u,u) -> LocImage u a -> LocImage u a
duplicateColumnwiseTable i num_rows dims gf =
distribColumnwiseTable num_rows dims (replicate i gf)
-- | TODO - account for CW CCW or just rely on +ve -ve angles?...
--
radialChainScheme :: Floating u
=> u -> Radian -> Radian -> ChainScheme u
radialChainScheme radius angstart angi =
ChainScheme { chain_init = start, chain_step = step }
where
start pt = let ogin = displace (avec angstart (-radius)) pt
in (ogin, angstart)
step _ (ogin,ang) = let ang_next = ang + angi
pt = displace (avec ang_next radius) ogin
in (pt, (ogin, ang_next))
-- radialChain is convoluted because first point is not the
-- circle center but a point on the circumference. Also the next
-- step iterates the (constant) origin rather than the previous
-- point.