{-# LANGUAGE BangPatterns                                #-}
{-# LANGUAGE DeriveDataTypeable                          #-}
{-# LANGUAGE DeriveGeneric                               #-}
{-# LANGUAGE FlexibleContexts                            #-}
{-# LANGUAGE MagicHash                                   #-}
{-# LANGUAGE MultiWayIf                                  #-}
{-# LANGUAGE PatternGuards                               #-}
{-# LANGUAGE ScopedTypeVariables                         #-}
{-# LANGUAGE TypeApplications                            #-}

-- |
-- Module      :  Graphics.Gloss.Raster.Array
-- Copyright   :  (c) Matthew Mosior 2023
-- License     :  BSD-style
-- Maintainer  :  mattm.github@gmail.com
-- Portability :  portable
--
-- = Massiv-based alternative for gloss-raster
--
-- This library utilizes [massiv](https://hackage.haskell.org/package/massiv-1.0.4.0)'s superb performance characteristics to supply alternative rasterization functionality to that which is provided by the [gloss-raster](https://hackage.haskell.org/package/gloss-raster) package.

module Graphics.Gloss.Raster.Array ( -- * Graphics.Gloss.Raster.Array Replacement functions - Display functions
                                     animateArrayMassiv,
                                     playArrayMassiv,
                                     animateArrayMassivIO,
                                     playArrayMassivIO,
                                     makeFrame,
                                     sizeOfDisplay 
                                   ) where

import Graphics.Gloss.Raster.Massiv.Internal

import Data.Bits
import Data.Word
import Data.Massiv.Array as DMA
import Data.Massiv.Array.Unsafe as DMAU
import Debug.Trace
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 System.IO.Unsafe
import Unsafe.Coerce

-- | A more performant replacement of
-- [animateArray](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html#v:animateArray)
-- found in [Graphics.Gloss.Raster.Array](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html).
--
-- Animate a bitmap generated from a Massiv array.
animateArrayMassiv :: Display                                -- ^ Display mode.
                   -> (Int,Int)                              -- ^ Number of pixels to draw per element.
                   -> (Float -> Array DMA.S Ix2 ColorMassiv) -- ^ 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 ()
animateArrayMassiv :: Display
-> (Int, Int) -> (Float -> Array S Ix2 ColorMassiv) -> IO ()
animateArrayMassiv Display
display scalemassiv :: (Int, Int)
scalemassiv@(Int
scaleX, Int
scaleY) Float -> Array S Ix2 ColorMassiv
makeMassivArray =
  Int
scaleX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
scaleY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
scaleX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
scaleY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
     -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
scaleX,Int
scaleY)
     | Bool
otherwise
     -> let {-# INLINE frame #-}
            frame :: Float -> m Picture
frame !Float
time          = Picture -> m Picture
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Picture -> m Picture) -> Picture -> m Picture
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Array S Ix2 ColorMassiv -> Picture
makeFrame (Int, Int)
scalemassiv (Float -> Array S Ix2 ColorMassiv
makeMassivArray Float
time)
        in  Display
-> Color -> (Float -> IO Picture) -> (Controller -> IO ()) -> IO ()
animateFixedIO Display
display Color
black Float -> IO Picture
forall {m :: * -> *}. Monad m => Float -> m Picture
frame (IO () -> Controller -> IO ()
forall a b. a -> b -> a
const (IO () -> Controller -> IO ()) -> IO () -> Controller -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE animateArrayMassiv #-}

-- | A more performant replacement of
-- [animateArrayIO](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html#v:animateArrayIO)
-- found in [Graphics.Gloss.Raster.Array](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html).
--
-- Animate a bitmap generated from a Massiv array, via the IO monad.
animateArrayMassivIO :: Display                                     -- ^ Display mode.
                     -> (Int,Int)                                   -- ^ Number of pixels to draw per element.
                     -> (Float -> IO (Array DMA.S Ix2 ColorMassiv)) -- ^ 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 ()
animateArrayMassivIO :: Display
-> (Int, Int) -> (Float -> IO (Array S Ix2 ColorMassiv)) -> IO ()
animateArrayMassivIO Display
display scalemassiv :: (Int, Int)
scalemassiv@(Int
scaleX, Int
scaleY) Float -> IO (Array S Ix2 ColorMassiv)
makeMassivArray =
  Int
scaleX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
scaleY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
scaleX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
scaleY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
     -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
scaleX,Int
scaleY)
     | Bool
otherwise
     -> let {-# INLINE frame #-}
            frame :: Float -> IO Picture
frame !Float
time          = (Array S Ix2 ColorMassiv -> Picture)
-> IO (Array S Ix2 ColorMassiv) -> IO Picture
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int, Int) -> Array S Ix2 ColorMassiv -> Picture
makeFrame (Int, Int)
scalemassiv) (Float -> IO (Array S Ix2 ColorMassiv)
makeMassivArray Float
time)
        in  Display
-> Color -> (Float -> IO Picture) -> (Controller -> IO ()) -> IO ()
animateFixedIO Display
display Color
black Float -> IO Picture
frame (IO () -> Controller -> IO ()
forall a b. a -> b -> a
const (IO () -> Controller -> IO ()) -> IO () -> Controller -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
{-# INLINE animateArrayMassivIO #-}

-- | A more performant replacement of
-- [playArray](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html#v:playArray)
-- found in [Graphics.Gloss.Raster.Array](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html).
--
-- Play with a bitmap generated from a Massiv array.
playArrayMassiv :: 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 DMA.S Ix2 ColorMassiv) -- ^ 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 ()
playArrayMassiv :: forall world.
Display
-> (Int, Int)
-> Int
-> world
-> (world -> Array S Ix2 ColorMassiv)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
playArrayMassiv !Display
display scalemassiv :: (Int, Int)
scalemassiv@(Int
scaleX, Int
scaleY) !Int
stepRate
                !world
initWorld !world -> Array S Ix2 ColorMassiv
makeMassivArray !Event -> world -> world
handleEvent !Float -> world -> world
stepWorld =
  Int
scaleX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
scaleY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
scaleX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
scaleY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
     -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int, Int)
scalemassiv
     | Bool
otherwise
     -> let  {-# INLINE frame #-}
             frame :: world -> Picture
frame !world
world    = (Int, Int) -> Array S Ix2 ColorMassiv -> Picture
makeFrame (Int, Int)
scalemassiv (world -> Array S Ix2 ColorMassiv
makeMassivArray world
world)
        in   Display
-> Color
-> Int
-> world
-> (world -> Picture)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
forall world.
Display
-> Color
-> Int
-> world
-> (world -> Picture)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
play Display
display Color
black
                     Int
stepRate
                     world
initWorld
                     world -> Picture
frame
                     Event -> world -> world
handleEvent
                     Float -> world -> world
stepWorld
{-# INLINE playArrayMassiv #-}

-- | A more performant replacement of
-- [playArrayIO](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html#v:playArrayIO)
-- found in [Graphics.Gloss.Raster.Array](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html).
--
-- Play with a bitmap generated from a Massiv array, via the IO monad.
playArrayMassivIO :: 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 DMA.S Ix2 ColorMassiv)) -- ^ 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 ()
playArrayMassivIO :: forall world.
Display
-> (Int, Int)
-> Int
-> world
-> (world -> IO (Array S Ix2 ColorMassiv))
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playArrayMassivIO !Display
display scalemassiv :: (Int, Int)
scalemassiv@(Int
scaleX, Int
scaleY) !Int
stepRate
                  !world
initWorld !world -> IO (Array S Ix2 ColorMassiv)
makeMassivArray !Event -> world -> IO world
handleEvent !Float -> world -> IO world
stepWorld =
  Int
scaleX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
scaleY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
scaleX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
scaleY Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
     -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Graphics.Gloss.Raster.Array: invalid pixel scale factor "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int, Int)
scalemassiv
     | Bool
otherwise
     -> let  {-# INLINE frame #-}
             frame :: world -> IO Picture
frame !world
world    = (Array S Ix2 ColorMassiv -> Picture)
-> IO (Array S Ix2 ColorMassiv) -> IO Picture
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Int, Int) -> Array S Ix2 ColorMassiv -> Picture
makeFrame (Int, Int)
scalemassiv) (world -> IO (Array S Ix2 ColorMassiv)
makeMassivArray world
world)
        in  Display
-> Color
-> Int
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
forall world.
Display
-> Color
-> Int
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playIO Display
display Color
black
                     Int
stepRate
                     world
initWorld
                     world -> IO Picture
frame
                     Event -> world -> IO world
handleEvent
                     Float -> world -> IO world
stepWorld
{-# INLINE playArrayMassivIO #-}

-- | A more performant replacement of
-- [makeFrame](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html)
-- found in [Graphics.Gloss.Raster.Array](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Array.html).
makeFrame :: (Int,Int)
          -> Array DMA.S Ix2 ColorMassiv
          -> Picture
makeFrame :: (Int, Int) -> Array S Ix2 ColorMassiv -> Picture
makeFrame (Int
scaleX,Int
scaleY) !Array S Ix2 ColorMassiv
array
 = let  -- Size of the array
        (Sz2 Int
sizeY Int
sizeX) = Array S Ix2 ColorMassiv -> Sz Ix2
forall r ix e. Size r => Array r ix e -> Sz ix
forall ix e. Array S ix e -> Sz ix
DMA.size Array S Ix2 ColorMassiv
array

        convColor :: ColorMassiv
                  -> Word32
        convColor :: ColorMassiv -> Word32
convColor ColorMassiv
colormassiv
         = let  (Word8
r,Word8
g,Word8
b) = ColorMassiv -> (Word8, Word8, Word8)
unpackColorMassiv ColorMassiv
colormassiv
                r' :: Word32
r'      = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r
                g' :: Word32
g'      = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g
                b' :: Word32
b'      = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
                a :: Word32
a       = Word32
255
                !w :: Word32
w      =  Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
unsafeShiftL Word32
r' Int
24
                       Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
unsafeShiftL Word32
g' Int
16
                       Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
unsafeShiftL Word32
b' Int
8
                       Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
a
           in Word32
w
        {-# INLINE convColor #-}

   in IO Picture -> Picture
forall a. IO a -> a
unsafePerformIO (IO Picture -> Picture) -> IO Picture -> Picture
forall a b. (a -> b) -> a -> b
$ 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.
        [Char] -> IO ()
traceEventIO [Char]
"Gloss.Raster.Massiv[makeFrame]: start frame evaluation."
        (Array S Ix2 Word32
arrRGB :: Array DMA.S Ix2 Word32) <- (ColorMassiv -> IO Word32)
-> Array S Ix2 ColorMassiv -> IO (Array S Ix2 Word32)
forall r ix b r' a (m :: * -> *).
(Source r' a, Manifest r b, Index ix, PrimMonad m) =>
(a -> m b) -> Array r' ix a -> m (Array r ix b)
DMA.traversePrim (\ColorMassiv
x -> Word32 -> IO Word32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> IO Word32) -> Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ ColorMassiv -> Word32
convColor ColorMassiv
x) Array S Ix2 ColorMassiv
array
        [Char] -> IO ()
traceEventIO [Char]
"Gloss.Raster.Massiv[makeFrame]: done, returning picture."

        let arrRGBC :: Array S Ix2 Word8
arrRGBC = Array S Ix2 Word32 -> Array S Ix2 Word8
forall a b. a -> b
unsafeCoerce Array S Ix2 Word32
arrRGB :: Array DMA.S Ix2 Word8
        let arrRGBCFP :: ForeignPtr Word8
arrRGBCFP = (\(ForeignPtr Word8
a,Int
_) -> ForeignPtr Word8
a) ((ForeignPtr Word8, Int) -> ForeignPtr Word8)
-> (ForeignPtr Word8, Int) -> ForeignPtr Word8
forall a b. (a -> b) -> a -> b
$
                        Array S Ix2 Word8 -> (ForeignPtr Word8, Int)
forall ix e. Index ix => Array S ix e -> (ForeignPtr e, Int)
DMAU.unsafeArrayToForeignPtr Array S Ix2 Word8
arrRGBC
        -- Wrap the ForeignPtr from the Array as a gloss picture.
        let picture :: Picture
picture
                = Float -> Float -> Picture -> Picture
Scale (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
scaleX) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
scaleY)
                (Picture -> Picture) -> Picture -> Picture
forall a b. (a -> b) -> a -> b
$ Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture
bitmapOfForeignPtr
                        Int
sizeX Int
sizeY     -- raw image size
                        (RowOrder -> PixelFormat -> BitmapFormat
BitmapFormat RowOrder
BottomToTop PixelFormat
PxABGR)
                        ForeignPtr Word8
arrRGBCFP       -- the image data.
                        Bool
False           -- don't cache this in texture memory.

        Picture -> IO Picture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Picture
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 :: Float -> Word8
word8OfFloat Float
f
        = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Int
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Float
f :: Int)
{-# INLINE word8OfFloat #-}

-- | Function to unpack a ColorMassiv
-- into a triplet of Word8's.
unpackColorMassiv :: ColorMassiv
                  -> (Word8,Word8,Word8)
unpackColorMassiv :: ColorMassiv -> (Word8, Word8, Word8)
unpackColorMassiv ColorMassiv
c
        | (Float
r,Float
g,Float
b,Float
_) <- ColorMassiv -> (Float, Float, Float, Float)
rgbaOfColorMassiv ColorMassiv
c
        = ( Float -> Word8
word8OfFloat (Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255)
          , Float -> Word8
word8OfFloat (Float
g Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255)
          , Float -> Word8
word8OfFloat (Float
b Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
255)
          )
{-# INLINE unpackColorMassiv #-}

-- | Function that takes a display
-- and returns a tuple of the x and y scale.
sizeOfDisplay :: Display
              -> IO (Int,Int)
sizeOfDisplay :: Display -> IO (Int, Int)
sizeOfDisplay Display
display
 = case Display
display of
        InWindow [Char]
_ (Int, Int)
s (Int, Int)
_  -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int, Int)
s
        Display
FullScreen      -> IO (Int, Int)
getScreenSize
{-# INLINE sizeOfDisplay #-}