module Data.Yarr.Shape (
module Data.Yarr.WorkTypes,
Block, Shape(..), BlockShape(..),
Dim1, Dim2, Dim3,
dim2BlockFill,
Touchable(..), noTouch,
) where
import Prelude as P hiding (foldl, foldr)
import GHC.Exts
import Control.DeepSeq
import Data.Yarr.WorkTypes
import Data.Yarr.Utils.FixedVector as V hiding (foldl, foldr)
import Data.Yarr.Utils.LowLevelFlow
import Data.Yarr.Utils.Primitive
import Data.Yarr.Utils.Split
type Block sh = (sh, sh)
class (Eq sh, Bounded sh, Show sh, NFData sh) => Shape sh where
zero :: sh
size :: sh -> Int
plus :: sh -> sh -> sh
minus :: sh -> sh -> sh
minus = flip offset
offset :: sh -> sh -> sh
fromLinear
:: sh
-> Int
-> sh
toLinear
:: sh
-> sh
-> Int
intersect
:: (Arity n, n ~ S n0)
=> VecList n sh
-> sh
complement :: (Arity n, n ~ S n0) => VecList n sh -> sh
intersectBlocks :: (Arity n, n ~ S n0) => VecList n (Block sh) -> Block sh
intersectBlocks blocks =
let ss = V.map fst blocks
es = V.map snd blocks
in (complement ss, intersect es)
blockSize :: Block sh -> Int
insideBlock :: Block sh -> sh -> Bool
makeChunkRange :: Int -> sh -> sh -> (Int -> Block sh)
foldl :: Foldl sh a b
unrolledFoldl
:: forall a b uf. Arity uf
=> uf
-> (a -> IO ())
-> Foldl sh a b
foldr :: Foldr sh a b
unrolledFoldr
:: forall a b uf. Arity uf
=> uf
-> (a -> IO ())
-> Foldr sh a b
fill :: Fill sh a
unrolledFill
:: forall a uf. Arity uf
=> uf
-> (a -> IO ())
-> Fill sh a
class (Shape sh, Arity (BorderCount sh)) => BlockShape sh where
type BorderCount sh
clipBlock
:: Block sh
-> Block sh
-> VecList (BorderCount sh) (Block sh)
type Dim1 = Int
instance Shape Dim1 where
zero = 0
size = id
plus = (+)
offset off i = i off
fromLinear _ i = i
toLinear _ i = i
intersect = V.minimum
complement = V.maximum
blockSize (s, e) = e s
insideBlock (s, e) i = i >= s && i < e
makeChunkRange chunks start end =
let
split = makeSplitIndex chunks start end
in \ !c -> (split c, split (c + 1))
fill get write = \ (I# start#) (I# end#) -> fill# get write start# end#
unrolledFill uf tch =
\get write ->
\ (I# start#) (I# end#) -> unrolledFill# uf tch get write start# end#
foldl reduce mz get =
\ (I# start#) (I# end#) -> foldl# reduce mz get start# end#
unrolledFoldl unrollFactor tch reduce mz get =
\ (I# start#) (I# end#) ->
unrolledFoldl# unrollFactor tch reduce mz get start# end#
foldr reduce mz get =
\ (I# start#) (I# end#) -> foldr# reduce mz get start# end#
unrolledFoldr unrollFactor tch reduce mz get =
\ (I# start#) (I# end#) ->
unrolledFoldr# unrollFactor tch reduce mz get start# end#
instance BlockShape Dim1 where
type BorderCount Dim1 = N2
clipBlock outer@(os, oe) inner =
let intersection@(is, ie) = intersectBlocks (vl_2 inner outer)
in (vl_2 (os, is) (ie, oe))
type Dim2 = (Int, Int)
instance Shape Dim2 where
zero = (0, 0)
size (h, w) = h * w
plus (y1, x1) (y2, x2) = (y1 + y2, x1 + x2)
offset (offY, offX) (y, x) = (y offY, x offX)
fromLinear (_, w) i = i `quotRem` w
toLinear (_, w) (y, x) = y * w + x
intersect shapes =
let hs = V.map fst shapes
ws = V.map snd shapes
in (V.minimum hs, V.minimum ws)
complement shapes =
let hs = V.map fst shapes
ws = V.map snd shapes
in (V.maximum hs, V.maximum ws)
blockSize ((sy, sx), (ey, ex)) = (ey sy) * (ex sx)
insideBlock ((sy, sx), (ey, ex)) (iy, ix) =
(iy >= sy && iy < ey) && (ix >= sx && ix < ex)
makeChunkRange chunks (sy, sx) (ey, ex) =
let
range = makeChunkRange chunks sy ey
in \c -> let (csy, cey) = range c in ((csy, sx), (cey, ex))
fill get write =
\ (!sy, !sx) (!ey, !ex) ->
let
go y | y >= ey = return ()
| otherwise = do
fill (\x -> get (y, x))
(\x a -> write (y, x) a)
sx ex
go (y + 1)
in go sy
unrolledFill
:: forall a uf. Arity uf
=> uf
-> (a -> IO ())
-> Fill Dim2 a
unrolledFill unrollFactor tch =
let !(I# uf#) = arity unrollFactor
in \get write ->
\ ((I# sy#), (I# sx#)) ((I# ey#), (I# ex#)) ->
let limX# = ex# -# uf#
goY# y#
| y# >=# ey# = return ()
| otherwise = do
let y = I# y#
goX# x#
| x# ># limX# =
fill#
(\x -> get (y, x))
(\x a -> write (y, x) a)
x# ex#
| otherwise = do
let x = I# x#
is :: VecList uf (Int, Int)
is = V.generate (\i -> (y, i + x))
as <- V.mapM get is
V.mapM_ tch as
V.zipWithM_ write is as
goX# (x# +# uf#)
goX# sx#
goY# (y# +# 1#)
in goY# sy#
foldl reduce mz get =
\ (!sy, !sx) (!ey, !ex) ->
let
go y b
| y >= ey = return b
| otherwise = do
b' <- foldl (\b x a -> reduce b (y, x) a)
(return b)
(\x -> get (y, x))
sx ex
go (y + 1) b'
in mz >>= go sy
unrolledFoldl unrollFactor tch reduce mz get =
\ (!sy, !sx) (!ey, !ex) ->
let
go y b
| y >= ey = return b
| otherwise = do
b' <- unrolledFoldl
unrollFactor tch
(\b x a -> reduce b (y, x) a)
(return b)
(\x -> get (y, x))
sx ex
go (y + 1) b'
in mz >>= go sy
foldr reduce mz get =
\ (!sy, !sx) (!ey, !ex) ->
let
go y b
| y < sy = return b
| otherwise = do
b' <- foldr (\x a b -> reduce (y, x) a b)
(return b)
(\x -> get (y, x))
sx ex
go (y 1) b'
in mz >>= go (ey 1)
unrolledFoldr unrollFactor tch reduce mz get =
\ (!sy, !sx) (!ey, !ex) ->
let
go y b
| y < sy = return b
| otherwise = do
b' <- unrolledFoldr
unrollFactor tch
(\x a b -> reduce (y, x) a b)
(return b)
(\x -> get (y, x))
sx ex
go (y 1) b'
in mz >>= go (ey 1)
instance BlockShape Dim2 where
type BorderCount Dim2 = N4
clipBlock outer@((osy, osx), (oey, oex)) inner =
let intersection@((isy, isx), (iey, iex)) =
intersectBlocks (vl_2 inner outer)
in (vl_4 ((osy, isx), (isy, oex))
((isy, iex), (oey, oex))
((iey, osx), (oey, iex))
((osy, osx), (iey, isx)))
dim2BlockFill
:: forall a bsx bsy. (Arity bsx, Arity bsy)
=> bsx
-> bsy
-> (a -> IO ())
-> Fill Dim2 a
dim2BlockFill blockSizeX blockSizeY tch =
\get write ->
\ ((I# sy#), sx@(I# sx#)) end@((I# ey#), ex@(I# ex#)) ->
let !(I# bx#) = arity blockSizeX
limX# = ex# -# bx#
!(I# by#) = arity blockSizeY
limY# = ey# -# by#
goY# y# | y# ># limY# = fill get write ((I# y#), sx) end
| otherwise = do
let y = I# y#
ys :: VecList bsy Int
ys = V.generate (+ y)
go# x#
| x# ># limX# =
fill get write
(y, (I# x#)) (I# (y# +# by#), ex)
| otherwise = do
let xs :: VecList bsx Int
xs = V.generate (+ (I# x#))
is = V.map (\y -> V.map (\x -> (y, x)) xs) ys
as <- V.mapM (V.mapM get) is
V.mapM_ (V.mapM_ tch) as
V.zipWithM_ (V.zipWithM_ write) is as
go# (x# +# bx#)
go# sx#
goY# (y# +# by#)
in goY# sy#
type Dim3 = (Int, Int, Int)
instance Shape Dim3 where
zero = (0, 0, 0)
size (d, h, w) = d * h * w
plus (z1, y1, x1) (z2, y2, x2) = (z1 + z2, y1 + y2, x1 + x2)
offset (offZ, offY, offX) (z, y, x) = (z offZ, y offY, x offX)
fromLinear (_, h, w) i =
let (i', x) = i `quotRem` w
(z, y) = i' `quotRem` h
in (z, y, x)
toLinear (_, h, w) (z, y, x) = z * (h * w) + y * w + x
intersect shapes =
let ds = V.map (\(d, _, _) -> d) shapes
hs = V.map (\(_, h, _) -> h) shapes
ws = V.map (\(_, _, w) -> w) shapes
in (V.minimum ds, V.minimum hs, V.minimum ws)
complement shapes =
let ds = V.map (\(d, _, _) -> d) shapes
hs = V.map (\(_, h, _) -> h) shapes
ws = V.map (\(_, _, w) -> w) shapes
in (V.maximum ds, V.maximum hs, V.maximum ws)
blockSize ((sz, sy, sx), (ez, ey, ex)) =
(ez sz) * (ey sy) * (ex sx)
insideBlock ((sz, sy, sx), (ez, ey, ex)) (iz, iy, ix) =
(iz >= sz && iz < ez) &&
(iy >= sy && iy < ey) &&
(ix >= sx && ix < ex)
makeChunkRange chunks (sz, sy, sx) (ez, ey, ex) =
let
range = makeChunkRange chunks sz ez
in \c -> let (csz, cez) = range c
in ((csz, sy, sx), (cez, ey, ex))
fill get write =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z | z >= ez = return ()
| otherwise = do
fill
(\(y, x) -> get (z, y, x))
(\(y, x) a -> write (z, y, x) a)
(sy, sx) (ey, ex)
go (z + 1)
in go sz
unrolledFill unrollFactor tch =
let !uf = arity unrollFactor
actualFill _ get write =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z | z >= ez = return ()
| otherwise = do
unrolledFill
unrollFactor tch
(\(y, x) -> get (z, y, x))
(\(y, x) a -> write (z, y, x) a)
(sy, sx) (ey, ex)
go (z + 1)
in go sz
in actualFill uf
foldl reduce mz get =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z b
| z >= ez = return b
| otherwise = do
b' <- foldl
(\b (y, x) a -> reduce b (z, y, x) a)
(return b)
(\(y, x) -> get (z, y, x))
(sy, sx) (ey, ex)
go (z + 1) b'
in mz >>= go sz
unrolledFoldl unrollFactor tch reduce mz get =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z b
| z >= ez = return b
| otherwise = do
b' <- unrolledFoldl
unrollFactor tch
(\b (y, x) a -> reduce b (z, y, x) a)
(return b)
(\(y, x) -> get (z, y, x))
(sy, sx) (ey, ex)
go (z + 1) b'
in mz >>= go sz
foldr reduce mz get =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z b
| z < sz = return b
| otherwise = do
b' <- foldr
(\(y, x) a b -> reduce (z, y, x) a b)
(return b)
(\(y, x) -> get (z, y, x))
(sy, sx) (ey, ex)
go (z 1) b'
in mz >>= go (ez 1)
unrolledFoldr unrollFactor tch reduce mz get =
\ (!sz, !sy, !sx) (!ez, !ey, !ex) ->
let
go z b
| z < sz = return b
| otherwise = do
b' <- unrolledFoldr
unrollFactor tch
(\(y, x) a b -> reduce (z, y, x) a b)
(return b)
(\(y, x) -> get (z, y, x))
(sy, sx) (ey, ex)
go (z 1) b'
in mz >>= go (ez 1)