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

-- |
-- Module      :  Graphics.Gloss.Raster.Field
-- 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.Field ( -- * Graphics.Gloss.Raster.Field Replacement functions - Display functions
                                     animateFieldMassiv,
                                     playFieldMassiv,
                                     animateFieldMassivIO,
                                     playFieldMassivIO,
                                     -- * Graphics.Gloss.Raster.Field Replacement functions - Frame creation
                                     makePicture,
                                     makeFrame,
                                     -- * Graphics.Gloss.Raster.Field Replacement functions - Size of Display
                                     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
-- [animateField](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:animateField)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
--
-- Animate a continuous 2D function from a Massiv array.
animateFieldMassiv :: Display                         -- ^ Display mode.
                   -> (Int,Int)                       -- ^ Number of pixels to draw per point.
                   -> (Float -> Point -> ColorMassiv) -- ^ Function to compute the color at a particular point.
                                                      --
                                                      --   It is passed the time in seconds since the program started,
                                                      --   and a point between (-1, -1) and (+1, +1).
                   -> IO ()
animateFieldMassiv :: Display -> (Int, Int) -> (Float -> Point -> ColorMassiv) -> IO ()
animateFieldMassiv Display
display (Int
zoomX, Int
zoomY) Float -> Point -> ColorMassiv
makePixel =
  Int
zoomX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
zoomY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
zoomX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
zoomY 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.Field: invalid pixel scale factor"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
zoomX, Int
zoomY)
     | Bool
otherwise
     -> do (Int
winSizeX, Int
winSizeY) <- Display -> IO (Int, Int)
sizeOfDisplay Display
display
           let  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 -> Int -> Int -> (Point -> ColorMassiv) -> Picture
makePicture Int
winSizeX Int
winSizeY Int
zoomX Int
zoomY (Float -> Point -> ColorMassiv
makePixel Float
time)
           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 animateFieldMassiv #-}

-- | A more performant replacement of
-- [animateFieldIO](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:animateFieldIO)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
--
-- Animate a continuous 2D function from a Massiv array, via the IO monad.
animateFieldMassivIO :: Display                              -- ^ Display mode.
                     -> (Int,Int)                            -- ^ Number of pixels to draw per point.
                     -> (Float -> IO (Point -> ColorMassiv)) -- ^ Function to compute the color at a particular point.
                                                             --
                                                             --   It is passed the time in seconds since the program started,
                                                             --   and a point between (-1, -1) and (+1, +1).
                     -> IO ()
animateFieldMassivIO :: Display
-> (Int, Int) -> (Float -> IO (Point -> ColorMassiv)) -> IO ()
animateFieldMassivIO Display
display (Int
zoomX, Int
zoomY) Float -> IO (Point -> ColorMassiv)
makePixel =
  Int
zoomX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
zoomY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
zoomX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
zoomY 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.Field: invalid pixel scale factor"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
zoomX, Int
zoomY)
     | Bool
otherwise
     -> do (Int
winSizeX, Int
winSizeY) <- Display -> IO (Int, Int)
sizeOfDisplay Display
display
           let  frame :: Float -> IO Picture
frame !Float
time
                  = Int -> Int -> Int -> Int -> (Point -> ColorMassiv) -> Picture
makePicture Int
winSizeX Int
winSizeY Int
zoomX Int
zoomY ((Point -> ColorMassiv) -> Picture)
-> IO (Point -> ColorMassiv) -> IO Picture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Float -> IO (Point -> ColorMassiv)
makePixel Float
time
           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 animateFieldMassivIO #-}

-- | A more performant replacement of
-- [playField](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:playField)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
--
-- Play a game with a continuous 2D function generated from a Massiv array.
playFieldMassiv :: Display                         -- ^ Display mode.
                -> (Int,Int)                       -- ^ Number of pixels to draw per point.
                -> Int                             -- ^ Number of simulation steps to take
                                                   --   for each second of real time
                -> world                           -- ^ The initial world.
                -> (world -> Point -> ColorMassiv) -- ^ Function to compute the color of the world at the given point.
                -> (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 ()
playFieldMassiv :: forall world.
Display
-> (Int, Int)
-> Int
-> world
-> (world -> Point -> ColorMassiv)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
playFieldMassiv !Display
display (Int
zoomX, Int
zoomY) !Int
stepRate
                !world
initWorld !world -> Point -> ColorMassiv
makePixel !Event -> world -> world
handleEvent !Float -> world -> world
stepWorld =
  Int
zoomX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
zoomY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
zoomX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
zoomY 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.Field: invalid pixel scale factor"
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
zoomX, Int
zoomY)
     | Bool
