wumpus-drawing-0.2.0: src/Wumpus/Drawing/Chains/Base.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Chains.Base
-- Copyright : (c) Stephen Tetley 2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Generate points in an iterated chain.
--
--------------------------------------------------------------------------------
module Wumpus.Drawing.Chains.Base
(
PointChain
, LocChain
, ConnectorChain
-- * Unrolling chains
, unchain
, unchainU
, unchainZip
, unchainZipWith
, unconnectorChain
-- * Building chains
, liftChainF
) where
import Wumpus.Basic.Kernel -- package: wumpus-basic
import Wumpus.Core -- package: wumpus-core
-- | A 'PointChain' is a list of points.
--
-- The list is typically inifinte so some attention must be given
-- to choosing a chain drawing function and using it appropriately.
--
type PointChain u = [Point2 u]
-- | A LocChain is a function from a starting point to a
-- 'PointChain'.
--
-- The list is often expected to be inifinte, but if it was a
-- Stream it would loose the ability to use list comprehensions.
--
type LocChain u = LocDrawingInfo u (PointChain u)
-- | A ConnectorChain is a function from a start- and end-point
-- to a 'Chain'.
--
type ConnectorChain u = ConnectorCF u (PointChain u)
-- | 'unchain' : @ unroll_count * alt_fun * draw_fun * chain -> LocCF @
--
-- Unroll the chain, applying the @draw_fun@ to each point
-- producing a LocCF (usually a 'LocGraphic'). If the chain does
-- not produce any points the @alt_fun@ is applied to the start
-- point.
--
-- Note - commonly a 'Chain' may be infinite, so it is only
-- unrolled a finite number of times - the @unrool_count@.
--
-- This function has a very general type signature commonly it
-- will be used at these types:
--
-- > unchain :: (Num u, OPlus a) =>
-- > Int -> LocImage u a -> LocImage u a -> LocChain u -> LocImage u a
-- >
-- > unchain :: Num u =>
-- > Int -> LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u
--
unchain :: (Num u, OPlus a)
=> Int
-> LocCF u (ImageAns u a)
-> LocCF u (ImageAns u a)
-> LocChain u
-> LocCF u (ImageAns u a)
unchain i alt _ _ | i <= 0 = alt
unchain i alt gf chn = promoteR1 $ \p0 ->
(chn `at` p0) >>= \pts -> case pts of
[] -> alt `at` p0
[x] -> gf `at` x
(x:xs) -> go x (take (i-1) xs)
where
go x [] = gf `at` x
go x (y:ys) = (gf `at` x) `oplus` go y ys
-- | 'unchain' : @ alt_fun * draw_fun * chain -> LocCF @
--
-- /Unsafe/ version of 'unchain' - this function assumes the chain
-- is finite which is not usually the case.
--
-- This function has a very general type signature commonly it
-- will be used at these type:
--
-- > unchainU :: (Num u, OPlus a) =>
-- > LocImage u a -> LocImage u a -> LocChain u -> LocImage u a
-- >
-- > unchainU :: Num u =>
-- > LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u
--
-- \*\* WARNING \*\* - if the chain is infinite this function will
-- not terminate.
--
unchainU :: (Num u, OPlus a)
=> LocCF u (ImageAns u a)
-> LocCF u (ImageAns u a)
-> LocChain u
-> LocCF u (ImageAns u a)
unchainU alt gf chn = promoteR1 $ \p0 ->
(chn `at` p0) >>= \pts -> case pts of
[] -> alt `at` p0
[x] -> gf `at` x
(x:xs) -> go x xs
where
go x [] = gf `at` x
go x (y:ys) = (gf `at` x) `oplus` go y ys
-- | 'unchainZip' : @ alt_fun * [draw_fun] * chain -> LocCF @
--
-- Unroll the chain, zipping the list of @draw_funs@ to the list
-- of points producing a LocCF (usually a 'LocGraphic'). If the
-- chain does not produce any points the @alt_fun@ is applied to
-- the start point.
--
-- This function has a very general type signature commonly it
-- will be used at these types:
--
-- > unchainZip :: (Num u, OPlus a) =>
-- > LocImage u a -> [LocImage u a] -> LocChain u -> LocImage u a
-- >
-- > unchainZip :: Num u =>
-- > LocGraphic u -> [LocGraphic u] -> LocChain u -> LocGraphic u
--
-- \*\* WARNING \*\* - the list of drawing functions should be
-- finite. If both the list of drawing functions and the chain are
-- infinite this function will not terminate.
--
unchainZip :: (Num u, OPlus a)
=> LocCF u (ImageAns u a)
-> [LocCF u (ImageAns u a)]
-> LocChain u
-> LocCF u (ImageAns u a)
unchainZip alt [] _ = promoteR1 $ \p0 -> alt `at` p0
unchainZip alt (g:gs) chn = promoteR1 $ \p0 ->
(chn `at` p0) >>= \pts -> case pts of
[] -> alt `at` p0
[x] -> g `at` x
(x:xs) -> go (g `at` x) gs xs
where
go acc _ [] = acc
go acc [] _ = acc
go acc (f:fs) (p:ps) = go (acc `oplus` (f `at` p)) fs ps
-- | 'unchainZipWith' : @ alt_fun * (a -> draw_fun) * [a] * chain -> LocCF @
--
-- Version of 'unchainZip' where the list is some data rather
-- than a drawing function and the @(a -> draw_fun)@ builder is
-- applied to each element as part of the unrolling.
--
-- Approximately this function is a @zipWith@ to the @zip@ of
-- @unchainZip@.
--
-- This function has a very general type signature commonly it
-- will be used at these type:
--
-- > unchainZipWith :: (Num u, OPlus a) =>
-- > LocImage u a -> (s -> LocImage u a) -> [s] -> LocChain u -> LocImage u a
-- >
-- > unchainZipWith :: Num u =>
-- > LocGraphic u -> (s -> LocGraphic u) -> [s] -> LocChain u -> LocGraphic u
--
-- \*\* WARNING \*\* - if the chain and list are infinite this
-- function will not terminate.
--
unchainZipWith :: (Num u, OPlus a)
=> LocCF u (ImageAns u a)
-> (s -> LocCF u (ImageAns u a))
-> [s]
-> LocChain u
-> LocCF u (ImageAns u a)
unchainZipWith alt _ [] _ = promoteR1 $ \p0 -> alt `at` p0
unchainZipWith alt mkGF (s:ss) chn = promoteR1 $ \p0 ->
(chn `at` p0) >>= \pts -> case pts of
[] -> alt `at` p0
[x] -> mkGF s `at` x
(x:xs) -> go (mkGF s `at` x) ss xs
where
go acc _ [] = acc
go acc [] _ = acc
go acc (t:ts) (p:ps) = go (acc `oplus` (mkGF t `at` p)) ts ps
-- | 'unconnectorChain' : @ alt_fun * draw_fun * conn_chain -> ConnectorCF @
--
-- Unroll the chain produced between the implicit start and end
-- points. Apply the @draw_fun@ to each point producing a
-- ConnectorCF (usually a 'ConnectorGraphic'). If the chain does
-- not produce any points, the @alt_fun@ is applied to the start
-- and end points.
--
-- This function has a very general type signature commonly it
-- will be used at these types:
--
-- > unconnectorChain :: (Num u, OPlus a) =>
-- > ConnectorImage u a -> LocImage u a -> ConnectorChain u -> ConnectorImage u a
-- >
-- > unconnectorChain :: Num u =>
-- > ConnectorGraphic u -> LocGraphic u -> ConnectorChain u -> ConnectorGraphic u
--
--
unconnectorChain :: (Num u, OPlus a)
=> ConnectorCF u (ImageAns u a)
-> LocCF u (ImageAns u a)
-> ConnectorChain u
-> ConnectorCF u (ImageAns u a)
unconnectorChain alt gf cchn = promoteR2 $ \p0 p1 ->
(connect cchn p0 p1) >>= \pts -> case pts of
[] -> connect alt p0 p1
[x] -> gf `at` x
(x:xs) -> go (gf `at` x) xs
where
go acc [] = acc
go acc (p:ps) = go (acc `oplus` (gf `at` p)) ps
--------------------------------------------------------------------------------
-- | 'liftChainF' : @ (point -> [point]) -> LocChain @
--
-- Lift a pure chain generating function inot a 'LocChain'.
--
liftChainF :: (Point2 u -> PointChain u) -> LocChain u
liftChainF fn = promoteR1 $ \pt -> return $ fn pt