diff --git a/Graphics/Gloss/Accelerate/Data/Picture.hs b/Graphics/Gloss/Accelerate/Data/Picture.hs deleted file mode 100644 --- a/Graphics/Gloss/Accelerate/Data/Picture.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE CPP #-} --- | --- Module : Graphics.Gloss.Accelerate.Data.Picture --- Copyright : [2013..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Graphics.Gloss.Accelerate.Data.Picture - where - --- Standard library -import Prelude as P -import Foreign.Ptr -import Foreign.ForeignPtr -import System.IO.Unsafe - --- Gloss -import Graphics.Gloss.Rendering - --- Accelerate -import Data.Array.Accelerate as A -import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) -import Data.Array.Accelerate.Array.Sugar ( Array(..) ) - - --- | Use an Accelerate array of RGBA data as a bitmap image. If the image is --- generated programatically every frame, then the second parameter should be --- `False`. If you have loaded it from static data then use `True`. --- - --- TODO: --- --- If CUDA is enabled, check whether the array already exists on the device --- and if so blitz it straight to a texture as described below. Otherwise, --- just use this method. See also the cuda examples in the --- non-USE_TEXSUBIMAGE2D path. --- --- 1. (once) Allocate a new texture object --- 2. Run the CUDA computation, but do not copy the result back to the host --- 3. Map the texture resource to an array --- 4. Copy the CUDA result directly to the mapped texture --- -bitmapOfArray - :: Array DIM2 Word32 -- The array data (packed RGBA) - -> Bool -- Should the image be cached between frames? - -> Picture -bitmapOfArray arrPixels cacheMe - = let -- Size of the raw image - Z :. sizeY :. sizeX = arrayShape arrPixels - - -- Wrap the array data in a Foreign pointer and turn into a Gloss picture - {-# NOINLINE rawData #-} - rawData = let (Array _ adata) = arrPixels - ptr = ptrsOfArrayData adata - in - unsafePerformIO $ newForeignPtr_ (castPtr ptr) - -#if MIN_VERSION_gloss_rendering(1,10,0) - fmt = BitmapFormat BottomToTop PxRGBA -- assume little-endian host - pic = bitmapOfForeignPtr - sizeX sizeY -- image size - fmt -- image format - rawData -- raw image data - cacheMe -#else - pic = bitmapOfForeignPtr - sizeX sizeY -- raw image size - rawData -- the image data - cacheMe -#endif - in pic - diff --git a/Graphics/Gloss/Accelerate/Data/Point.hs b/Graphics/Gloss/Accelerate/Data/Point.hs deleted file mode 100644 --- a/Graphics/Gloss/Accelerate/Data/Point.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Graphics.Gloss.Accelerate.Data.Point --- Copyright : [2013..2017] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Graphics.Gloss.Accelerate.Data.Point ( - - -- ** Point data type - Point, - - -- ** Point creation - makePoint, - xyOfPoint, - pointOfIndex, - - -- ** Testing points - pointInBox, - -) where - -import Data.Array.Accelerate as A -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Product ( TupleIdx(..), IsProduct(..), ) -import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..) ) - -import Data.Typeable -import Prelude ( fromInteger ) -- ghc < 8 bug -import qualified Prelude as P - - --- | An abstract point value on the xy-plane. --- -type Point = XY Float - --- | A parameterised point in the xy-plane. This is so that the type can be both --- Exp (Point' a) and Point' (Exp a). --- -data XY a = XY a a - deriving (P.Show, P.Eq, Typeable) - --- | Pretend a point is a number. --- --- Vectors aren't real numbers according to Haskell, because they don't support --- the multiply and divide field operators. We can pretend they are though, and --- use the (+) and (-) operators as component-wise addition and subtraction. --- -instance P.Num a => P.Num (XY a) where - (+) (XY x1 y1) (XY x2 y2) = XY (x1 + x2) (y1 + y2) - (-) (XY x1 y1) (XY x2 y2) = XY (x1 - x2) (y1 - y2) - (*) (XY x1 y1) (XY x2 y2) = XY (x1 * x2) (y1 * y2) - signum (XY x y) = XY (signum x) (signum y) - abs (XY x y) = XY (abs x) (abs y) - negate (XY x y) = XY (negate x) (negate y) - fromInteger i = let f = P.fromInteger i - in XY f f - --- Represent points in Accelerate as a tuple --- -type instance EltRepr (XY a) = EltRepr (a, a) - -instance Elt a => Elt (XY a) where - eltType (_ :: XY a) = eltType (undefined :: (a,a)) - toElt p = let (x,y) = toElt p in XY x y - fromElt (XY x y) = fromElt (x,y) - -instance Elt a => IsProduct Elt (XY a) where - type ProdRepr (XY a) = (((),a), a) - fromProd _ (XY x y) = (((), x), y) - toProd _ (((),x),y) = XY x y - prod cst _ = prod cst (undefined :: (a,a)) - -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (XY a) where - type Plain (XY a) = XY (Plain a) - lift (XY x y) = Exp . Tuple $ NilTup `SnocTup` lift x `SnocTup` lift y - -instance Elt a => Unlift Exp (XY (Exp a)) where - unlift p = let x = Exp $ SuccTupIdx ZeroTupIdx `Prj` p - y = Exp $ ZeroTupIdx `Prj` p - in XY x y - - --- | Make a custom point --- -makePoint - :: Exp Float -- ^ x-coordinate - -> Exp Float -- ^ y-coordinate - -> Exp Point -makePoint x y = lift (XY x y) - - --- | Take the components of a point --- -xyOfPoint - :: Exp Point - -> (Exp Float, Exp Float) -xyOfPoint p - = let XY x y = unlift p - in (x, y) - - --- | Convert a two-dimensional index into a point centered in a plane of the --- given width and height. --- -pointOfIndex - :: Int -- ^ width - -> Int -- ^ height - -> Exp DIM2 - -> Exp Point -pointOfIndex sizeX sizeY ix - = let -- Size of the raw plane - fsizeX, fsizeY :: Float - fsizeX = P.fromIntegral sizeX - fsizeY = P.fromIntegral sizeY - - fsizeX2, fsizeY2 :: Exp Float - fsizeX2 = constant $ fsizeX / 2 - fsizeY2 = constant $ fsizeY / 2 - - -- Midpoint of plane - midX, midY :: Exp Int - midX = constant $ sizeX `div` 2 - midY = constant $ sizeY `div` 2 - - -- Centre coordinate in the plane - Z :. y :. x = unlift ix - x' = A.fromIntegral (x - midX) / fsizeX2 - y' = A.fromIntegral (y - midY) / fsizeY2 - in - makePoint x' y' - - --- | Test whether a point lies within a rectangular box that is oriented --- on the x-y plane. The points P1-P2 are opposing points of the box, --- but need not be in a particular order. --- --- @ --- P2 +-------+ --- | | --- | + P0 | --- | | --- +-------+ P1 --- @ --- -pointInBox - :: Exp Point -- ^ point to test - -> Exp Point -- ^ corner of box - -> Exp Point -- ^ opposite corner of box - -> Exp Bool -pointInBox p0 p1 p2 - = let XY x0 y0 = unlift p0 - XY x1 y1 = unlift p1 - XY x2 y2 = unlift p2 - in - x0 >= min x1 x2 && - x0 <= max x1 x2 && - y0 >= min y1 y2 && - y0 <= max y1 y2 - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Trevor L. McDonell +Copyright (c) [2013..2020], Trevor L. McDonell All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,24 @@ -gloss-accelerate -================ +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/tmcdonell/gloss-accelerate.svg)](https://travis-ci.org/tmcdonell/gloss-accelerate) +# gloss-accelerate + +[![GitHub CI](https://github.com/tmcdonell/gloss-accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/gloss-accelerate/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/gloss-accelerate/badge/lts)](https://stackage.org/lts/package/gloss-accelerate) +[![Stackage Nightly](https://stackage.org/package/gloss-accelerate/badge/nightly)](https://stackage.org/nightly/package/gloss-accelerate) [![Hackage](https://img.shields.io/hackage/v/gloss-accelerate.svg)](https://hackage.haskell.org/package/gloss-accelerate) -Extras to help interface [gloss][gloss] and [accelerate][accelerate]. Refer to +
+ +Extras to help interface [gloss][gloss] and [Accelerate][accelerate]. Refer to the main repositories of each project for more information. +Contributions and bug reports are welcome!
+Please feel free to contact me through [GitHub][accelerate] or [gitter.im][gitter.im]. + [gloss]: https://github.com/benl23x5/gloss [accelerate]: https://github.com/AccelerateHS/accelerate + [gitter.im]: https://gitter.im/AccelerateHS/Lobby diff --git a/gloss-accelerate.cabal b/gloss-accelerate.cabal --- a/gloss-accelerate.cabal +++ b/gloss-accelerate.cabal @@ -1,28 +1,29 @@ -Name: gloss-accelerate -Version: 2.0.0.1 -Synopsis: Extras to interface Gloss and Accelerate -Description: Extras to interface Gloss and Accelerate -License: BSD3 -License-file: LICENSE -Author: Trevor L. McDonell -Maintainer: Trevor L. McDonell -Category: Graphics -Build-type: Simple -Cabal-version: >=1.10 +name: gloss-accelerate +version: 2.1.0.0 +synopsis: Extras to interface Gloss and Accelerate +description: Please see the README on GitHub at +license: BSD3 +license-file: LICENSE +author: Trevor L. McDonell +maintainer: Trevor L. McDonell +category: Accelerate, Graphics +build-type: Simple +cabal-version: >=1.10 extra-source-files: README.md -Library - Exposed-modules: +library + exposed-modules: Graphics.Gloss.Accelerate.Data.Picture Graphics.Gloss.Accelerate.Data.Point - Build-depends: - base >= 4.6 && < 4.12 - , accelerate >= 0.16 + build-depends: + base >= 4.9 && < 5 + , accelerate >= 1.3 , gloss >= 1.9 - , gloss-rendering >= 1.9 + , gloss-rendering >= 1.10 + , linear-accelerate >= 0.7 ghc-options: -Wall @@ -31,13 +32,16 @@ default-language: Haskell2010 + hs-source-dirs: + src + source-repository head type: git location: https://github.com/tmcdonell/gloss-accelerate source-repository this type: git - tag: v2.0.0.1 + tag: v2.1.0.0 location: https://github.com/tmcdonell/gloss-accelerate -- vim: nospell diff --git a/src/Graphics/Gloss/Accelerate/Data/Picture.hs b/src/Graphics/Gloss/Accelerate/Data/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Accelerate/Data/Picture.hs @@ -0,0 +1,63 @@ +-- | +-- Module : Graphics.Gloss.Accelerate.Data.Picture +-- Copyright : [2013..2020] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Graphics.Gloss.Accelerate.Data.Picture + where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Sugar.Array +import qualified Data.Array.Accelerate.Representation.Array as R + +import Graphics.Gloss.Rendering + +import Foreign.ForeignPtr + + +-- | Use an Accelerate array of RGBA data as a bitmap image. If the image +-- is generated programatically every frame, then the second parameter +-- should be `False`. If you have loaded it from static data then use +-- `True`. +-- + +-- TODO: +-- +-- If CUDA is enabled, check whether the array already exists on the device +-- and if so blitz it straight to a texture as described below. Otherwise, +-- just use this method. See also the cuda examples in the +-- non-USE_TEXSUBIMAGE2D path. +-- +-- 1. (once) Allocate a new texture object +-- 2. Run the CUDA computation, but do not copy the result back to the host +-- 3. Map the texture resource to an array +-- 4. Copy the CUDA result directly to the mapped texture +-- +bitmapOfArray + :: Array DIM2 Word32 -- The array data (packed RGBA) + -> Bool -- Should the image be cached between frames? + -> Picture +bitmapOfArray arrPixels cacheMe + = let -- Size of the raw image + Z :. sizeY :. sizeX = arrayShape arrPixels + + rawData = let Array (R.Array _ adata) = arrPixels + ptr = unsafeGetValue (uniqueArrayData adata) + in + castForeignPtr ptr + + fmt = BitmapFormat TopToBottom PxRGBA -- assume little-endian host + pic = bitmapOfForeignPtr + sizeX sizeY -- image size + fmt -- image format + rawData -- raw image data + cacheMe + in pic + diff --git a/src/Graphics/Gloss/Accelerate/Data/Point.hs b/src/Graphics/Gloss/Accelerate/Data/Point.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Gloss/Accelerate/Data/Point.hs @@ -0,0 +1,106 @@ +-- | +-- Module : Graphics.Gloss.Accelerate.Data.Point +-- Copyright : [2013..2020] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Graphics.Gloss.Accelerate.Data.Point ( + + -- ** Point data type + Point, + + -- ** Point creation + makePoint, + xyOfPoint, + pointOfIndex, + + -- ** Testing points + pointInBox, + +) where + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Linear.V2 + +import qualified Prelude as P + + +-- | An abstract point value on the xy-plane. +-- +type Point = V2 Float + +-- | Make a custom point +-- +makePoint + :: Exp Float -- ^ x-coordinate + -> Exp Float -- ^ y-coordinate + -> Exp Point +makePoint = V2_ + + +-- | Take the components of a point +-- +xyOfPoint + :: Exp Point + -> (Exp Float, Exp Float) +xyOfPoint (V2_ x y) = (x, y) + + +-- | Convert a two-dimensional index into a point centered in a plane of the +-- given width and height. +-- +pointOfIndex + :: Int -- ^ width + -> Int -- ^ height + -> Exp DIM2 + -> Exp Point +pointOfIndex sizeX sizeY ix + = let -- Size of the raw plane + fsizeX, fsizeY :: Float + fsizeX = P.fromIntegral sizeX + fsizeY = P.fromIntegral sizeY + + fsizeX2, fsizeY2 :: Exp Float + fsizeX2 = constant $ fsizeX / 2 + fsizeY2 = constant $ fsizeY / 2 + + -- Midpoint of plane + midX, midY :: Exp Int + midX = constant $ sizeX `div` 2 + midY = constant $ sizeY `div` 2 + + -- Centre coordinate in the plane + Z :. y :. x = unlift ix + x' = A.fromIntegral (x - midX) / fsizeX2 + y' = A.fromIntegral (y - midY) / fsizeY2 + in + makePoint x' y' + + +-- | Test whether a point lies within a rectangular box that is oriented +-- on the x-y plane. The points P1-P2 are opposing points of the box, +-- but need not be in a particular order. +-- +-- @ +-- P2 +-------+ +-- | | +-- | + P0 | +-- | | +-- +-------+ P1 +-- @ +-- +pointInBox + :: Exp Point -- ^ point to test + -> Exp Point -- ^ corner of box + -> Exp Point -- ^ opposite corner of box + -> Exp Bool +pointInBox (V2_ x0 y0) (V2_ x1 y1) (V2_ x2 y2) = + x0 >= min x1 x2 && + x0 <= max x1 x2 && + y0 >= min y1 y2 && + y0 <= max y1 y2 +