prepare to make cache size runtime settable
[ruff:gruff.git] / Tile.hs
1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
2 module Tile where
3
4 import Prelude hiding (log)
5
6 import Control.Exception (bracketOnError)
7 import Control.Monad (when)
8 import Data.Bits (shiftL, shiftR, (.&.))
9 import Foreign (Ptr, castPtr, sizeOf, mallocArray, free, Word8, with, poke, allocaBytes, withArray, peekArray)
10 import Foreign.C (CFloat, CDouble, CInt, CSize, withCStringLen)
11 import System.Directory (createDirectoryIfMissing)
12 import System.FilePath ((</>), (<.>))
13 import System.IO (withBinaryFile, IOMode(ReadMode,WriteMode), hPutBuf, hGetBuf)
14 --import Data.BEncode
15 import Numeric.QD (DoubleDouble, QuadDouble)
16 #ifdef HAVE_MPFR
17 import Foreign.C (CString, withCString)
18 import Number (R)
19 #endif
20
21 import QuadTree
22 import Utils (catchIO)
23
24 width, height, count, bytes :: Int
25 width  = 256
26 height = 256
27 count  = width * height
28 bytes  = count * sizeOf (0 :: CFloat)
29
30 rootSquare :: Square
31 rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }
32
33 data Tile = Tile Quad (Ptr CFloat) (Ptr CFloat) (Ptr CFloat)
34
35 mallocTile :: Quad -> IO Tile
36 mallocTile cs = do
37   ns <- mallocArray count
38   ds <- mallocArray count
39   ts <- mallocArray count
40   return $ Tile cs ns ds ts
41
42 freeTile :: Tile -> IO ()
43 freeTile (Tile _ ns ds ts) = do
44   free ns
45   free ds
46   free ts
47
48 header :: String
49 header = "RuFfTiLe001\n"
50
51 writeTile :: FilePath -> Tile -> IO ()
52 writeTile cacheDir (Tile q ns ds ts) = do
53   case filename q of
54     Nothing -> return ()
55     Just (dirs, file) -> do
56       let dir = foldr1 (</>) (cacheDir : dirs)
57       createDirectoryIfMissing True dir
58       withBinaryFile (dir </> file <.> "ruff") WriteMode $ \h -> do
59         withCStringLen header $ \(p, l) -> hPutBuf h p l
60         withArray (wordBE (bytes * 3)) $ \p -> hPutBuf h p 4
61         hPutBuf h ns bytes
62         hPutBuf h ds bytes
63         hPutBuf h ts bytes
64 --        hPut h . bPack . metaData $ q
65   where
66     wordBE :: Int -> [Word8]
67     wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0]
68
69 {-
70 metaData :: Quad -> BEncode
71 metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } =
72   BDict $ fromList [ ("tile", BDict $ fromList
73     [ ("about", BDict $ fromList
74       [ ("version", BInt 1)
75       , ("generator", BString $ pack "gruff-0.1") ]
76     , ("images", BDict . fromList . map image . zip [0..] $
77       [ "continuous dwell", "normalized distance", "final angle"]) ]
78     ]
79   where
80     image plane alg = (alg, BDict $ fromList
81       [ ("width", BInt (fromIntegral width))
82       , ("height", BInt (fromIntegral height))
83       , ("real", BInt w)
84       , ("imag", BInt (negate n))
85       , ("scale", BInt (fromIntegral l + 2))
86       , ("format", BString $ pack "float32le")
87       , ("order", BString $ pack "lr,tb")
88       , ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat)))
89       ])
90 -}
91
92 readTile :: FilePath -> Quad -> IO (Maybe Tile)
93 readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do
94   case filename q of
95     Nothing -> return Nothing
96     Just (dirs, file) -> do
97       let dir = foldr1 (</>) (cacheDir : dirs)
98       bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ns ds ts) -> do
99         withBinaryFile (dir </> file <.> "ruff") ReadMode $ \h -> do
100           let headerBytes = 12
101           allocaBytes headerBytes $ \p -> do
102             headerBytes' <- hGetBuf h p headerBytes
103             when (headerBytes /= headerBytes') $ fail "readTile header fail"
104             header' <- peekArray headerBytes p
105             when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch"
106           dataBytes <- allocaBytes 4 $ \p -> do
107             lenBytes' <- hGetBuf h p 4
108             when (lenBytes' /= 4) $ fail "readTile header length fail"
109             unwordBE `fmap` peekArray 4 p
110           when (dataBytes /= bytes * 3) $ fail "readTile header length mismatch"
111           bytes' <- hGetBuf h ns bytes
112           when (bytes /= bytes') $ fail ("readTile 0 " ++ show bytes ++ " /= " ++ show bytes')
113           bytes'' <- hGetBuf h ds bytes
114           when (bytes /= bytes'') $ fail ("readTile 1 " ++ show bytes ++ " /= " ++ show bytes'')
115           bytes''' <- hGetBuf h ts bytes
116           when (bytes /= bytes''') $ fail ("readTile 2 " ++ show bytes ++ " /= " ++ show bytes''')
117           return $ Just t
118   where
119     unwordBE :: [Word8] -> Int
120     unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0]
121
122 clearTile :: Tile -> IO ()
123 clearTile (Tile _ ns ds ts) = do
124   mapM_ clear [ns, ds, ts]
125   where
126     clear p = c_memset (castPtr p) 0 (fromIntegral bytes)
127
128 computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool
129 computeTile log p (Tile q@Quad{ quadLevel = l } ns ds ts) = do
130     its <- compute'
131     log $ show ("getTile", q, "computed", its)
132     return $ its /= 0
133   where
134     compute'
135       | l <  18 =   c_compute_f32  p ns ds ts cx cy l' m'
136       | l <  48 =   c_compute_f64  p ns ds ts cx cy l' m'
137       | l <  96 = with (cx :: DoubleDouble) $ \px -> with (cy :: DoubleDouble) $ \py ->
138                     c_compute_f128 p ns ds ts (castPtr px) (castPtr py) l' m'
139       | l < 192 = with (cx :: QuadDouble  ) $ \px -> with (cy :: QuadDouble  ) $ \py ->
140                     c_compute_f256 p ns ds ts (castPtr px) (castPtr py) l' m'
141 #ifdef HAVE_MPFR
142       | otherwise = withCString (show (cx :: R)) $ \px -> withCString (show (cy :: R)) $ \py ->
143                     c_compute_mpfr p ns ds ts px py l' m'
144 #else
145       | otherwise = error "Tile.computeTile: too deep; recompile with MPFR"
146 #endif
147     l' = fromIntegral l
148     m' = 10000000
149     s = square rootSquare q
150     cx, cy :: Fractional a => a
151     cx = fromRational (squareWest s)
152     cy = fromRational (squareNorth s)
153
154 getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO (Maybe Tile)
155 getTile log cacheDir p q = do
156   mTile <- readTile cacheDir q
157   case mTile of
158     Just t -> do
159       log $ show ("getTile", q, "read")
160       return (Just t)
161     Nothing -> do
162       log $ show ("getTile", q, "compute")
163       t <- mallocTile q
164       clearTile t
165       poke p 0
166       ok <- computeTile log p t
167       if ok
168         then writeTile cacheDir t >> return (Just t)
169         else freeTile t >> return Nothing
170
171 foreign import ccall unsafe "string.h memset"
172   c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)
173
174 foreign import ccall "compute.h compute_f32"
175   c_compute_f32 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CFloat -> CFloat -> CInt -> CInt -> IO CInt
176
177 foreign import ccall "compute.h compute_f64"
178   c_compute_f64 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CDouble -> CDouble -> CInt -> CInt -> IO CInt
179
180 foreign import ccall "compute.h compute_f128"
181   c_compute_f128 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt
182
183 foreign import ccall "compute.h compute_f256"
184   c_compute_f256 :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> Ptr CDouble -> Ptr CDouble -> CInt -> CInt -> IO CInt
185
186 #ifdef HAVE_MPFR
187 foreign import ccall "compute.h compute_mpfr"
188   c_compute_mpfr :: Ptr CInt -> Ptr CFloat -> Ptr CFloat -> Ptr CFloat -> CString -> CString -> CInt -> CInt -> IO CInt
189 #endif