gloss-accelerate (empty) → 0.2.0.0
raw patch · 5 files changed
+317/−0 lines, 5 filesdep +acceleratedep +basedep +glosssetup-changed
Dependencies added: accelerate, base, gloss, gloss-rendering
Files
- Graphics/Gloss/Accelerate/Data/Picture.hs +76/−0
- Graphics/Gloss/Accelerate/Data/Point.hs +170/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- gloss-accelerate.cabal +39/−0
+ Graphics/Gloss/Accelerate/Data/Picture.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP #-}+-- |+-- Module : Graphics.Gloss.Accelerate.Data.Picture+-- Copyright : [2013..2017] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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+
+ Graphics/Gloss/Accelerate/Data/Point.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gloss-accelerate.cabal view
@@ -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 <tmcdonell@cse.unsw.edu.au>+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