{-# LANGUAGE 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

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 Quad (Ptr CFloat) (Ptr CFloat) (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'
      | otherwise = error "Tile.computeTile: too deep"
    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