diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for gloss-raster-massiv + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Matthew Mosior + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Matthew Mosior nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/gloss-raster-massiv.cabal b/gloss-raster-massiv.cabal new file mode 100644 --- /dev/null +++ b/gloss-raster-massiv.cabal @@ -0,0 +1,111 @@ +cabal-version: 3.0 +-- The cabal-version field refers to the version of the .cabal specification, +-- and can be different from the cabal-install (the tool) version and the +-- Cabal (the library) version you are using. As such, the Cabal (the library) +-- version used must be equal or greater than the version stated in this field. +-- Starting from the specification version 2.2, the cabal-version field must be +-- the first thing in the cabal file. + +-- Initial package description 'gloss-raster-massiv' generated by +-- 'cabal init'. For further documentation, see: +-- http://haskell.org/cabal/users-guide/ +-- +-- The name of the package. +name: gloss-raster-massiv + +-- The package version. +-- See the Haskell package versioning policy (PVP) for standards +-- guiding when and how versions should be incremented. +-- https://pvp.haskell.org +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Massiv-based alternative for gloss-raster + +-- A longer description of the package. +description: This library utilizes massiv's superb performance characteristics to supply alternative rasterization functionality to that which is provided by the gloss-raster package. + +-- The license under which the package is released. +license: BSD-3-Clause + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Matthew Mosior + +-- An email address to which users can send suggestions, bug reports, and patches. +maintainer: mattm.github@gmail.com + +-- A copyright notice. +-- copyright: +category: Graphics +build-type: Simple + +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md + +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: + +common warnings + ghc-options: -Wall + +library + -- Import common warning flags. + import: warnings + + -- Modules exported by the library. + exposed-modules: Graphics.Gloss.Raster.Array, + Graphics.Gloss.Raster.Massiv.Internal + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base ^>=4.17.1.0, + derive-storable >= 0.3.1 && < 0.4, + derive-storable-plugin >= 0.2.3 && < 0.3, + generic-deriving >= 1.14.4 && < 1.15, + gloss >= 1.13.2 && < 1.14, + gloss-rendering >= 1.13.1 && < 1.14, + massiv >= 1.0.4 && < 1.1 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + +test-suite gloss-raster-massiv-test + -- Import common warning flags. + import: warnings + + -- Base language which the package is written in. + default-language: Haskell2010 + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- The interface type and version of the test suite. + type: exitcode-stdio-1.0 + + -- Directories containing source files. + hs-source-dirs: test + + -- The entrypoint to the test suite. + main-is: Main.hs + + -- Test dependencies. + build-depends: + base ^>=4.17.1.0, + gloss-raster-massiv diff --git a/src/Graphics/Gloss/Raster/Array.hs b/src/Graphics/Gloss/Raster/Array.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Raster/Array.hs @@ -0,0 +1,234 @@ +{-# 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 +-- 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, + 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 scalemassiv@(scaleX, scaleY) makeMassivArray = + scaleX `seq` scaleY `seq` + if | scaleX < 1 || scaleY < 1 + -> error $ "Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor " + ++ show (scaleX,scaleY) + | otherwise + -> let {-# INLINE frame #-} + frame !time = return $ makeFrame scalemassiv (makeMassivArray time) + in animateFixedIO display black frame (const $ 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 scalemassiv@(scaleX, scaleY) makeMassivArray = + scaleX `seq` scaleY `seq` + if | scaleX < 1 || scaleY < 1 + -> error $ "Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor " + ++ show (scaleX,scaleY) + | otherwise + -> let {-# INLINE frame #-} + frame !time = fmap (makeFrame scalemassiv) (makeMassivArray time) + in animateFixedIO display black frame (const $ 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 !display scalemassiv@(scaleX, scaleY) !stepRate + !initWorld !makeMassivArray !handleEvent !stepWorld = + scaleX `seq` scaleY `seq` + if | scaleX < 1 || scaleY < 1 + -> error $ "Graphics.Gloss.Raster.Massiv.Array: invalid pixel scale factor " + ++ show scalemassiv + | otherwise + -> let {-# INLINE frame #-} + frame !world = makeFrame scalemassiv (makeMassivArray world) + in play display black + stepRate + initWorld + frame + handleEvent + 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 !display scalemassiv@(scaleX, scaleY) !stepRate + !initWorld !makeMassivArray !handleEvent !stepWorld = + scaleX `seq` scaleY `seq` + if | scaleX < 1 || scaleY < 1 + -> error $ "Graphics.Gloss.Raster.Array: invalid pixel scale factor " + ++ show scalemassiv + | otherwise + -> let {-# INLINE frame #-} + frame !world = fmap (makeFrame scalemassiv) (makeMassivArray world) + in playIO display black + stepRate + initWorld + frame + handleEvent + 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 (scaleX,scaleY) !array + = let -- Size of the array + (Sz2 sizeY sizeX) = DMA.size array + + convColor :: ColorMassiv + -> Word32 + convColor colormassiv + = let (r,g,b) = unpackColorMassiv colormassiv + 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.Massiv[makeFrame]: start frame evaluation." + let arrRGB = DMA.map convColor array :: Array DMA.D Ix2 Word32 + traceEventIO "Gloss.Raster.Massiv[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) + ((\(a,_) -> a) $ DMAU.unsafeArrayToForeignPtr $ (unsafeCoerce arrRGB :: Array DMA.S Ix2 Word8)) + -- 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 #-} + +-- | Function to unpack a ColorMassiv +-- into a triplet of Word8's. +unpackColorMassiv :: ColorMassiv + -> (Word8,Word8,Word8) +unpackColorMassiv c + | (r,g,b,_) <- rgbaOfColorMassiv c + = ( 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Raster/Massiv/Internal.hs @@ -0,0 +1,212 @@ +{-# 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.Massiv.Internal +-- Copyright : (c) Matthew Mosior 2023 +-- License : BSD-style +-- Maintainer : mattm.github@gmail.com +-- Portability : portable +-- +-- = WARNING +-- +-- This module is considered __internal__. +-- +-- The Package Versioning Policy __does not apply__. +-- +-- The contents of this module may change __in any way whatsoever__ +-- and __without any warning__ between minor versions of this package. +-- +-- Authors importing this library are expected to track development +-- closely. +-- +-- All credit goes to the author(s)/maintainer(s) of the +-- [containers](https://hackage.haskell.org/package/containers) library +-- for the above warning text. +-- +-- = Description +-- +-- 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.Massiv.Internal ( -- * Graphics.Gloss.Raster.Array Replacement functions - INTERNAL + ColorMassiv(..), + rgbMassiv, + rgbMassivI, + rgbMassiv8w, + rgbMassiv', + rgbMassivI', + makeColorMassiv, + makeColorMassivI, + makeRawColorMassiv, + makeRawColorMassivI, + rgbaOfColorMassiv + ) where + +import Data.Data +import Data.Word +import Foreign.Storable.Generic +import Generics.Deriving.Base + +-- | Custom [Color](https://hackage.haskell.org/package/gloss-rendering-1.13.1.1/docs/Graphics-Gloss-Rendering.html#t:Color) data type. +data ColorMassiv = RGBA !Float !Float !Float !Float + deriving (Show,Eq,Data,Generic,Typeable) + +instance Num ColorMassiv where + (+) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 + r2) (g1 + g2) (b1 + b2) 1 + {-# INLINE (+) #-} + + (-) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 - r2) (g1 - g2) (b1 - b2) 1 + {-# INLINE (-) #-} + + (*) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) + = RGBA (r1 * r2) (g1 * g2) (b1 * b2) 1 + {-# INLINE (*) #-} + + abs (RGBA r1 g1 b1 _) + = RGBA (abs r1) (abs g1) (abs b1) 1 + {-# INLINE abs #-} + + signum (RGBA r1 g1 b1 _) + = RGBA (signum r1) (signum g1) (signum b1) 1 + {-# INLINE signum #-} + + fromInteger i + = let f = fromInteger i + in RGBA f f f 1 + {-# INLINE fromInteger #-} + +instance GStorable ColorMassiv + +-- | Make a custom color. All components are clamped to the range [0..1]. +makeColorMassiv :: Float -- ^ Red component. + -> Float -- ^ Green component. + -> Float -- ^ Blue component. + -> Float -- ^ Alpha component. + -> ColorMassiv +makeColorMassiv r g b a + = clampColorMassiv + $ RGBA r g b a +{-# INLINE makeColorMassiv #-} + +-- | Make a custom color. All components are clamped to the range [0..255]. +makeColorMassivI :: Int + -> Int + -> Int + -> Int + -> ColorMassiv +makeColorMassivI r g b a + = clampColorMassiv + $ RGBA (fromIntegral r / 255) + (fromIntegral g / 255) + (fromIntegral b / 255) + (fromIntegral a / 255) +{-# INLINE makeColorMassivI #-} + +-- | Make a custom color. +-- +-- Using this function over `makeColor` avoids clamping the components, +-- which saves time. However, if the components are out of range then +-- this will result in integer overflow at rendering time, and the actual +-- picture you get will be implementation dependent. +-- +-- You'll only need to use this function when using the @gloss-raster@ +-- package that builds a new color for every pixel. If you're just working +-- with the Picture data type then it there is no need for raw colors. +makeRawColorMassiv :: Float + -> Float + -> Float + -> Float + -> ColorMassiv +makeRawColorMassiv r g b a + = RGBA r g b a +{-# INLINE makeRawColorMassiv #-} + +-- | Make a custom color, taking pre-clamped components. +makeRawColorMassivI :: Int + -> Int + -> Int + -> Int + -> ColorMassiv +makeRawColorMassivI r g b a + = RGBA (fromIntegral r / 255) + (fromIntegral g / 255) + (fromIntegral b / 255) + (fromIntegral a / 255) +{-# INLINE makeRawColorMassivI #-} + +-- | Take the RGBA components of a color. +rgbaOfColorMassiv :: ColorMassiv + -> (Float,Float,Float,Float) +rgbaOfColorMassiv (RGBA r g b a) = (r,g,b,a) +{-# INLINE rgbaOfColorMassiv #-} + + +-- | Clamp components of a raw color into the required range. +clampColorMassiv :: ColorMassiv + -> ColorMassiv +clampColorMassiv cc + = let (r,g,b,a) = rgbaOfColorMassiv cc + clamp x = (min (max x 0.0) 1.0) + in RGBA (clamp r) (clamp g) (clamp b) (clamp a) + +-- | Construct a color from red, green, blue components. +-- +-- Each component is clamped to the range [0..1] +rgbMassiv :: Float + -> Float + -> Float + -> ColorMassiv +rgbMassiv r g b = makeColorMassiv r g b 1.0 +{-# INLINE rgbMassiv #-} + +-- | Construct a color from red, green, blue components. +-- +-- Each component is clamped to the range [0..255] +rgbMassivI :: Int + -> Int + -> Int + -> ColorMassiv +rgbMassivI r g b = makeColorMassivI r g b 255 +{-# INLINE rgbMassivI #-} + +-- | Construct a color from red, green, blue components. +rgbMassiv8w :: Word8 + -> Word8 + -> Word8 + -> ColorMassiv +rgbMassiv8w r g b = makeRawColorMassivI (fromIntegral r) (fromIntegral g) (fromIntegral b) 255 +{-# INLINE rgbMassiv8w #-} + +-- | 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. +rgbMassiv' :: Float + -> Float + -> Float + -> ColorMassiv +rgbMassiv' r g b = makeRawColorMassiv r g b 1.0 +{-# INLINE rgbMassiv' #-} + +-- | 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. +rgbMassivI' :: Int + -> Int + -> Int + -> ColorMassiv +rgbMassivI' r g b = makeRawColorMassivI r g b 255 +{-# INLINE rgbMassivI' #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."