Shape.hs

{-# LANGUAGE BangPatterns
           , CPP
           , FlexibleInstances
           , TypeFamilies, MultiParamTypeClasses, FlexibleContexts
           , TypeOperators #-}

-- | 'Shape's are similar to what you could found in @repa@. 'Shape' are used
-- both for indexes and shapes.
--
-- To create a shape/index, use the 'ix1', 'ix2', 'ix3' ... helpers :
--
-- > size = ix2 200 100
--
-- To pull values from a shape, use the 'Z' and ':.' constructors :
--
-- > Z :. h :. w = size
module Vision.Primitive.Shape (
      Shape (..), Z (..), (:.) (..)
    -- * Common dimensions.
    , DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9
    -- * Helpers
    , ix1, ix2, ix3, ix4, ix5, ix6, ix7, ix8, ix9
) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
import Data.Word
#endif

import Foreign.Storable (Storable (..))
import Foreign.Ptr (castPtr, plusPtr)
import Data.Vector.Unboxed (Unbox)
import qualified Data.Vector.Unboxed as VU
import Data.Vector.Generic.Mutable (MVector(..))
import qualified Data.Vector.Generic as VG

-- | Class of types that can be used as array shapes and indices.
class Eq sh => Shape sh where
    -- | Gets the number of dimensions in a shape.
    shapeRank :: sh -> Int

    -- | Gets the total number of elements in an array of this shape.
    shapeLength :: sh -> Int

    -- | Gives the first index of an array.
    shapeZero :: sh

    -- | Gives the successor of an index, given the shape of the array.
    shapeSucc :: sh -- ^ Shape of the array.
              -> sh -- ^ Index.
              -> sh

    -- | Convert an index into its equivalent flat, linear, row-major version.
    toLinearIndex :: sh  -- ^ Shape of the array.
                  -> sh  -- ^ Index into the array.
                  -> Int

    -- | Inverse of `toLinearIndex`.
    fromLinearIndex :: sh  -- ^ Shape of the array.
                    -> Int -- ^ Index into linear representation.
                    -> sh

    -- | Return the ascending list of indexes for the given shape.
    shapeList :: sh -> [sh]

    -- | Check whether an index is within a given shape.
    inShape :: sh   -- ^ Shape of the array.
            -> sh   -- ^ Index to check for.
            -> Bool

-- | An index of dimension zero.
data Z = Z deriving (Show, Read, Eq, Ord)

-- | Our index type, used for both shapes and indices.
infixl 3 :.
data tail :. head = !tail :. !head
    deriving (Show, Read, Eq, Ord)

newtype instance VU.MVector s Z = MV_Z (VU.MVector s ())
newtype instance VU.Vector    Z = V_Z  (VU.Vector    ())

instance MVector VU.MVector Z where
  {-# INLINE basicLength #-}
  basicLength (MV_Z v)          = basicLength v
  basicUnsafeSlice s e (MV_Z v) = MV_Z $ basicUnsafeSlice s e v
  basicUnsafeRead (MV_Z v) i    = basicUnsafeRead  v i >>= \_ -> return Z
  basicUnsafeNew   i            = MV_Z `fmap` basicUnsafeNew i
  basicUnsafeWrite (MV_Z v) i a = a `seq` basicUnsafeWrite v i ()
  basicOverlaps (MV_Z a) (MV_Z b) = basicOverlaps a b

instance VG.Vector VU.Vector Z where
  {-# INLINE basicLength #-}
  basicLength (V_Z v)          = VG.basicLength v
  basicUnsafeFreeze (MV_Z v)   = V_Z `fmap` VG.basicUnsafeFreeze v
  basicUnsafeThaw (V_Z v)      = MV_Z `fmap` VG.basicUnsafeThaw v
  basicUnsafeSlice s e (V_Z v) = V_Z $ VG.basicUnsafeSlice s e v
  basicUnsafeIndexM (V_Z v) i  = VG.basicUnsafeIndexM v i >>= \_ -> return Z

instance Unbox Z

newtype instance VU.MVector s (t :. h) = MV_Dim (VU.MVector s (t , h))
newtype instance VU.Vector    (t :. h) = V_Dim  (VU.Vector    (t , h))

instance (Unbox t, Unbox h) => MVector VU.MVector (t :. h) where
  {-# INLINE basicLength #-}
  basicLength (MV_Dim v)          = basicLength v
  basicUnsafeSlice s e (MV_Dim v) = MV_Dim $ basicUnsafeSlice s e v
  basicUnsafeRead (MV_Dim v) i    = pairToPoint `fmap` basicUnsafeRead  v i
  basicUnsafeNew   i              = MV_Dim `fmap` basicUnsafeNew i
  basicUnsafeWrite (MV_Dim v) i a = basicUnsafeWrite v i (pointToPair a)
  basicOverlaps (MV_Dim a) (MV_Dim b) = basicOverlaps a b

instance (Unbox t, Unbox h) => VG.Vector VU.Vector (t :. h) where
  {-# INLINE basicLength #-}
  basicLength (V_Dim v) = VG.basicLength v
  basicUnsafeFreeze (MV_Dim v)   = V_Dim `fmap` VG.basicUnsafeFreeze v
  basicUnsafeThaw (V_Dim v)      = MV_Dim `fmap` VG.basicUnsafeThaw v
  basicUnsafeSlice s e (V_Dim v) = V_Dim $ VG.basicUnsafeSlice s e v
  basicUnsafeIndexM (V_Dim v) i  = pairToPoint `fmap` VG.basicUnsafeIndexM v i

instance (Unbox t, Unbox h) => Unbox (t :. h)

pairToPoint :: (tail, head) -> tail :. head
pairToPoint (a,b) = a :. b

pointToPair :: tail :. head -> (tail, head)
pointToPair (a :. b) = (a,b)


-- Common dimensions.
type DIM0 = Z
type DIM1 = DIM0 :. Int
type DIM2 = DIM1 :. Int
type DIM3 = DIM2 :. Int
type DIM4 = DIM3 :. Int
type DIM5 = DIM4 :. Int
type DIM6 = DIM5 :. Int
type DIM7 = DIM6 :. Int
type DIM8 = DIM7 :. Int
type DIM9 = DIM8 :. Int

instance Shape Z where
    shapeRank Z = 0
    {-# INLINE shapeRank #-}

    shapeLength Z = 1
    {-# INLINE shapeLength #-}

    shapeZero = Z
    {-# INLINE shapeZero #-}

    shapeSucc _ _= Z
    {-# INLINE shapeSucc #-}

    toLinearIndex Z _ = 0
    {-# INLINE toLinearIndex #-}

    fromLinearIndex Z _ = Z
    {-# INLINE fromLinearIndex #-}

    -- | Returns every shape in ascending order
    --
    -- > shapeList sh = map fromLinearIndex [1..shapeLength sh - 1]
    shapeList Z = [Z]
    {-# INLINE shapeList #-}

    inShape Z Z = True
    {-# INLINE inShape #-}

instance Storable Z where
    sizeOf _ = 0
    {-# INLINE sizeOf #-}

    alignment _ = 0
    {-# INLINE alignment #-}

    peek _ = return Z
    {-# INLINE peek #-}

    poke _ _ = return ()
    {-# INLINE poke #-}

instance Shape sh => Shape (sh :. Int) where
    shapeRank (sh  :. _) = shapeRank sh + 1
    {-# INLINE shapeRank #-}

    shapeLength (sh :. n) = shapeLength sh * n
    {-# INLINE shapeLength #-}

    shapeZero = shapeZero :. 0
    {-# INLINE shapeZero #-}

    shapeSucc (sh :. n) (sh' :. ix)
        | ix' >= n  = shapeSucc sh sh' :. 0
        | otherwise = sh'              :. ix'
      where
        !ix' = ix + 1
    {-# INLINE shapeSucc #-}

    toLinearIndex (sh :. n) (sh' :. ix) =   toLinearIndex sh sh' * n
                                          + ix
    {-# INLINE toLinearIndex #-}

    fromLinearIndex (sh :. n) ix
        | shapeRank sh == 0 = fromLinearIndex sh 0 :. ix
        | otherwise         = let (q, r) = ix `quotRem` n
                              in fromLinearIndex sh q :. r
    {-# INLINE fromLinearIndex #-}

    shapeList (sh :. n) = [ sh' :. i | sh' <- shapeList sh, i <- [0..n-1] ]
    {-# INLINE shapeList #-}

    inShape (sh :. n) (sh' :. ix) = word ix < word n && inShape sh sh'
    {-# INLINE inShape #-}

instance Storable sh => Storable (sh :. Int) where
    sizeOf ~(sh :. _) = sizeOf (undefined :: Int) + sizeOf sh
    {-# INLINE sizeOf #-}

    alignment _ = alignment (undefined :: Int)
    {-# INLINE alignment #-}

    peek !ptr = do
        let !ptr' = castPtr ptr
        (:.) <$> peek (castPtr $! ptr' `plusPtr` 1) <*> peek ptr'
    {-# INLINE peek #-}

    poke !ptr (sh :. n) = do
        let !ptr' = castPtr ptr
        poke (castPtr $! ptr' `plusPtr` 1) sh >> poke ptr' n
    {-# INLINE poke #-}

-- | Helper for index construction.
--
-- Use this instead of explicit constructors like @(Z :. (x :: Int))@
-- The this is sometimes needed to ensure that 'x' is constrained to
-- be in @Int@.
ix1 :: Int -> DIM1
ix1 x = Z :. x
{-# INLINE ix1 #-}

ix2 :: Int -> Int -> DIM2
ix2 y x = Z :. y :. x
{-# INLINE ix2 #-}

ix3 :: Int -> Int -> Int -> DIM3
ix3 z y x = Z :. z :. y :. x
{-# INLINE ix3 #-}

ix4 :: Int -> Int -> Int -> Int -> DIM4
ix4 a z y x = Z :. a :. z :. y :. x
{-# INLINE ix4 #-}

ix5 :: Int -> Int -> Int -> Int -> Int -> DIM5
ix5 b a z y x = Z :. b :. a :. z :. y :. x
{-# INLINE ix5 #-}

ix6 :: Int -> Int -> Int -> Int -> Int -> Int -> DIM6
ix6 c b a z y x = Z :. c :. b :. a :. z :. y :. x
{-# INLINE ix6 #-}

ix7 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM7
ix7 d c b a z y x = Z :. d :. c :. b :. a :. z :. y :. x
{-# INLINE ix7 #-}

ix8 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM8
ix8 e d c b a z y x = Z :. e :. d :. c :. b :. a :. z :. y :. x
{-# INLINE ix8 #-}

ix9 :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> DIM9
ix9 f e d c b a z y x = Z :. f :. e :. d :. c :. b :. a :. z :. y :. x
{-# INLINE ix9 #-}

word :: Integral a => a -> Word
word = fromIntegral