diff --git a/Graphics/Gloss/Accelerate/Data/Picture.hs b/Graphics/Gloss/Accelerate/Data/Picture.hs new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Accelerate/Data/Picture.hs @@ -0,0 +1,76 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Graphics/Gloss/Accelerate/Data/Point.hs @@ -0,0 +1,170 @@ +{-# 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 = 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 new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Trevor L. McDonell + +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 Trevor L. McDonell 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gloss-accelerate.cabal b/gloss-accelerate.cabal new file mode 100644 --- /dev/null +++ b/gloss-accelerate.cabal @@ -0,0 +1,39 @@ +Name: gloss-accelerate +Version: 0.2.0.0 +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 + +Library + Exposed-modules: + Graphics.Gloss.Accelerate.Data.Picture + Graphics.Gloss.Accelerate.Data.Point + + Build-depends: + base >= 4.6 && < 4.10 + , accelerate >= 0.16 + , gloss >= 1.9 + , gloss-rendering >= 1.9 + + ghc-options: + -Wall -O2 + + default-language: + Haskell2010 + +source-repository head + type: git + location: https://github.com/tmcdonell/gloss-accelerate + +source-repository this + type: git + tag: 0.2.0.0 + location: https://github.com/tmcdonell/gloss-accelerate + +-- vim: nospell