use tile result data type
[ruff:gruff.git] / src / Tile.hs
1 {-# LANGUAGE ForeignFunctionInterface #-}
2 module Tile where
3
4 import Prelude hiding (log)
5
6 import Control.Exception (bracketOnError)
7 import Control.Monad (forM_, when)
8 import Data.Bits (shiftL, shiftR, (.&.))
9 import Foreign (Ptr, castPtr, mallocArray, free, Word8, poke, allocaBytes, withArray, peekArray, peekElemOff, pokeElemOff)
10 import Foreign.C (CInt(..), CUChar(..), 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
16 import TypeLevel.NaturalNumber (Zero)
17
18 import UnComplex (Complex((:+)))
19 import Compute (compute)
20 import FixedPrecision
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
29
30 rootSquare :: Square
31 rootSquare = Square{ squareSize = 8, squareWest = -4, squareNorth = -4 }
32
33 data Tile = Tile
34   { tileQuad :: Quad
35   , tileData :: Ptr CUChar
36   }
37
38 mallocTile :: Quad -> IO Tile
39 mallocTile cs = do
40   ds <- mallocArray count
41   return $ Tile cs ds
42
43 freeTile :: Tile -> IO ()
44 freeTile (Tile _ ds) = do
45   free ds
46
47 header :: String
48 header = "RuFfTtLe001\n"
49
50 writeTile :: FilePath -> Tile -> IO ()
51 writeTile cacheDir (Tile q ds) = do
52   case filename q of
53     Nothing -> return ()
54     Just (dirs, file) -> do
55       let dir = foldr1 (</>) (cacheDir : dirs)
56       createDirectoryIfMissing True dir
57       withBinaryFile (dir </> file <.> "t") WriteMode $ \h -> do
58         withCStringLen header $ \(p, l) -> hPutBuf h p l
59         withArray (wordBE bytes) $ \p -> hPutBuf h p 4
60         hPutBuf h ds bytes
61 --        hPut h . bPack . metaData $ q
62   where
63     wordBE :: Int -> [Word8]
64     wordBE n = map (\b -> fromIntegral $ (n `shiftR` (8 * b)) .&. 0xFF) [3, 2, 1, 0]
65
66 {-
67 metaData :: Quad -> BEncode
68 metaData q@Quad{ quadLevel = l, quadWest = w, quadNorth = n } =
69   BDict $ fromList [ ("tile", BDict $ fromList
70     [ ("about", BDict $ fromList
71       [ ("version", BInt 1)
72       , ("generator", BString $ pack "gruff-0.1") ]
73     , ("images", BDict . fromList . map image . zip [0..] $
74       [ "continuous dwell", "normalized distance", "final angle"]) ]
75     ]
76   where
77     image plane alg = (alg, BDict $ fromList
78       [ ("width", BInt (fromIntegral width))
79       , ("height", BInt (fromIntegral height))
80       , ("real", BInt w)
81       , ("imag", BInt (negate n))
82       , ("scale", BInt (fromIntegral l + 2))
83       , ("format", BString $ pack "float32le")
84       , ("order", BString $ pack "lr,tb")
85       , ("data offset", BInt (fromIntegral $ plane * count * sizeOf (0 :: CFloat)))
86       ])
87 -}
88
89 readTile :: FilePath -> Quad -> IO (Maybe Tile)
90 readTile cacheDir q = flip catchIO (\_ -> return Nothing) $ do
91   case filename q of
92     Nothing -> return Nothing
93     Just (dirs, file) -> do
94       let dir = foldr1 (</>) (cacheDir : dirs)
95       bracketOnError (mallocTile q) freeTile $ \t@(Tile _ ds) -> do
96         withBinaryFile (dir </> file <.> "t") ReadMode $ \h -> do
97           let headerBytes = 12
98           allocaBytes headerBytes $ \p -> do
99             headerBytes' <- hGetBuf h p headerBytes
100             when (headerBytes /= headerBytes') $ fail "readTile header fail"
101             header' <- peekArray headerBytes p
102             when (header' /= (map (fromIntegral . fromEnum) header :: [Word8])) $ fail "readTile header mismatch"
103           dataBytes <- allocaBytes 4 $ \p -> do
104             lenBytes' <- hGetBuf h p 4
105             when (lenBytes' /= 4) $ fail "readTile header length fail"
106             unwordBE `fmap` peekArray 4 p
107           when (dataBytes /= bytes) $ fail "readTile header length mismatch"
108           bytes' <- hGetBuf h ds bytes
109           when (bytes /= bytes') $ fail ("readTile " ++ show bytes ++ " /= " ++ show bytes')
110           return $ Just t
111   where
112     unwordBE :: [Word8] -> Int
113     unwordBE = sum . zipWith (\b n -> fromIntegral n `shiftL` (8 * b)) [3, 2, 1, 0]
114
115 clearTile :: Tile -> IO ()
116 clearTile (Tile _ ds) = clear ds >> return ()
117   where
118     clear p = c_memset (castPtr p) 0 (fromIntegral bytes)
119
120 computeTile :: (String -> IO ()) -> Ptr CInt -> Tile -> IO Bool
121 computeTile log p (Tile q@Quad{ quadLevel = l } ds) = do
122     its <- compute'
123     log $ show ("getTile", q, "computed", its)
124     return $ its /= 0
125   where
126     compute' = withPrecision (l + 8) (undefined :: Zero) $ \prec ->
127       let _ = fmap getPrecision c `asTypeOf` (prec :+ prec)
128           c = cx :+ cy
129           cx = fromRational (squareWest s)
130           cy = fromRational (squareNorth s)
131       in  compute p ds c l m'
132     m' = 10000000
133     s = square rootSquare q
134
135 data TileResult = Interrupted | Completed !Tile | BlockedOn !Quad
136
137 getTile :: (String -> IO ()) -> FilePath -> Ptr CInt -> Quad -> IO TileResult
138 getTile log cacheDir p q = do
139   mTile <- readTile cacheDir q
140   case mTile of
141     Just t -> do
142       log $ show ("getTile", q, "read")
143       return (Completed t)
144     Nothing -> case parent q of
145       Just (ch, q') -> do
146         mptile <- readTile cacheDir q'
147         case mptile of
148           Nothing -> do
149             log $ show ("getTile", q, "blocked")
150             return (BlockedOn q')
151           Just t' -> do
152             log $ show ("getTile", q, "compute")
153             t <- mallocTile q
154             inheritTile ch t' t
155             freeTile t'
156             touchTileBorder t
157             poke p 0
158             ok <- computeTile log p t
159             if ok
160               then writeTile cacheDir t >> return (Completed t)
161               else freeTile t >> return Interrupted
162       Nothing -> do
163         log $ show ("getTile", q, "compute")
164         t <- mallocTile q
165         clearTile t
166         touchTileBorder t
167         poke p 0
168         ok <- computeTile log p t
169         if ok
170           then writeTile cacheDir t >> return (Completed t)
171           else freeTile t >> return Interrupted
172
173 inheritTile :: Child -> Tile -> Tile -> IO ()
174 inheritTile c (Tile _ from) (Tile _ to) = do
175   let coff = case c of
176                 NorthWest -> 0
177                 NorthEast -> 128
178                 SouthWest -> 256 * 128
179                 SouthEast -> 256 * 128 + 128
180   forM_ [0..255] $ \j -> do
181     forM_ [0..255] $ \i -> do
182       let toff = 256 * j + i
183           foff = 256 * (j `div` 2) + (i `div` 2) + coff
184       pokeElemOff to toff =<< peekElemOff from foff
185
186 touchTileBorder :: Tile -> IO ()
187 touchTileBorder (Tile _ t) = do
188   let o i j = 256 * j + i
189   forM_ [0..255] $ \e -> do
190     pokeElemOff t (o   0   e) 254
191     pokeElemOff t (o   e   0) 254
192     pokeElemOff t (o 255   e) 254
193     pokeElemOff t (o   e 255) 254
194
195 foreign import ccall unsafe "string.h memset"
196   c_memset :: Ptr Word8 -> CInt -> CSize -> IO (Ptr Word8)