wumpus-basic-0.18.0: src/Wumpus/Basic/Kernel/Objects/LocImage.hs

{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.LocImage
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- LocImage and LocGraphic types - these are functional types from the 
-- DrawingContext and start point to a graphic /primitive/.
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.LocImage
   (

     LocImage
   , LocGraphic

   , DLocImage
   , DLocGraphic

   , LocQuery

   , runLocImage
   , runLocQuery

   , promoteLoc
   , applyLoc
   , qpromoteLoc
   , qapplyLoc
   , zapLocQuery

   , emptyLocImage

   , moveStart
   , at

   -- * Composing LocImages
   , distrib
   , distribH 
   , distribV
   
   , duplicate
   , duplicateH
   , duplicateV


   )

   where

import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Objects.Basis


import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space
import Data.VectorSpace

import Control.Applicative
import Data.Monoid



-- | 'LocThetaImage' - function from  start point and 
-- DrawingContext to a polymorphic /answer/ and a graphic 
-- /primitive/ (PrimW).
--
newtype LocImage u a = LocImage { 
          getLocImage :: Point2 u -> Image u a }

type instance DUnit (LocImage u a) = u

type LocGraphic u = LocImage u (UNil u)


-- | Type specialized version of 'LocImage'.
--
type DLocImage a        = LocImage Double a

-- | Type specialized version of 'LocGraphic'.
--
type DLocGraphic        = LocGraphic Double 

newtype LocQuery u a = LocQuery { 
          getLocQuery :: Point2 u -> Query u a }

-- Functor

instance Functor (LocImage u) where
  fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt


instance Functor (LocQuery u) where
  fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt

-- Applicative

instance Applicative (LocImage u) where
  pure a    = LocImage $ \_  -> pure a
  mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt

instance Applicative (LocQuery u) where
  pure a    = LocQuery $ \_  -> pure a
  mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt
                                


-- Monad

instance Monad (LocImage u) where
  return a  = LocImage $ \_  -> return a
  ma >>= k  = LocImage $ \pt -> getLocImage ma pt >>= \ans -> 
                                  getLocImage (k ans) pt


instance Monad (LocQuery u) where
  return a  = LocQuery $ \_  -> return a
  ma >>= k  = LocQuery $ \pt -> getLocQuery ma pt >>= \ans -> 
                                  getLocQuery (k ans) pt


-- Monoid

instance Monoid a => Monoid (LocImage u a) where
  mempty          = pure mempty
  ma `mappend` mb = LocImage $ \pt -> 
                      getLocImage ma pt `mappend` getLocImage mb pt 

instance Monoid a => Monoid (LocQuery u a) where
  mempty          = pure mempty
  ma `mappend` mb = LocQuery $ \pt -> 
                      getLocQuery ma pt `mappend` getLocQuery mb pt 

-- DrawingCtxM

instance DrawingCtxM (LocImage u) where
  askDC           = LocImage $ \_  -> askDC
  asksDC fn       = LocImage $ \_  -> asksDC fn
  localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)

instance DrawingCtxM (LocQuery u) where
  askDC           = LocQuery $ \_  -> askDC
  asksDC fn       = LocQuery $ \_  -> asksDC fn
  localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)



  
instance Decorate LocImage where
  decorate ma mz = LocImage $ \pt -> 
                      getLocImage ma pt `decorate` getLocImage mz pt 

  elaborate ma f = LocImage $ \pt -> 
                      getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)

  obliterate ma mz = LocImage $ \pt -> 
                       getLocImage ma pt `obliterate` getLocImage mz pt 

  hyperlink xl ma = LocImage $ \pt -> 
                       hyperlink xl $ getLocImage ma pt 


runLocImage :: Point2 u -> DrawingContext -> LocImage u a -> PrimW u a
runLocImage pt ctx mf = runImage ctx (getLocImage mf pt)

runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a
runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)



promoteLoc ::  (Point2 u -> Image u a) -> LocImage u a
promoteLoc k = LocImage $ \pt -> k pt

applyLoc :: LocImage u a -> Point2 u -> Image u a
applyLoc mq pt = getLocImage mq pt


qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a
qpromoteLoc k = LocQuery $ \pt -> k pt

qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
qapplyLoc mq pt = getLocQuery mq pt


-- qapplyLoc :: LocQuery u a -> Point2 u -> Query u a
-- qapplyLoc mq pt = getLocQuery mq pt

