WrappedPrimitive.hs

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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Base.WrappedPrimitive
-- Copyright   :  (c) Stephen Tetley 2010-2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Wrapped versions of the @Primitive@ type from Wumpus-Core.
--
-- This file is essentially /internal/ to Wumpus-Basic.
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Base.WrappedPrimitive
  (


  -- * Primitives
    CatPrim
  , prim1
  , cpmap

  , HPrim
  , hprimToList
  , singleH

  ) where

import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Utils.HList

import Wumpus.Core                      -- package: wumpus-core


import Data.Monoid



-- | A wrapped version of 'Primitive' from Wumpus-Core that 
-- supports Monoid.
--
-- This type is essentially internal to Wumpus-Basic.
--
data CatPrim = CZero
             | Cat1 Primitive

type instance DUnit CatPrim = Double

instance OPlus CatPrim where
  CZero  `oplus` b      = b
  a      `oplus` CZero  = a
  Cat1 a `oplus` Cat1 b = Cat1 $ a `primCat` b


instance Monoid CatPrim where
  mempty                  = CZero
  CZero  `mappend` b      = b
  a      `mappend` CZero  = a
  Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b

  mconcat []      = mempty
  mconcat (a:as)  = step a as
    where
      step ac []     = ac
      step ac (x:xs) = step (ac `mappend` x) xs


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

instance Rotate CatPrim where
  rotate _   CZero              = CZero
  rotate ang (Cat1 a)           = Cat1 $ rotate ang a

instance RotateAbout CatPrim where
  rotateAbout _   _  CZero      = CZero
  rotateAbout ang pt (Cat1 a)   = Cat1 $ rotateAbout ang pt a

instance Scale CatPrim where
  scale _  _  CZero             = CZero
  scale sx sy (Cat1 a)          = Cat1 $ scale sx sy a

instance Translate CatPrim where
  translate _  _  CZero         = CZero
  translate dx dy (Cat1 a)      = Cat1 $ translate dx dy a


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

prim1 :: Primitive -> CatPrim 
prim1 = Cat1


-- | Map 
cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim
cpmap _ CZero    = CZero
cpmap f (Cat1 a) = Cat1 $ f a

--------------------------------------------------------------------------------
-- Lists of primitives...


-- | Graphics objects, even simple ones (line, arrow, dot) might 
-- need more than one primitive (path or text label) for their
-- construction. Hence, the primary representation that all the 
-- others are built upon must support /concatenation/ of 
-- primitives. 
--
-- Wumpus-Core has a type Picture - made from one or more 
-- Primitives - but Pictures include support for affine frames. 
-- For drawing many simple graphics (dots, connector lines...) 
-- that do not need individual affine transformations this is a 
-- penalty. A list of Primitives is therefore more suitable 
-- representation, and a Hughes list which supports
-- efficient concatenation is wise.
--
-- This type is essentially internal to Wumpus-Basic.
-- 
newtype HPrim u = HPrim { getHPrim :: H Primitive }

-- Note - only a Monoid instance for HPrim - they cannot be 
-- shown, fmapped etc.

instance Monoid (HPrim u) where
  mempty          = HPrim emptyH
  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb

  mconcat []      = mempty
  mconcat (a:as)  = step a as
    where
      step ac []     = ac
      step ac (x:xs) = step (ac `mappend` x) xs


-- | Extract the internal list of 'Primitive' from a 'HPrim'.
--
hprimToList :: HPrim u -> [Primitive]
hprimToList = toListH . getHPrim


-- | Form a 'HPrim' from a 'CatPrim'.
--
singleH :: CatPrim -> HPrim u
singleH CZero    = HPrim emptyH
singleH (Cat1 a) = HPrim $ wrapH a