{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE PatternGuards       #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Rendering of Repa arrays as raster images.
--
--  Gloss programs should be compiled with @-threaded@, otherwise the GHC runtime
--  will limit the frame-rate to around 20Hz.
--
--  The performance of programs using this interface is sensitive to how much
--  boxing and unboxing the GHC simplifier manages to eliminate. For the best
--  result add INLINE pragmas to all of your numeric functions and use the following
--  compile options.
--
--  @-threaded -Odph -fno-liberate-case -funfolding-use-threshold1000
--   -funfolding-keeness-factor1000 -fllvm -optlo-O3@
--
--  See the examples the @raster@ directory of the @gloss-examples@ package
--  for more details.
--
module Graphics.Gloss.Raster.Array
        ( -- * Color
          module Graphics.Gloss.Data.Color
        , rgb,  rgbI, rgb8w
        , rgb', rgbI'

          -- * Display functions
        , Display       (..)
        , animateArray
        , playArray
        , animateArrayIO
        , playArrayIO)
where
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Picture
import Graphics.Gloss.Data.Display
import Graphics.Gloss.Data.Bitmap
import Graphics.Gloss.Interface.Pure.Game
import Graphics.Gloss.Interface.IO.Animate
import Graphics.Gloss.Interface.IO.Game
import Graphics.Gloss.Interface.Environment
import Graphics.Gloss.Rendering
import Data.Word
import System.IO.Unsafe
import Unsafe.Coerce
import Debug.Trace
import Data.Bits
import Data.Array.Repa                          as R
import Data.Array.Repa.Repr.ForeignPtr          as R
import Prelude                                  as P


-- Color ----------------------------------------------------------------------
-- | Construct a color from red, green, blue components.
--
--   Each component is clamped to the range [0..1]
rgb  :: Float -> Float -> Float -> Color
rgb r g b   = makeColor r g b 1.0
{-# INLINE rgb #-}


-- | Construct a color from red, green, blue components.
--
--   Each component is clamped to the range [0..255]
rgbI :: Int -> Int -> Int -> Color
rgbI r g b  = makeColorI r g b 255
{-# INLINE rgbI #-}


-- | Construct a color from red, green, blue components.
rgb8w :: Word8 -> Word8 -> Word8 -> Color
rgb8w r g b = makeRawColorI (fromIntegral r) (fromIntegral g) (fromIntegral b) 255
{-# INLINE rgb8w #-}


-- | Like `rgb`, but take pre-clamped components for speed.
--
--   If you're building a new color for every pixel then use this version,
--   however if your components are out of range then the picture you get will
--   be implementation dependent.
rgb' :: Float -> Float -> Float -> Color
rgb' r g b  = makeRawColor r g b 1.0
{-# INLINE rgb' #-}


-- | Like `rgbI`, but take pre-clamped components for speed.
--
--   If you're building a new color for every pixel then use this version,
--   however if your components are out of range then the picture you get will
--   be implementation dependent.
rgbI' :: Int -> Int -> Int -> Color
rgbI' r g b  = makeRawColorI r g b 255
{-# INLINE rgbI' #-}


-- Animate --------------------------------------------------------------------
-- | Animate a bitmap generated from a Repa array.
animateArray
        :: Display
                -- ^ Display mode.
        -> (Int, Int)
                -- ^ Number of pixels to draw per element.
        -> (Float -> Array D DIM2 Color)
                -- ^ A function to construct a delayed array for the given time.
                --   The function should return an array of the same extent each
                --   time it is applied.
                --
                --   It is passed the time in seconds since the program started.
        -> IO ()

animateArray display scale@(scaleX, scaleY) makeArray
 = scaleX `seq` scaleY `seq`
 if scaleX < 1 || scaleY < 1
   then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor "
                P.++ show (scaleX, scaleY)
   else let {-# INLINE frame #-}
            frame !time          = return $ makeFrame scale (makeArray time)
        in  animateFixedIO display black frame (const $ return ())
{-# INLINE animateArray #-}
--  INLINE so the repa functions fuse with the users client functions.


-- AnimateIO --------------------------------------------------------------------
-- | Animate a bitmap generated from a Repa array, via the IO monad.
animateArrayIO
        :: Display
                -- ^ Display mode.
        -> (Int, Int)
                -- ^ Number of pixels to draw per element.
        -> (Float -> IO (Array D DIM2 Color))
                -- ^ A function to construct a delayed array for the given time.
                --   The function should return an array of the same extent each
                --   time it is applied.
                --
                --   It is passed the time in seconds since the program started.
        -> IO ()

animateArrayIO display scale@(scaleX, scaleY) makeArray
 = scaleX `seq` scaleY `seq`
 if scaleX < 1 || scaleY < 1
   then error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor "
                P.++ show (scaleX, scaleY)
   else let {-# INLINE frame #-}
            frame !time          = fmap (makeFrame scale) (makeArray time)
        in  animateFixedIO display black frame (const $ return ())
{-# INLINE animateArrayIO #-}
--  INLINE so the repa functions fuse with the users client functions.


-- Play -----------------------------------------------------------------------
-- | Play with a bitmap generated from a Repa array.
playArray
        :: Display
                -- ^ Display mode.
        -> (Int, Int)
                -- ^ Number of pixels to draw per element.
        -> Int  -- ^ Number of simulation steps to take
                --   for each second of real time
        -> world
                -- ^ The initial world.
        -> (world -> Array D DIM2 Color)
                -- ^ Function to convert the world to an array.
        -> (Event -> world -> world)
                -- ^ Function to handle input events.
        -> (Float -> world -> world)
                -- ^ Function to step the world one iteration.
                --   It is passed the time in seconds since the program started.
        -> IO ()
playArray !display scale@(scaleX, scaleY) !stepRate
          !initWorld !makeArray !handleEvent !stepWorld
 = scaleX `seq` scaleY `seq`
   if scaleX < 1 || scaleY < 1
     then  error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor "
                 P.++ show scale
     else  let  {-# INLINE frame #-}
                frame !world    = makeFrame scale (makeArray world)

           in   play display black
                        stepRate
                        initWorld
                        frame
                        handleEvent
                        stepWorld
{-# INLINE playArray #-}


-- PlayIO -----------------------------------------------------------------------
-- | Play with a bitmap generated from a Repa array, via the IO monad.
playArrayIO
        :: Display
                -- ^ Display mode.
        -> (Int, Int)
                -- ^ Number of pixels to draw per element.
        -> Int  -- ^ Number of simulation steps to take
                --   for each second of real time
        -> world
                -- ^ The initial world.
        -> (world -> IO (Array D DIM2 Color))
                -- ^ Function to convert the world to an array.
        -> (Event -> world -> IO world)
                -- ^ Function to handle input events.
        -> (Float -> world -> IO world)
                -- ^ Function to step the world one iteration.
                --   It is passed the time in seconds since the program started.
        -> IO ()
playArrayIO !display scale@(scaleX, scaleY) !stepRate
            !initWorld !makeArray !handleEvent !stepWorld
 = scaleX `seq` scaleY `seq`
   if scaleX < 1 || scaleY < 1
     then  error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor "
                 P.++ show scale
     else  let  {-# INLINE frame #-}
                frame !world    = fmap (makeFrame scale) (makeArray world)

           in  playIO display black
                        stepRate
                        initWorld
                        frame
                        handleEvent
                        stepWorld
{-# INLINE playArrayIO #-}


-- Frame ----------------------------------------------------------------------
makeFrame :: (Int, Int) -> Array D DIM2 Color -> Picture
makeFrame (scaleX, scaleY) !array
 = let  -- Size of the array
        _ :. sizeY :. sizeX
                         = R.extent array

        convColor :: Color -> Word32
        convColor color
         = let  (r, g, b) = unpackColor color
                r'        = fromIntegral r
                g'        = fromIntegral g
                b'        = fromIntegral b
                a         = 255

                !w        =  unsafeShiftL r' 24
                         .|. unsafeShiftL g' 16
                         .|. unsafeShiftL b' 8
                         .|. a
           in   w
        {-# INLINE convColor #-}

   in unsafePerformIO $ do

        -- Define the image, and extract out just the RGB color components.
        -- We don't need the alpha because we're only drawing one image.
        traceEventIO "Gloss.Raster[makeFrame]: start frame evaluation."
        (arrRGB :: Array F DIM2 Word32)
                <- R.computeP $ R.map convColor array
        traceEventIO "Gloss.Raster[makeFrame]: done, returning picture."

        -- Wrap the ForeignPtr from the Array as a gloss picture.
        let picture
                = Scale (fromIntegral scaleX) (fromIntegral scaleY)
                $ bitmapOfForeignPtr
                        sizeX sizeY     -- raw image size
                        (BitmapFormat BottomToTop PxABGR)
                        (R.toForeignPtr $ unsafeCoerce arrRGB)
                                        -- the image data.
                        False           -- don't cache this in texture memory.

        return picture
{-# INLINE makeFrame #-}


-- | Float to Word8 conversion because the one in the GHC libraries
--   doesn't have enout specialisations and goes via Integer.
word8OfFloat :: Float -> Word8
word8OfFloat f
        = fromIntegral (truncate f :: Int)
{-# INLINE word8OfFloat #-}


unpackColor :: Color -> (Word8, Word8, Word8)
unpackColor c
        | (r, g, b, _) <- rgbaOfColor c
        = ( word8OfFloat (r * 255)
          , word8OfFloat (g * 255)
          , word8OfFloat (b * 255))
{-# INLINE unpackColor #-}


sizeOfDisplay :: Display -> IO (Int, Int)
sizeOfDisplay display
 = case display of
        InWindow _ s _  -> return s
        FullScreen      -> getScreenSize
{-# INLINE sizeOfDisplay #-}