-- | \"zero-apply\" a LocQuery.
--
zapLocQuery :: LocQuery u a -> Point2 u -> Image u a
zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a



-- Maybe there is need for a function line qapplyLoc of this type:
--
-- > blankLoc :: LocQuery u a -> Point2 u -> Image u a
-- 
-- This then means we can have monadic bind back for the notation:
--
-- > qapplyLocTheta (rellipsePath rx ry) pt ang  `bindQ` dcClosedPath style
-- 
-- becomes
--
-- > blankLoc (rellipsePath rx ry) pt ang >>= dcClosedPath style


--------------------------------------------------------------------------------
-- Affine instances

instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where
  rotate ang ma = promoteLoc $ \pt -> 
                     fmap (rotate ang) $ getLocImage ma (rotate ang pt)


instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
    RotateAbout (LocImage u a) where
  rotateAbout ang pt ma = promoteLoc $ \p0 -> 
                            fmap (rotateAbout ang pt) $ 
                              getLocImage ma (rotateAbout ang pt p0)


instance (Fractional u, Scale a) => Scale (LocImage u a) where
  scale sx sy ma = promoteLoc $ \pt -> 
                   fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)

instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) => 
    Translate (LocImage u a) where
  translate dx dy ma = promoteLoc $ \pt -> 
                         fmap (translate dx dy) $ 
                           getLocImage ma (translate dx dy pt)

--------------------------------------------------------------------------------


instance UConvert LocImage where
  uconvF = uconvLocImageF
  uconvZ = uconvLocImageZ

-- | Use this to convert 'LocGraphic' or 'LocImage' with Functor 
-- answer.
--
uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) 
               => LocImage u (t u) -> LocImage u1 (t u1)
uconvLocImageF ma = LocImage $ \pt -> 
    getFontSize >>= \sz -> 
    let ptu = uconvertF sz pt
    in uconvF $ getLocImage ma ptu



-- | Use this to convert 'LocImage' with unit-less answer.
--
uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) 
               => LocImage u a -> LocImage u1 a
uconvLocImageZ ma = LocImage $ \pt -> 
    getFontSize >>= \sz ->  
    let ptu = uconvertF sz pt
    in uconvZ $ getLocImage ma ptu


-- | Having /empty/ at the specific 'LocImage' type is useful.
-- 
emptyLocImage :: Monoid a => LocImage u a
emptyLocImage = mempty




-- Note - maybe this should just be an operator on LocImage...
--

moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a
moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1) 



infixr 1 `at`


-- | Downcast a 'LocImage' function by applying it to the supplied 
-- point, making an 'Image'. 
-- 
at :: LocImage u a -> Point2 u -> Image u a
at mf pt = getLocImage mf pt


--------------------------------------------------------------------------------
-- Combining LocImages 

-- LocImages have no concept of /border/ or /next/, so they can 
-- only be combined by manipulating the start point of successive
-- drawings.

-- 'oplus' gives super-imposition - Locimages are drawn at the same
-- start point.



distrib :: (Monoid a, InterpretUnit u) 
        => Vec2 u -> [LocImage u a]  -> LocImage u a
distrib _  []     = mempty
distrib v1 (x:xs) = promoteLoc $ \pt -> 
    go (applyLoc x pt) (pt .+^ v1) xs
  where
    go acc _  []     = acc
    go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as

distribH :: (Monoid a, InterpretUnit u) 
         => u -> [LocImage u a]  -> LocImage u a
distribH dx = distrib (hvec dx)

distribV :: (Monoid a, InterpretUnit u) 
         => u -> [LocImage u a]  -> LocImage u a
distribV dy = distrib (hvec dy)


-- | This is analogue to @replicate@ in the Prelude.
--
duplicate :: (Monoid a, InterpretUnit u) 
          => Int -> Vec2 u -> LocImage u a -> LocImage u a
duplicate n _ _   | n < 1 = mempty
duplicate n v img         = go img v (n-1)
  where
     go acc _  i | i < 1 = acc
     go acc v1 i         = let img1 = moveStart v1 img
                           in go (acc `mappend` img1) (v1 ^+^ v) (i-1)

duplicateH :: (Monoid a, InterpretUnit u) 
           => Int -> u -> LocImage u a -> LocImage u a
duplicateH n dx = duplicate n (hvec dx)

duplicateV :: (Monoid a, InterpretUnit u) 
           => Int -> u -> LocImage u a -> LocImage u a
duplicateV n dy = duplicate n (vvec dy)