gruff-0.3.3: src/Tile.hs
{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Tile where
import Prelude hiding (log)
import Control.Exception (bracketOnError)
import Control.Monad (when)
import Data.Bits (shiftL, shiftR, (.&.))
import Foreign (Ptr, castPtr, sizeOf, mallocArray, free, Word8, with, poke, allocaBytes, withArray, peekArray)
import Foreign.C (CFloat(..), CDouble(..), CInt(..), CSize(..), withCStringLen)
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>), (<.>))
import System.IO (withBinaryFile, IOMode(ReadMode,WriteMode), hPutBuf, hGetBuf)
--import Data.BEncode
import Numeric.QD (DoubleDouble, QuadDouble)
#ifdef HAVE_MPFR
import Foreign.C (CString, withCString)
import Number (R)
#endif
import QuadTree
import Utils (catchIO)
width, height, count, bytes :: Int
width = 256
height = 256
count = width * height
bytes = count * sizeOf (0 :: CFloat)
rootSquare :: Square
rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }
data Tile = Tile
{ tileQuad :: Quad
, tileIter :: Ptr CFloat
, tileDist :: Ptr CFloat
, tileAngle :: Ptr CFloat
}
mallocTile :: Quad -> IO Tile
mallocTile cs = do
ns <- mallocArray count
ds <- mallocArray count
ts <- mallocArray count
return $ Tile cs ns ds ts
freeTile :: Tile -> IO ()
freeTile (Tile _ ns ds ts) = do
free ns
free ds
free ts
header :: String
header = "RuFfTiLe001\n"
writeTile :: FilePath -> Tile -> IO ()
writeTile cacheDir (Tile q ns ds ts) = do
case filename q of
Nothing -> return ()
Just (dirs, file) -> do
let dir = foldr1 (</>) (cacheDir : dirs)
createDirectoryIfMissing True dir
withBinaryFile (dir </> file <.> "ruff") WriteMode $ \h -> do
withCStringLen header $ \(p, l) -> hPutBuf h p l
withArray (wordBE (bytes * 3)) $ \p -> hPutBuf h p 4
hPutBuf h ns bytes
hPutBuf h ds bytes
hPutBuf h ts bytes
-- hPut h . bPack . metaData $ q
where
wordBE :: Int -> [Word8]
wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0]
{-
metaData :: Quad -> BEncode
metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } =
BDict $ fromList [ ("tile", BDict $ fromList
[ ("about", BDict $ fromList
[ ("version", BInt 1)
, ("generator", BString $ pack "gruff-0.1") ]
, ("images", BDict . fromList . map image . zip [0..] $
[ "continuous dwell", "normalized distance", "final angle"]) ]
]
where
image plane alg = (alg, BDict $ fromList
[ ("width", BInt (fromIntegral width))
, ("height", BInt (fromIntegral height))
, ("real", BInt w)
, ("imag", BInt (negate n))
, ("scale", BInt (fromIntegral l + 2))
, ("format", BString $ pack "float32le")
, ("order", BString $ pack "lr,tb")
, ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat)))
])
-}
readTile :: FilePath -> Quad -> IO (Maybe Tile)
readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do
case filename q of
Nothing -> return Nothing
Just (dirs, file) -> do
let dir = foldr1 (</>) (cacheDir : dirs)
bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ns ds ts) -> do
withBinaryFile (dir </> file <.> "ruff") ReadMode $ \h -> do
let headerBytes = 12
allocaBytes headerBytes $ \p -> do
headerBytes' <- hGetBuf h p headerBytes
when (headerBytes /= headerBytes') $ fail "readTile header fail"
header' <- peekArray headerBytes p
when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch"
dataBytes <- allocaBytes 4 $ \p -> do
lenBytes' <- hGetBuf h p 4
when (lenBytes' /= 4) $ fail "readTile header length fail"
unwordBE `fmap` peekArray 4 p
when (dataBytes /= bytes * 3) $ fail "readTile header length mismatch"
bytes' <- hGetBuf h ns bytes
when (bytes /= bytes') $ fail ("readTile 0 " ++ show bytes ++ " /= " ++ show bytes')
bytes'' <- hGetBuf h ds bytes
when (bytes /= bytes'') $ fail ("readTile 1 " ++ show bytes ++ " /= " ++ show bytes'')
bytes''' <- hGetBuf h ts bytes
when (bytes /= bytes''') $ fail ("readTile 2 " ++ show bytes ++ " /= " ++ show bytes''')
return $ Just t
where
unwordBE :: [Word8] -> Int
unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0]
clearTile :: Tile -> IO ()
clearTile (Tile _ ns ds ts) = do
mapM_ clear [ns, ds, ts]
where
clear p = c_memset (castPtr p) 0 (fromIntegral bytes)
computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool
computeTile log p (Tile q@Quad{ quadLevel = l } ns ds ts) = do
its <- compute'
log $ show ("getTile", q, "computed", its)
return $ its /= 0
where
compute'
| l < 18 = c_compute_f32 p ns ds ts cx cy l' m'
| l < 48 = c_compute_f64 p ns ds ts cx cy l' m'
| l < 96 = with (cx :: DoubleDouble) $ \px -> with (cy :: DoubleDouble) $ \py ->
c_compute_f128 p ns ds ts (castPtr px) (castPtr py) l' m'
| l < 192 = with (cx :: QuadDouble ) $ \px -> with (cy :: QuadDouble ) $ \py ->
c_compute_f256 p ns ds ts (castPtr px) (castPtr py) l' m'
#ifdef HAVE_MPFR
| otherwise = withCString (show (cx :: R)) $ \px -> withCString (show (cy :: R)) $ \py ->
c_compute_mpfr p ns ds ts px py l' m'
#else
| otherwise = error "Tile.computeTile: too deep; recompile with MPFR"
#endif
l' = fromIntegral l
m' = 10000000
s = square rootSquare q
cx, cy :: Fractional a => a
cx = fromRational (squareWest s)
cy = fromRational (squareNorth s)
getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO (Maybe Tile)
getTile log cacheDir p q = do
mTile <- readTile cacheDir q
case mTile of
Just t -> do
log $ show ("getTile", q, "read")
return (Just t)
Nothing -> do
log $ show ("getTile", q, "compute")
t <- mallocTile q
clearTile t
poke p 0
ok <- computeTile log p t
if ok
then writeTile cacheDir t >> return (Just t)
else freeTile t >> return Nothing
foreign import ccall unsafe "string.h memset"
c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
foreign import ccall "compute.h compute_f32"
c_compute_f32 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CFloat -> CFloat -> CInt -> CInt -> IO CInt
foreign import ccall "compute.h compute_f64"
c_compute_f64 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CDouble -> CDouble -> CInt -> CInt -> IO CInt
foreign import ccall "compute.h compute_f128"
c_compute_f128 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt
foreign import ccall "compute.h compute_f256"
c_compute_f256 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt
#ifdef HAVE_MPFR
foreign import ccall "compute.h compute_mpfr"
c_compute_mpfr :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CString -> CString -> CInt -> CInt -> IO CInt
#endif