diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,3 +20,7 @@ ## 0.1.0.4 -- 2023-07-25 * Removed extraneous print statement in makeFrame function in Graphics.Gloss.Raster.Array. + +## 0.1.1.4 -- 2023-08-04 + +* Added Graphics.Gloss.Raster.Field. diff --git a/gloss-raster-massiv.cabal b/gloss-raster-massiv.cabal --- a/gloss-raster-massiv.cabal +++ b/gloss-raster-massiv.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.1.0.4 +version: 0.1.1.4 -- A short (one-line) description of the package. synopsis: Massiv-based alternative for gloss-raster @@ -66,6 +66,7 @@ -- Modules exported by the library. exposed-modules: Graphics.Gloss.Raster.Array, + Graphics.Gloss.Raster.Field, Graphics.Gloss.Raster.Massiv.Internal -- Modules included in this library but not exported. diff --git a/src/Graphics/Gloss/Raster/Array.hs b/src/Graphics/Gloss/Raster/Array.hs --- a/src/Graphics/Gloss/Raster/Array.hs +++ b/src/Graphics/Gloss/Raster/Array.hs @@ -7,7 +7,6 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -fplugin=Foreign.Storable.Generic.Plugin #-} -- | -- Module : Graphics.Gloss.Raster.Array diff --git a/src/Graphics/Gloss/Raster/Field.hs b/src/Graphics/Gloss/Raster/Field.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Raster/Field.hs @@ -0,0 +1,296 @@ +{-# 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 (zoomX, zoomY) makePixel = + zoomX `seq` zoomY `seq` + if | zoomX < 1 || zoomY < 1 + -> error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor" + ++ show (zoomX, zoomY) + | otherwise + -> do (winSizeX, winSizeY) <- sizeOfDisplay display + let frame !time + = return + $ makePicture winSizeX winSizeY zoomX zoomY (makePixel time) + animateFixedIO display black frame (const $ 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 (zoomX, zoomY) makePixel = + zoomX `seq` zoomY `seq` + if | zoomX < 1 || zoomY < 1 + -> error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor" + ++ show (zoomX, zoomY) + | otherwise + -> do (winSizeX, winSizeY) <- sizeOfDisplay display + let frame !time + = makePicture winSizeX winSizeY zoomX zoomY <$> makePixel time + animateFixedIO display black frame (const $ 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 !display (zoomX, zoomY) !stepRate + !initWorld !makePixel !handleEvent !stepWorld = + zoomX `seq` zoomY `seq` + if | zoomX < 1 || zoomY < 1 + -> error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor" + ++ show (zoomX, zoomY) + | otherwise + -> do (winSizeX, winSizeY) <- sizeOfDisplay display + winSizeX `seq` winSizeY `seq` + play display black stepRate + ((winSizeX, winSizeY), initWorld) + (\((winSizeX', winSizeY'), world) -> + winSizeX' `seq` winSizeY' `seq` world `seq` + makePicture winSizeX' winSizeY' zoomX zoomY (makePixel world)) + (\event (winSize, world) -> + let winSize' = + case event of + EventResize dims -> dims + _ -> winSize + in (winSize', handleEvent event world)) + (fmap . 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 !display (zoomX, zoomY) !stepRate + !initWorld !makePixel !handleEvent !stepWorld = + zoomX `seq` zoomY `seq` + if | zoomX < 1 || zoomY < 1 + -> error $ "Graphics.Gloss.Raster.Field: invalid pixel scale factor " + ++ show (zoomX, zoomY) + | otherwise + -> do (winSizeX, winSizeY) <- sizeOfDisplay display + winSizeX `seq` winSizeY `seq` + playIO display black stepRate + ((winSizeX, winSizeY), initWorld) + (\((winSizeX', winSizeY'), world) -> + winSizeX' `seq` winSizeY' `seq` world `seq` + makePicture winSizeX' winSizeY' zoomX zoomY <$> makePixel world) + (\event (winSize, world) -> + let winSize' = + case event of + EventResize dims -> dims + _ -> winSize + in (,) winSize' <$> handleEvent event world) + (\time (winSize, world) -> (,) winSize <$> stepWorld time 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 !winSizeX !winSizeY !zoomX !zoomY !makePixel = + let -- Size of the raw image to render. + sizeX = winSizeX `div` zoomX + sizeY = winSizeY `div` zoomY + + {-# INLINE conv #-} + conv (r, g, b) + = let r' = fromIntegral r + g' = fromIntegral g + b' = fromIntegral b + a = 255 + + !w = unsafeShiftL r' 24 + .|. unsafeShiftL g' 16 + .|. unsafeShiftL b' 8 + .|. a + in w + + 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[makePicture]: start frame evaluation." + (arrRGBTriplet :: Array DMA.S Ix2 RGBTriplet) <- makeFrame sizeX + sizeY + makePixel + (arrRGB :: Array DMA.S Ix2 Word32) <- DMA.traversePrim (\x -> return $ conv ( (\(RGBTriplet a _ _) -> a) x + , (\(RGBTriplet _ b _) -> b) x + , (\(RGBTriplet _ _ c) -> c) x + ) + ) + arrRGBTriplet + traceEventIO "Gloss.Raster[makePicture]: done, returning picture." + + let arrRGBC = unsafeCoerce arrRGB :: Array DMA.S Ix2 Word8 + let arrRGBCFP = (\(a,_) -> a) $ + DMAU.unsafeArrayToForeignPtr arrRGBC + -- Wrap the ForeignPtr from the Array as a gloss picture. + let picture + = Scale (fromIntegral zoomX) (fromIntegral zoomY) + $ bitmapOfForeignPtr + sizeX sizeY -- raw image size + (BitmapFormat BottomToTop PxABGR) + arrRGBCFP -- the image data. + False -- don't cache this in texture memory. + + return 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 !sizeX !sizeY !makePixel = do + let !pixelofindexarray = DMA.makeArray Par + (Sz2 sizeY sizeX) + (\(i :. j) -> pixelOfIndex (Ix2 j i)) :: Array DMA.S Ix2 ColorMassiv + (!rgbtripletarray :: Array DMA.S Ix2 RGBTriplet) <- DMA.traversePrim (\x -> return $ unpackColorMassiv x) pixelofindexarray + return rgbtripletarray + where + fsizeX, fsizeY :: Float + !fsizeX = fromIntegral sizeX + !fsizeY = fromIntegral sizeY + + fsizeX2, fsizeY2 :: Float + !fsizeX2 = fsizeX / 2 + !fsizeY2 = fsizeY / 2 + + -- Midpoint of image. + midX, midY :: Int + !midX = sizeX `div` 2 + !midY = sizeY `div` 2 + + {-# INLINE pixelOfIndex #-} + pixelOfIndex (Ix2 y x) + = let x' = fromIntegral (x - midX) / fsizeX2 + y' = fromIntegral (y - midY) / fsizeY2 + in makePixel (x',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 f + = fromIntegral (truncate f :: Int) +{-# INLINE word8OfFloat #-} + +-- | Function to unpack a ColorMassiv +-- into a triplet of Word8's (RGBTriplet). +unpackColorMassiv :: ColorMassiv + -> RGBTriplet +unpackColorMassiv c + | (r,g,b,_) <- rgbaOfColorMassiv c + = RGBTriplet (word8OfFloat (r * 255)) + (word8OfFloat (g * 255)) + (word8OfFloat (b * 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 + = case display of + InWindow _ s _ -> return s + FullScreen -> getScreenSize +{-# INLINE sizeOfDisplay #-} diff --git a/src/Graphics/Gloss/Raster/Massiv/Internal.hs b/src/Graphics/Gloss/Raster/Massiv/Internal.hs --- a/src/Graphics/Gloss/Raster/Massiv/Internal.hs +++ b/src/Graphics/Gloss/Raster/Massiv/Internal.hs @@ -38,6 +38,7 @@ module Graphics.Gloss.Raster.Massiv.Internal ( -- * Graphics.Gloss.Raster.Array Replacement functions - INTERNAL ColorMassiv(..), + RGBTriplet(..), rgbMassiv, rgbMassivI, rgbMassiv8w, @@ -86,6 +87,12 @@ {-# INLINE fromInteger #-} instance GStorable ColorMassiv + +-- | Custom data type for makeFrame function in @"Grahpics.Gloss.Raster.Field"@. +data RGBTriplet = RGBTriplet Word8 Word8 Word8 + deriving (Show,Eq,Data,Generic,Typeable) + +instance GStorable RGBTriplet -- | Make a custom color. All components are clamped to the range [0..1]. makeColorMassiv :: Float -- ^ Red component.