module Vision.Primitive.Shape (
Shape (..), Z (..), (:.) (..)
, DIM0, DIM1, DIM2, DIM3, DIM4, DIM5, DIM6, DIM7, DIM8, DIM9
, 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 Eq sh => Shape sh where
shapeRank :: sh -> Int
shapeLength :: sh -> Int
shapeZero :: sh
shapeSucc :: sh
-> sh
-> sh
toLinearIndex :: sh
-> sh
-> Int
fromLinearIndex :: sh
-> Int
-> sh
shapeList :: sh -> [sh]
inShape :: sh
-> sh
-> Bool
data Z = Z deriving (Show, Read, Eq, Ord)
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
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
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
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
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)
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
shapeLength Z = 1
shapeZero = Z
shapeSucc _ _= Z
toLinearIndex Z _ = 0
fromLinearIndex Z _ = Z
shapeList Z = [Z]
inShape Z Z = True
instance Storable Z where
sizeOf _ = 0
alignment _ = 0
peek _ = return Z
poke _ _ = return ()
instance Shape sh => Shape (sh :. Int) where
shapeRank (sh :. _) = shapeRank sh + 1
shapeLength (sh :. n) = shapeLength sh * n
shapeZero = shapeZero :. 0
shapeSucc (sh :. n) (sh' :. ix)
| ix' >= n = shapeSucc sh sh' :. 0
| otherwise = sh' :. ix'
where
!ix' = ix + 1
toLinearIndex (sh :. n) (sh' :. ix) = toLinearIndex sh sh' * n
+ ix
fromLinearIndex (sh :. n) ix
| shapeRank sh == 0 = fromLinearIndex sh 0 :. ix
| otherwise = let (q, r) = ix `quotRem` n
in fromLinearIndex sh q :. r
shapeList (sh :. n) = [ sh' :. i | sh' <- shapeList sh, i <- [0..n1] ]
inShape (sh :. n) (sh' :. ix) = word ix < word n && inShape sh sh'
instance Storable sh => Storable (sh :. Int) where
sizeOf ~(sh :. _) = sizeOf (undefined :: Int) + sizeOf sh
alignment _ = alignment (undefined :: Int)
peek !ptr = do
let !ptr' = castPtr ptr
(:.) <$> peek (castPtr $! ptr' `plusPtr` sizeOf (undefined :: Int)) <*> peek ptr'
poke !ptr (sh :. n) = do
let !ptr' = castPtr ptr
poke (castPtr $! ptr' `plusPtr` sizeOf n) sh >> poke ptr' n
ix1 :: Int -> DIM1
ix1 x = Z :. x
ix2 :: Int -> Int -> DIM2
ix2 y x = Z :. y :. x
ix3 :: Int -> Int -> Int -> DIM3
ix3 z y x = Z :. z :. y :. x
ix4 :: Int -> Int -> Int -> Int -> DIM4
ix4 a z y x = Z :. a :. z :. y :. x
ix5 :: Int -> Int -> Int -> Int -> Int -> DIM5
ix5 b a z y x = Z :. b :. a :. z :. y :. x
ix6 :: Int -> Int -> Int -> Int -> Int -> Int -> DIM6
ix6 c b a z y x = Z :. c :. b :. a :. z :. y :. x
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
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
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
word :: Integral a => a -> Word
word = fromIntegral