module Graphics.Gloss.Data.Picture
( Point
, Vector
, Path
, Picture(..)
, blank, polygon, line, circle, thickCircle, text, bitmap
, color, translate, rotate, scale
, pictures
, 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 Control.Monad
import Data.Monoid
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
type Path = [Point]
data Picture
= Blank
| Polygon Path
| Line Path
| Circle Float
| ThickCircle Float Float
| Text String
| Bitmap Int Int ByteString
| 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 -> ByteString -> 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
loadBMP :: FilePath -> IO Picture
loadBMP fname = do
bs <- B.readFile fname
when (not (isBmp bs)) $ error (fname ++ ": not a bmp file" )
when (bpp bs < 32) $ error (fname ++ ": must be saved in 32-bit RGBA format" )
when (comp bs /= 0) $ error (fname ++ ": must be saved in uncompressed format")
return (Bitmap (width bs) (height bs) (dat bs))
where range s n bs = B.unpack (B.take n (B.drop s bs))
littleEndian ds = sum [ fromIntegral b * 256^k | (b,k) <- zip ds [(0 :: Int) ..] ]
isBmp bs = littleEndian (range 0 2 bs) == (19778 :: Int)
pxOff bs = littleEndian (range 10 4 bs) :: Int
width bs = littleEndian (range 18 4 bs) :: Int
height bs = littleEndian (range 22 4 bs) :: Int
bpp bs = littleEndian (range 28 2 bs) :: Int
comp bs = littleEndian (range 30 4 bs) :: Int
dat bs = swapRB (B.take (4 * width bs * height bs)
(B.drop (pxOff bs) bs))
swapRB bs
| B.null bs = B.empty
| otherwise = let [b,g,r,a] = B.unpack (B.take 4 bs)
in B.pack [r,g,b,a] `B.append` swapRB (B.drop 4 bs)
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