module ReadImage
    (readImage)
where

import           Data.Array.Unboxed
import           Data.Word
import           ImageTypes


readImage       :: String -> Image
readImage       = readPNM . item

readPNM         :: (String, String) -> Image
readPNM ("P1", str)
    = mkBitmap (mkGeo w h) at
      where
      (ns, rest)= readRow 2 str
      [w, h]    = map read ns
      pixels    = fst . readRow len $ rest
      len       = w * h

      bits      :: [Int]
      bits      = map read pixels

      bitMx     :: UArray Int Bool
      bitMx     = listArray (0, len - 1) . map (== 0) $ bits

      at x y
          | 0 <= x && x < w &&
            0 <= y && y < h
                =  bitMx ! (x + w * y)
          | otherwise
              = False

readPNM ("P2", str)
    = Image (mkGeo w h) at
      where
      ([w', h', m'], rest)      = readRow 3 str
      w         = (read w')::Int
      h         = (read h')::Int
      m         = (read m')::Lightness
      l         = w * h
      pixels    = fst . readRow l $ rest

      bytes     :: [Word8]
      bytes     = map read pixels

      byteMx    :: UArray Int Word8
      byteMx    = listArray (0, l - 1) bytes

      at x y
          | 0 <= x && x < w &&
            0 <= y && y < h
                =  fromIntegral (byteMx ! (x + w * y)) / m
          | otherwise
              = dark

readPNM ("P3", str)
    = Image (mkGeo w h) at
      where
      ([w', h', m'], rest)      = readRow 3 str
      w         = (read w')::Int
      h         = (read h')::Int
      m         = (read m')::Lightness
      len       = w * h
      len3      = len * 3
      pixels    = fst . readRow len3 $ rest

      bytes     :: [Word8]
      bytes     = merge3 (map read pixels)
                  where
                  merge3 (r:g:b:xs) = (r + g + b) `div` 3 : merge3 xs
                  merge3 _          = []

      byteMx    :: UArray Int Word8
      byteMx    = listArray (0, len - 1) bytes

      at x y
          | 0 <= x && x < w &&
            0 <= y && y < h
                =  fromIntegral (byteMx ! (x + w * y)) / m
          | otherwise
              = dark

readPNM ("P5", str)
    = Image (mkGeo w h) at
      where
      ([w', h', m'], rest)      = readRow 3 str
      w         = (read w')::Int
      h         = (read h')::Int
      m         = (read m')::Lightness
      l         = w * h

      bytes     :: [Word8]
      bytes     = map (toEnum . fromEnum) .tail $ rest

      byteMx    :: UArray Int Word8
      byteMx    = listArray (0, l - 1) bytes

      at x y
          | 0 <= x && x < w &&
            0 <= y && y < h
                =  fromIntegral (byteMx ! (x + w * y)) / m
          | otherwise
              = dark

readPNM ("P6", str)
    = Image (mkGeo w h) at
      where
      ([w', h', m'], rest)      = readRow 3 str
      w         = (read w')::Int
      h         = (read h')::Int
      m         = (read m')::Lightness
      len       = w * h

      bytes     :: [Word8]
      bytes     = merge3 . map (toEnum . fromEnum) . tail $ rest
                  where
                  merge3 (r:g:b:xs) = (r + g + b) `div` 3 : merge3 xs
                  merge3 _          = []

      byteMx    :: UArray Int Word8
      byteMx    = listArray (0, len - 1) bytes

      at x y
          | 0 <= x && x < w &&
            0 <= y && y < h
                =  fromIntegral (byteMx ! (x + w * y)) / m
          | otherwise
              = dark


readPNM (fmt, _)
    = error $ "unsupported PNM format " ++ show fmt

-- ----------------------------------------

item    :: String -> (String, String)
item str
    = i1
      where
      i@(w,r) = head (lex str)
      i1 | head w == '#'
             = item r1
         | otherwise
             = i
         where
         r1 = ( drop 1 . snd . break (== '\n') . drop 1) r

readFct :: (String -> (a, String)) ->
           Int ->
           String -> ([a], String)

readFct _f 0 str
    = ([],str)

readFct f n str
    = (i:r, str2)
      where
      (i, str1) = f str
      (r, str2) = readFct f (n-1) str1

readRow         :: Int -> String -> ([String], String)
readRow         = readFct item


-- ----------------------------------------