module Graphics.Gloss.Data.Picture
( Point
, Vector
, Path
, Picture(..)
, BitmapData
, blank, polygon, line, circle, thickCircle, text, bitmap
, color, translate, rotate, scale
, pictures
, bitmapOfForeignPtr
, bitmapOfByteString
, bitmapOfBMP
, loadBMP
, lineLoop
, circleSolid
, rectanglePath, rectangleWire, rectangleSolid
, rectangleUpperPath, rectangleUpperWire, rectangleUpperSolid)
where
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Point
import Graphics.Gloss.Data.Vector
import Graphics.Gloss.Internals.Render.Bitmap
import Control.Monad
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 System.IO.Unsafe
import qualified Data.ByteString.Unsafe as BSU
type Path = [Point]
data Picture
= Blank
| Polygon Path
| Line Path
| Circle Float
| ThickCircle Float Float
| Text String
| Bitmap Int Int BitmapData Bool
| Color Color Picture
| Translate Float Float Picture
| Rotate Float Picture
| Scale Float Float Picture
| Pictures [Picture]
deriving (Show, Eq)
instance Monoid Picture where
mempty = blank
mappend a b = Pictures [a, b]
mconcat = Pictures
blank :: Picture
blank = Blank
polygon :: Path -> Picture
polygon = Polygon
line :: Path -> Picture
line = Line
circle :: Float -> Picture
circle = Circle
thickCircle :: Float -> Float -> Picture
thickCircle = ThickCircle
text :: String -> Picture
text = Text
bitmap :: Int -> Int -> BitmapData -> Bool -> Picture
bitmap = Bitmap
color :: Color -> Picture -> Picture
color = Color
translate :: Float -> Float -> Picture -> Picture
translate = Translate
rotate :: Float -> Picture -> Picture
rotate = Rotate
scale :: Float -> Float -> Picture -> Picture
scale = Scale
pictures :: [Picture] -> Picture
pictures = Pictures
bitmapOfForeignPtr :: Int -> Int -> ForeignPtr Word8 -> Bool -> Picture
bitmapOfForeignPtr width height fptr cacheMe
= let len = width * height * 4
bdata = BitmapData len fptr
in Bitmap width height bdata cacheMe
bitmapOfByteString :: Int -> Int -> ByteString -> Bool -> Picture
bitmapOfByteString width height bs cacheMe
= unsafePerformIO
$ do let len = width * height * 4
ptr <- mallocBytes len
fptr <- newForeignPtr finalizerFree ptr
BSU.unsafeUseAsCString bs
$ \cstr -> copyBytes ptr (castPtr cstr) len
let bdata = BitmapData len fptr
return $ Bitmap width height bdata cacheMe
bitmapOfBMP :: BMP -> Picture
bitmapOfBMP bmp
= unsafePerformIO
$ do let (width, height) = bmpDimensions bmp
let bs = unpackBMPToRGBA32 bmp
let len = width * height * 4
ptr <- mallocBytes len
fptr <- newForeignPtr finalizerFree ptr
BSU.unsafeUseAsCString bs
$ \cstr -> copyBytes ptr (castPtr cstr) len
let bdata = BitmapData len fptr
reverseRGBA bdata
return $ Bitmap width height bdata True
loadBMP :: FilePath -> IO Picture
loadBMP filePath
= do ebmp <- readBMP filePath
case ebmp of
Left err -> error $ show err
Right bmp -> return $ bitmapOfBMP bmp
lineLoop :: Path -> Picture
lineLoop [] = Line []
lineLoop (x:xs) = Line ((x:xs) ++ [x])
rectanglePath :: Float -> Float -> Path
rectanglePath sizeX sizeY
= let sx = sizeX / 2
sy = sizeY / 2
in [(sx, sy), (sx, sy), (sx, sy), (sx, sy)]
rectangleWire :: Float -> Float -> Picture
rectangleWire sizeX sizeY
= lineLoop $ rectanglePath sizeX sizeY
rectangleUpperWire :: Float -> Float -> Picture
rectangleUpperWire sizeX sizeY
= lineLoop $ rectangleUpperPath sizeX sizeY
rectangleUpperPath :: Float -> Float -> Path
rectangleUpperPath sizeX sy
= let sx = sizeX / 2
in [(sx, 0), (sx, sy), (sx, sy), (sx, 0)]
rectangleSolid :: Float -> Float -> Picture
rectangleSolid sizeX sizeY
= Polygon $ rectanglePath sizeX sizeY
rectangleUpperSolid :: Float -> Float -> Picture
rectangleUpperSolid sizeX sizeY
= Polygon $ rectangleUpperPath sizeX sizeY
circleSolid :: Float -> Picture
circleSolid r = thickCircle (r/2) r