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.
--
--------------------------------------------------------------------------------

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



-- | CatPrim could probably manage happily just being a
-- Primitive, but it is wrapped as a newtype...
--
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



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

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

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.
--
-- NOTE - currently HPrim has a phantom unit @u@, this is so 
-- trace drawings can have a unit type, but this may change as 
-- perhaps trace drawings don\'t benefit from having units.
--

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


hprimToList :: HPrim u -> [Primitive]
hprimToList = toListH . getHPrim


singleH :: CatPrim -> HPrim u
singleH CZero    = HPrim emptyH
singleH (Cat1 a) = HPrim $ wrapH a