module BMPRead where

import Network.URI
import Network.HTTP
-- import Network.HTTP.Base
import Data.Bits
import qualified Data.ByteString as B
import System.Environment
import System.IO
import FunctionalImage
import Fran

bytes2Integer :: Enum a => [a] -> Integer
bytes2Integer []     = 0
bytes2Integer (x:xs) = toEnum (fromEnum x) + 256 * bytes2Integer xs

type RawBMP = [[(Integer, Integer, Integer, Integer)]]

bytes2BMPwithMasks :: B.ByteString -> Int -> Int -> Int -> [Integer] -> RawBMP 
bytes2BMPwithMasks bytes width height bpp masks = map (map toARGB) pixels
   where  bytesPerLine = let tmp = width * bpp in
                           if tmp `mod` 4==0 then tmp
                                       else (tmp `div` 4 + 1) * 4
          splitLines pxs = if B.length pxs == 0 
                             then []
                             else B.take bytesPerLine pxs : splitLines (B.drop bytesPerLine pxs)
          lines = splitLines bytes
          splitPixel line = if B.length line == 0
                              then []
                              else B.take bpp line : splitPixel (B.drop bpp line)
          pixels    = map splitPixel lines
          extract v mask = let tmp     = v .&. mask
                               m2      = mask `shiftL` 1
                               divisor = complement m2 .&. mask
                             in tmp `div` divisor 
          toTuple [r,g,b,a] = (r,g,b,a)
          toTuple [r,g,b]   = (r,g,b,0xff)
          toARGB px = toTuple $ map (extract $ bytes2Integer $ B.unpack px) masks

bytes2BMPbyVersion :: B.ByteString -> Int -> Int -> Int -> Int -> Int -> Maybe RawBMP
bytes2BMPbyVersion bmp off 40    width height bpp = -- BITMAPINFOHEADER
  Just $ bytes2BMPwithMasks (B.drop off bmp) width height bpp (if bpp==4 then [0xff00, 0xff0000, 0xff000000, 0xff] else [0xff, 0xff00, 0xff0000])
bytes2BMPbyVersion bmp off hSize width height bpp 
  | hSize == 108 || hSize == 124 =  -- BITMAPV4HEADER || BITMAPV5HEADER
  let masks = map (\ i -> bytes2Integer $ B.unpack $ B.take 4 $ B.drop i bmp) [0x36, 0x3a, 0x3e, 0x42]
    in Just $ bytes2BMPwithMasks (B.drop off bmp) width height bpp masks 
bytes2BMPbyVersion bmp off _     _     _      _     = Nothing

bytes2BMP :: B.ByteString -> Maybe (RawBMP, (Int, Int))
bytes2BMP bmp = 
  let toChar :: Enum a => a -> Char
      toChar = toEnum . fromEnum
      magic  = map toChar $ B.unpack $ B.take 2 bmp
      off    = fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x0a bmp -- header size
      hSize  = fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x0e bmp
      width  = fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x12 bmp
      height = fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x16 bmp
      bpp    = (fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x1c bmp) `div` 8 -- bytes per pixel
      cmp    = fromInteger $ bytes2Integer $ B.unpack $ B.take 4 $ B.drop 0x1e bmp -- compression
    in if magic /= "BM" || hSize `notElem` [40, 108, 124]  || bpp `notElem` [3, 4] || cmp /= 0
         then Nothing
         else case bytes2BMPbyVersion bmp off hSize width height bpp of
                Just pss -> Just (pss, (width, height))
                _        -> Nothing
getBMP :: String -> IO (Maybe (RawBMP, (Int, Int)))
getBMP urlStr =
   case parseURIReference urlStr of
      Just uri -> do rsp <- simpleHTTP (defaultGETRequest_ uri)
                      -- fetch document and return it (as a 'String'.)
                     ba <- getResponseBody rsp
                     return $ bytes2BMP ba
      Nothing  -> return Nothing

getBMPFile :: String -> IO (Maybe (RawBMP, (Int, Int)))
getBMPFile path =  do 
  bs <- B.readFile path
  return $ bytes2BMP bs

colorss2Image :: (Int,Int) -> [[Colour]] -> ImageC
colorss2Image (w, h) css (x, y) = 
  let (ix, iy) = (round x, round y) in 
  if 0<=ix && ix<w && 0<=iy && iy<h then css!!(h-iy-1)!!ix else (0, 0, 0, 0)

rawBMP2Image :: RawBMP -> (Int, Int) -> ImageC
rawBMP2Image bmp (w, h) = 
   let w2 = fromIntegral w / 2
       h2 = fromIntegral h / 2
       i2d i = fromIntegral i / 256
       im =  translate (-w2, -h2) $ colorss2Image (w, h) 
                  $ map (map (\ (r, g, b, a) -> (i2d r, i2d g, i2d b, i2d a))) bmp
     in im

getImage :: String -> IO (Maybe (ImageC, (Int, Int)))
getImage urlStr =
  do mb <- getBMP urlStr
     case mb of
       Just (raw, (w, h)) -> return $ Just (rawBMP2Image raw (w, h), (w, h))
       Nothing  -> return Nothing
       
getImageFile :: String -> IO (Maybe (ImageC, (Int, Int)))
getImageFile path = 
  do mb <- getBMPFile path
     case mb of 
       Just (raw, (w, h)) -> return $ Just (rawBMP2Image raw (w, h), (w, h))
       Nothing  -> return Nothing

testBMPRead = 
       do args <- getArgs
          bmp <- getBMP (args!!0)
          case bmp of
            Nothing -> putStrLn "error processing a bmp file"
            Just (bmp, (w, h)) -> do putStrLn ("width = " ++ show w ++ ", height = " ++ show h)
                                     putStrLn (show $ bmp)