{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-}
module Graphics.Gloss.Raster.Array (
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
animateArrayMassiv :: Display
-> (Int,Int)
-> (Float -> Array DMA.S Ix2 ColorMassiv)
-> 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
-> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
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 #-}
animateArrayMassivIO :: Display
-> (Int,Int)
-> (Float -> IO (Array DMA.S Ix2 ColorMassiv))
-> 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
-> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
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 #-}
playArrayMassiv :: Display
-> (Int,Int)
-> Int
-> world
-> (world -> Array DMA.S Ix2 ColorMassiv)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> 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
-> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
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 #-}
playArrayMassivIO :: Display
-> (Int,Int)
-> Int
-> world
-> (world -> IO (Array DMA.S Ix2 ColorMassiv))
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> 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
-> String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Graphics.Gloss.Raster.Array: invalid pixel scale factor "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int, Int) -> String
forall a. Show a => a -> String
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 #-}
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
(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
String -> IO ()
traceEventIO String
"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
String -> IO ()
traceEventIO String
"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
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
(RowOrder -> PixelFormat -> BitmapFormat
BitmapFormat RowOrder
BottomToTop PixelFormat
PxABGR)
ForeignPtr Word8
arrRGBCFP
Bool
False
()
_ <- String -> IO ()
forall a. Show a => a -> IO ()
print String
"picture success"
Picture -> IO Picture
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Picture
picture
{-# INLINE makeFrame #-}
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 #-}
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 #-}
sizeOfDisplay :: Display
-> IO (Int,Int)
sizeOfDisplay :: Display -> IO (Int, Int)
sizeOfDisplay Display
display
= case Display
display of
InWindow String
_ (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 #-}