otherwise
     -> do (Int
winSizeX, Int
winSizeY) <- Display -> IO (Int, Int)
sizeOfDisplay Display
display
           Int
winSizeX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
winSizeY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
             Display
-> Color
-> Int
-> ((Int, Int), world)
-> (((Int, Int), world) -> Picture)
-> (Event -> ((Int, Int), world) -> ((Int, Int), world))
-> (Float -> ((Int, Int), world) -> ((Int, Int), world))
-> IO ()
forall world.
Display
-> Color
-> Int
-> world
-> (world -> Picture)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
play Display
display Color
black Int
stepRate
                ((Int
winSizeX, Int
winSizeY), world
initWorld)
                (\((Int
winSizeX', Int
winSizeY'), world
world) ->
                   Int
winSizeX' Int -> Picture -> Picture
forall a b. a -> b -> b
`seq` Int
winSizeY' Int -> Picture -> Picture
forall a b. a -> b -> b
`seq` world
world world -> Picture -> Picture
forall a b. a -> b -> b
`seq`
                   Int -> Int -> Int -> Int -> (Point -> ColorMassiv) -> Picture
makePicture Int
winSizeX' Int
winSizeY' Int
zoomX Int
zoomY (world -> Point -> ColorMassiv
makePixel world
world))
                (\Event
event ((Int, Int)
winSize, world
world) ->
                   let winSize' :: (Int, Int)
winSize' =
                         case Event
event of
                           EventResize (Int, Int)
dims -> (Int, Int)
dims
                           Event
_                -> (Int, Int)
winSize
                   in ((Int, Int)
winSize', Event -> world -> world
handleEvent Event
event world
world))
                ((world -> world) -> ((Int, Int), world) -> ((Int, Int), world)
forall a b. (a -> b) -> ((Int, Int), a) -> ((Int, Int), b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((world -> world) -> ((Int, Int), world) -> ((Int, Int), world))
-> (Float -> world -> world)
-> Float
-> ((Int, Int), world)
-> ((Int, Int), world)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> world -> world
stepWorld)
{-# INLINE playFieldMassiv #-}

-- | A more performant replacement of
-- [playFieldIO](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:playFieldIO)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
--
-- Play a game with a continuous 2D function generated from a Massiv array, via the IO monad.
playFieldMassivIO :: Display                              -- ^ Display mode.
                  -> (Int,Int)                            -- ^ Number of pixels to draw per point.
                  -> Int                                  -- ^ Number of simulation steps to take
                                                          --   for each second of real time
                  -> world                                -- ^ The initial world.
                  -> (world -> IO (Point -> ColorMassiv)) -- ^ Function to compute the color of the world at the given point.
                  -> (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 ()
playFieldMassivIO :: forall world.
Display
-> (Int, Int)
-> Int
-> world
-> (world -> IO (Point -> ColorMassiv))
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playFieldMassivIO !Display
display (Int
zoomX, Int
zoomY) !Int
stepRate
                !world
initWorld !world -> IO (Point -> ColorMassiv)
makePixel !Event -> world -> IO world
handleEvent !Float -> world -> IO world
stepWorld =
  Int
zoomX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
zoomY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
  if | Int
zoomX Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
zoomY 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.Field: invalid pixel scale factor "
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Int
zoomX, Int
zoomY)
     | Bool
otherwise
     -> do (Int
winSizeX, Int
winSizeY) <- Display -> IO (Int, Int)
sizeOfDisplay Display
display
           Int
winSizeX Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq` Int
winSizeY Int -> IO () -> IO ()
forall a b. a -> b -> b
`seq`
             Display
-> Color
-> Int
-> ((Int, Int), world)
-> (((Int, Int), world) -> IO Picture)
-> (Event -> ((Int, Int), world) -> IO ((Int, Int), world))
-> (Float -> ((Int, Int), world) -> IO ((Int, Int), 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
                ((Int
winSizeX, Int
winSizeY), world
initWorld)
                (\((Int
winSizeX', Int
winSizeY'), world
world) ->
                   Int
winSizeX' Int -> IO Picture -> IO Picture
forall a b. a -> b -> b
`seq` Int
winSizeY' Int -> IO Picture -> IO Picture
forall a b. a -> b -> b
`seq` world
world world -> IO Picture -> IO Picture
forall a b. a -> b -> b
`seq`
                   Int -> Int -> Int -> Int -> (Point -> ColorMassiv) -> Picture
makePicture Int
winSizeX' Int
winSizeY' Int
zoomX Int
zoomY ((Point -> ColorMassiv) -> Picture)
-> IO (Point -> ColorMassiv) -> IO Picture
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> world -> IO (Point -> ColorMassiv)
makePixel world
world)
                (\Event
event ((Int, Int)
winSize, world
world) ->
                   let winSize' :: (Int, Int)
winSize' =
                         case Event
event of
                           EventResize (Int, Int)
dims -> (Int, Int)
dims
                           Event
_                -> (Int, Int)
winSize
                   in (,) (Int, Int)
winSize' (world -> ((Int, Int), world))
-> IO world -> IO ((Int, Int), world)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> world -> IO world
handleEvent Event
event world
world)
                (\Float
time ((Int, Int)
winSize, world
world) -> (,) (Int, Int)
winSize (world -> ((Int, Int), world))
-> IO world -> IO ((Int, Int), world)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Float -> world -> IO world
stepWorld Float
time world
world)
{-# INLINE playFieldMassivIO #-}

-- | A more performant replacement of
-- [makePicture](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:makePicture)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
makePicture :: Int               -- Window Size X
            -> Int               -- Window Size Y
            -> Int               -- Pixels X
            -> Int               -- Pixels Y
            -> (Point -> ColorMassiv)
            -> Picture
makePicture :: Int -> Int -> Int -> Int -> (Point -> ColorMassiv) -> Picture
makePicture !Int
winSizeX !Int
winSizeY !Int
zoomX !Int
zoomY !Point -> ColorMassiv
makePixel =
  let  -- Size of the raw image to render.
       sizeX :: Int
sizeX = Int
winSizeX Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
zoomX
       sizeY :: Int
sizeY = Int
winSizeY Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
zoomY

       {-# INLINE conv #-}
       conv :: (a, b, c) -> b
conv (a
r, b
g, c
b)
        = let  r' :: b
r'      = a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
r
               g' :: b
g'      = b -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
g
               b' :: b
b'      = c -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral c
b
               a :: b
a       = b
255

               !w :: b
w      =   b -> Int -> b
forall a. Bits a => a -> Int -> a
unsafeShiftL b
r' Int
24
                       b -> b -> b
forall a. Bits a => a -> a -> a
.|. b -> Int -> b
forall a. Bits a => a -> Int -> a
unsafeShiftL b
g' Int
16
                       b -> b -> b
forall a. Bits a => a -> a -> a
.|. b -> Int -> b
forall a. Bits a => a -> Int -> a
unsafeShiftL b
b' Int
8
                       b -> b -> b
forall a. Bits a => a -> a -> a
.|. b
a
          in   b
w

   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[makePicture]: start frame evaluation."
        (Array S Ix2 RGBTriplet
arrRGBTriplet :: Array DMA.S Ix2 RGBTriplet) <- Int -> Int -> (Point -> ColorMassiv) -> IO (Array S Ix2 RGBTriplet)
forall (m :: * -> *).
PrimMonad m =>
Int -> Int -> (Point -> ColorMassiv) -> m (Array S Ix2 RGBTriplet)
makeFrame Int
sizeX
                                                                   Int
sizeY
                                                                   Point -> ColorMassiv
makePixel
        (Array S Ix2 Word32
arrRGB :: Array DMA.S Ix2 Word32) <- (RGBTriplet -> IO Word32)
-> Array S Ix2 RGBTriplet -> 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 (\RGBTriplet
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
$ (Word8, Word8, Word8) -> Word32
forall {c} {b} {a} {b}.
(Integral c, Integral b, Integral a, Num b, Bits b) =>
(a, b, c) -> b
conv ( (\(RGBTriplet Word8
a Word8
_ Word8
_) -> Word8
a) RGBTriplet
x
                                                                                    , (\(RGBTriplet Word8
_ Word8
b Word8
_) -> Word8
b) RGBTriplet
x
                                                                                    , (\(RGBTriplet Word8
_ Word8
_ Word8
c) -> Word8
c) RGBTriplet
x
                                                                                    )
                                                               )
                                              Array S Ix2 RGBTriplet
arrRGBTriplet
        [Char] -> IO ()
traceEventIO [Char]
"Gloss.Raster[makePicture]: 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
zoomX) (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
zoomY)
                (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 makePicture #-}

-- | A more performant replacement of
-- [makeFrame](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html#v:makeFrame)
-- found in [Graphics.Gloss.Raster.Field](https://hackage.haskell.org/package/gloss-raster-1.13.1.2/docs/Graphics-Gloss-Raster-Field.html).
makeFrame :: PrimMonad m
          => Int                  -- Array Size X
          -> Int                  -- Array Size Y
          -> (Point -> ColorMassiv)
          -> m (Array DMA.S Ix2 RGBTriplet)
makeFrame :: forall (m :: * -> *).
PrimMonad m =>
Int -> Int -> (Point -> ColorMassiv) -> m (Array S Ix2 RGBTriplet)
makeFrame !Int
sizeX !Int
sizeY !Point -> ColorMassiv
makePixel = do
  let !pixelofindexarray :: Array S Ix2 ColorMassiv
pixelofindexarray = Comp -> Sz Ix2 -> (Ix2 -> ColorMassiv) -> Array S Ix2 ColorMassiv
forall r ix e.
Load r ix e =>
Comp -> Sz ix -> (ix -> e) -> Array r ix e
DMA.makeArray Comp
Par
                                         (Int -> Int -> Sz Ix2
Sz2 Int
sizeY Int
sizeX)
                                         (\(Int
i :. Int
j) -> Ix2 -> ColorMassiv
pixelOfIndex (Int -> Int -> Ix2
Ix2 Int
j Int
i)) :: Array DMA.S Ix2 ColorMassiv
  (!Array S Ix2 RGBTriplet
rgbtripletarray :: Array DMA.S Ix2 RGBTriplet) <- (ColorMassiv -> m RGBTriplet)
-> Array S Ix2 ColorMassiv -> m (Array S Ix2 RGBTriplet)
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 -> RGBTriplet -> m RGBTriplet
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RGBTriplet -> m RGBTriplet) -> RGBTriplet -> m RGBTriplet
forall a b. (a -> b) -> a -> b
$ ColorMassiv -> RGBTriplet
unpackColorMassiv ColorMassiv
x) Array S Ix2 ColorMassiv
pixelofindexarray
  Array S Ix2 RGBTriplet -> m (Array S Ix2 RGBTriplet)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Array S Ix2 RGBTriplet
rgbtripletarray
    where
      fsizeX, fsizeY  :: Float
      !fsizeX :: Float
fsizeX          = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX
      !fsizeY :: Float
fsizeY          = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY

      fsizeX2, fsizeY2 :: Float
      !fsizeX2 :: Float
fsizeX2        = Float
fsizeX Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
      !fsizeY2 :: Float
fsizeY2        = Float
fsizeY Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2

       -- Midpoint of image.
      midX, midY :: Int
      !midX :: Int
midX           = Int
sizeX Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
      !midY :: Int
midY           = Int
sizeY Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
      
      {-# INLINE pixelOfIndex #-}
      pixelOfIndex :: Ix2 -> ColorMassiv
pixelOfIndex (Ix2 Int
y Int
x)
       = let  x' :: Float
x'      = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
midX) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
fsizeX2
              y' :: Float
y'      = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
midY) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
fsizeY2
         in   Point -> ColorMassiv
makePixel (Float
x',Float
y')
{-# 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 (RGBTriplet).
unpackColorMassiv :: ColorMassiv
                  -> RGBTriplet
unpackColorMassiv :: ColorMassiv -> RGBTriplet
unpackColorMassiv ColorMassiv
c
        | (Float
r,Float
g,Float
b,Float
_) <- ColorMassiv -> (Float, Float, Float, Float)
rgbaOfColorMassiv ColorMassiv
c
        = Word8 -> Word8 -> Word8 -> RGBTriplet
RGBTriplet (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 #-}