{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Data.Picture
( Point
, Vector
, Path
, Picture(..)
, Rectangle(..)
, BitmapData, PixelFormat(..), BitmapFormat(..), RowOrder(..)
, bitmapSize
, bitmapOfForeignPtr
, bitmapDataOfForeignPtr
, bitmapOfByteString
, bitmapDataOfByteString
, bitmapOfBMP
, bitmapDataOfBMP
, loadBMP
, rectAtOrigin )
where
import Graphics.Gloss.Internals.Data.Color
import Graphics.Gloss.Internals.Rendering.Bitmap
import Codec.BMP
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Data.Word
import Data.Monoid
import Data.ByteString
import Data.Data
import System.IO.Unsafe
import qualified Data.ByteString.Unsafe as BSU
import Prelude hiding (map)
#if __GLASGOW_HASKELL__ >= 800
import Data.Semigroup
import Data.List.NonEmpty
#endif
type Point = (Float, Float)
type Vector = Point
type Path = [Point]
data Picture
= Blank
| Polygon Path
| Line Path
| Circle Float
| ThickCircle Float Float
| Arc Float Float Float
| ThickArc Float Float Float Float
| Text String
| Bitmap BitmapData
| BitmapSection Rectangle BitmapData
| Color Color Picture
| Translate Float Float Picture
| Rotate Float Picture
| Scale Float Float Picture
| Pictures [Picture]
deriving (Int -> Picture -> ShowS
[Picture] -> ShowS
Picture -> String
(Int -> Picture -> ShowS)
-> (Picture -> String) -> ([Picture] -> ShowS) -> Show Picture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Picture] -> ShowS
$cshowList :: [Picture] -> ShowS
show :: Picture -> String
$cshow :: Picture -> String
showsPrec :: Int -> Picture -> ShowS
$cshowsPrec :: Int -> Picture -> ShowS
Show, Picture -> Picture -> Bool
(Picture -> Picture -> Bool)
-> (Picture -> Picture -> Bool) -> Eq Picture
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Picture -> Picture -> Bool
$c/= :: Picture -> Picture -> Bool
== :: Picture -> Picture -> Bool
$c== :: Picture -> Picture -> Bool
Eq, Typeable Picture
Constr
DataType
Typeable Picture =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Picture -> c Picture)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Picture)
-> (Picture -> Constr)
-> (Picture -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Picture))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Picture))
-> ((forall b. Data b => b -> b) -> Picture -> Picture)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r)
-> (forall u. (forall d. Data d => d -> u) -> Picture -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Picture -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture)
-> Data Picture
Picture -> Constr
Picture -> DataType
(forall b. Data b => b -> b) -> Picture -> Picture
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Picture -> c Picture
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Picture
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Picture -> u
forall u. (forall d. Data d => d -> u) -> Picture -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Picture
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Picture -> c Picture
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Picture)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Picture)
$cPictures :: Constr
$cScale :: Constr
$cRotate :: Constr
$cTranslate :: Constr
$cColor :: Constr
$cBitmapSection :: Constr
$cBitmap :: Constr
$cText :: Constr
$cThickArc :: Constr
$cArc :: Constr
$cThickCircle :: Constr
$cCircle :: Constr
$cLine :: Constr
$cPolygon :: Constr
$cBlank :: Constr
$tPicture :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Picture -> m Picture
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture
gmapMp :: (forall d. Data d => d -> m d) -> Picture -> m Picture
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture
gmapM :: (forall d. Data d => d -> m d) -> Picture -> m Picture
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Picture -> m Picture
gmapQi :: Int -> (forall d. Data d => d -> u) -> Picture -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Picture -> u
gmapQ :: (forall d. Data d => d -> u) -> Picture -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Picture -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Picture -> r
gmapT :: (forall b. Data b => b -> b) -> Picture -> Picture
$cgmapT :: (forall b. Data b => b -> b) -> Picture -> Picture
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Picture)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Picture)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Picture)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Picture)
dataTypeOf :: Picture -> DataType
$cdataTypeOf :: Picture -> DataType
toConstr :: Picture -> Constr
$ctoConstr :: Picture -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Picture
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Picture
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Picture -> c Picture
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Picture -> c Picture
$cp1Data :: Typeable Picture
Data, Typeable)
instance Monoid Picture where
mempty :: Picture
mempty = Picture
Blank
mappend :: Picture -> Picture -> Picture
mappend a :: Picture
a b :: Picture
b = [Picture] -> Picture
Pictures [Picture
a, Picture
b]
mconcat :: [Picture] -> Picture
mconcat = [Picture] -> Picture
Pictures
#if __GLASGOW_HASKELL__ >= 800
instance Semigroup Picture where
a :: Picture
a <> :: Picture -> Picture -> Picture
<> b :: Picture
b = [Picture] -> Picture
Pictures [Picture
a, Picture
b]
sconcat :: NonEmpty Picture -> Picture
sconcat = [Picture] -> Picture
Pictures ([Picture] -> Picture)
-> (NonEmpty Picture -> [Picture]) -> NonEmpty Picture -> Picture
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Picture -> [Picture]
forall a. NonEmpty a -> [a]
toList
stimes :: b -> Picture -> Picture
stimes = b -> Picture -> Picture
forall b a. Integral b => b -> a -> a
stimesIdempotent
#endif
bitmapOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture
bitmapOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> Picture
bitmapOfForeignPtr width :: Int
width height :: Int
height fmt :: BitmapFormat
fmt fptr :: ForeignPtr Word8
fptr cacheMe :: Bool
cacheMe =
BitmapData -> Picture
Bitmap (BitmapData -> Picture) -> BitmapData -> Picture
forall a b. (a -> b) -> a -> b
$
Int
-> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> BitmapData
bitmapDataOfForeignPtr Int
width Int
height BitmapFormat
fmt ForeignPtr Word8
fptr Bool
cacheMe
bitmapDataOfForeignPtr :: Int -> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> BitmapData
bitmapDataOfForeignPtr :: Int
-> Int -> BitmapFormat -> ForeignPtr Word8 -> Bool -> BitmapData
bitmapDataOfForeignPtr width :: Int
width height :: Int
height fmt :: BitmapFormat
fmt fptr :: ForeignPtr Word8
fptr cacheMe :: Bool
cacheMe
= let len :: Int
len = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4
in Int
-> BitmapFormat
-> (Int, Int)
-> Bool
-> ForeignPtr Word8
-> BitmapData
BitmapData Int
len BitmapFormat
fmt (Int
width,Int
height) Bool
cacheMe ForeignPtr Word8
fptr
bitmapOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture
bitmapOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> Picture
bitmapOfByteString width :: Int
width height :: Int
height fmt :: BitmapFormat
fmt bs :: ByteString
bs cacheMe :: Bool
cacheMe =
BitmapData -> Picture
Bitmap (BitmapData -> Picture) -> BitmapData -> Picture
forall a b. (a -> b) -> a -> b
$
Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData
bitmapDataOfByteString Int
width Int
height BitmapFormat
fmt ByteString
bs Bool
cacheMe
bitmapDataOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData
bitmapDataOfByteString :: Int -> Int -> BitmapFormat -> ByteString -> Bool -> BitmapData
bitmapDataOfByteString width :: Int
width height :: Int
height fmt :: BitmapFormat
fmt bs :: ByteString
bs cacheMe :: Bool
cacheMe
= IO BitmapData -> BitmapData
forall a. IO a -> a
unsafePerformIO
(IO BitmapData -> BitmapData) -> IO BitmapData -> BitmapData
forall a b. (a -> b) -> a -> b
$ do let len :: Int
len = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4
Ptr Word8
ptr <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
ForeignPtr Word8
fptr <- FinalizerPtr Word8 -> Ptr Word8 -> IO (ForeignPtr Word8)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr Word8
forall a. FinalizerPtr a
finalizerFree Ptr Word8
ptr
ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
BSU.unsafeUseAsCString ByteString
bs
((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
ptr (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
cstr) Int
len
BitmapData -> IO BitmapData
forall (m :: * -> *) a. Monad m => a -> m a
return (BitmapData -> IO BitmapData) -> BitmapData -> IO BitmapData
forall a b. (a -> b) -> a -> b
$ Int
-> BitmapFormat
-> (Int, Int)
-> Bool
-> ForeignPtr Word8
-> BitmapData
BitmapData Int
len BitmapFormat
fmt (Int
width, Int
height) Bool
cacheMe ForeignPtr Word8
fptr
{-# NOINLINE bitmapDataOfByteString #-}
bitmapOfBMP :: BMP -> Picture
bitmapOfBMP :: BMP -> Picture
bitmapOfBMP bmp :: BMP
bmp
= BitmapData -> Picture
Bitmap (BitmapData -> Picture) -> BitmapData -> Picture
forall a b. (a -> b) -> a -> b
$ BMP -> BitmapData
bitmapDataOfBMP BMP
bmp
bitmapDataOfBMP :: BMP -> BitmapData
bitmapDataOfBMP :: BMP -> BitmapData
bitmapDataOfBMP bmp :: BMP
bmp
= IO BitmapData -> BitmapData
forall a. IO a -> a
unsafePerformIO
(IO BitmapData -> BitmapData) -> IO BitmapData -> BitmapData
forall a b. (a -> b) -> a -> b
$ do let (width :: Int
width, height :: Int
height) = BMP -> (Int, Int)
bmpDimensions BMP
bmp
let bs :: ByteString
bs = BMP -> ByteString
unpackBMPToRGBA32 BMP
bmp
let len :: Int
len = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
height Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4
Ptr Word8
ptr <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
len
ForeignPtr Word8
fptr <- FinalizerPtr Word8 -> Ptr Word8 -> IO (ForeignPtr Word8)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr Word8
forall a. FinalizerPtr a
finalizerFree Ptr Word8
ptr
ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
BSU.unsafeUseAsCString ByteString
bs
((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word8
ptr (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
cstr) Int
len
BitmapData -> IO BitmapData
forall (m :: * -> *) a. Monad m => a -> m a
return (BitmapData -> IO BitmapData) -> BitmapData -> IO BitmapData
forall a b. (a -> b) -> a -> b
$ Int
-> BitmapFormat
-> (Int, Int)
-> Bool
-> ForeignPtr Word8
-> BitmapData
BitmapData Int
len (RowOrder -> PixelFormat -> BitmapFormat
BitmapFormat RowOrder
BottomToTop PixelFormat
PxRGBA) (Int
width,Int
height) Bool
True ForeignPtr Word8
fptr
{-# NOINLINE bitmapDataOfBMP #-}
loadBMP :: FilePath -> IO Picture
loadBMP :: String -> IO Picture
loadBMP filePath :: String
filePath
= do Either Error BMP
ebmp <- String -> IO (Either Error BMP)
readBMP String
filePath
case Either Error BMP
ebmp of
Left err :: Error
err -> String -> IO Picture
forall a. HasCallStack => String -> a
error (String -> IO Picture) -> String -> IO Picture
forall a b. (a -> b) -> a -> b
$ Error -> String
forall a. Show a => a -> String
show Error
err
Right bmp :: BMP
bmp -> Picture -> IO Picture
forall (m :: * -> *) a. Monad m => a -> m a
return (Picture -> IO Picture) -> Picture -> IO Picture
forall a b. (a -> b) -> a -> b
$ BMP -> Picture
bitmapOfBMP BMP
bmp
rectAtOrigin :: Int -> Int -> Rectangle
rectAtOrigin :: Int -> Int -> Rectangle
rectAtOrigin w :: Int
w h :: Int
h = (Int, Int) -> (Int, Int) -> Rectangle
Rectangle (0,0) (Int
w,Int
h)