module Graphics.Gloss.Game (
module Graphics.Gloss.Data.Color,
module Graphics.Gloss.Data.Display,
module Graphics.Gloss.Data.Picture,
module Graphics.Gloss.Interface.Pure.Game,
Size, Rect,
bmp, png, jpg,
boundingBox,
play, playInScene,
Animation, animation, noAnimation, animationPicture,
Scene, picture, picturing, animating, translating, rotating, scaling, scenes,
drawScene,
) where
import Data.IORef
import Data.Maybe
import System.IO.Unsafe (unsafePerformIO)
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Data.Display
import Graphics.Gloss.Data.Picture hiding (Picture(..))
import Graphics.Gloss.Data.Picture (Picture)
import Graphics.Gloss.Interface.Pure.Game (Event(..), Key(..), SpecialKey(..), MouseButton(..), KeyState(..))
import Graphics.Gloss.Juicy
import qualified Graphics.Gloss as G
import qualified Graphics.Gloss.Interface.IO.Game as G
type Size = (Float, Float)
type Rect = (Point, Size)
bmp :: FilePath -> Picture
bmp fname = unsafePerformIO $ loadBMP fname
png :: FilePath -> Picture
png fname = maybe (text "PNG ERROR") id (unsafePerformIO $ loadJuicyPNG fname)
jpg :: FilePath -> Picture
jpg fname = maybe (text "JPEG ERROR") id (unsafePerformIO $ loadJuicyJPG fname)
boundingBox :: Picture -> Rect
boundingBox G.Blank = ((0, 0), (0, 0))
boundingBox (G.Polygon _) = error "Graphics.Gloss.Game.boundingbox: Polygon not implemented yet"
boundingBox (G.Line _) = error "Graphics.Gloss.Game.boundingbox: Line not implemented yet"
boundingBox (G.Circle r) = ((0, 0), (2 * r, 2 * r))
boundingBox (G.ThickCircle t r) = ((0, 0), (2 * r + t, 2 * r + t))
boundingBox (G.Arc _ _ _) = error "Graphics.Gloss.Game.boundingbox: Arc not implemented yet"
boundingBox (G.ThickArc _ _ _ _) = error "Graphics.Gloss.Game.boundingbox: ThickArc not implemented yet"
boundingBox (G.Text _) = error "Graphics.Gloss.Game.boundingbox: Text not implemented yet"
boundingBox (G.Bitmap w h _ _) = ((0, 0), (fromIntegral w, fromIntegral h))
boundingBox (G.Color _ p) = boundingBox p
boundingBox (G.Translate dx dy p) = let ((x, y), size) = boundingBox p in ((x + dx, y + dy), size)
boundingBox (G.Rotate _ang _p) = error "Graphics.Gloss.Game.boundingbox: Rotate not implemented yet"
boundingBox (G.Scale xf yf p) = let (origin, (w, h)) = boundingBox p in (origin, (w * xf, h * yf))
boundingBox (G.Pictures _ps) = error "Graphics.Gloss.Game.boundingbox: Pictures not implemented yet"
play :: Display
-> Color
-> Int
-> world
-> (world -> Picture)
-> (Event -> world -> world)
-> [Float -> world -> world]
-> IO ()
play display bg fps world draw handler steppers
= G.play display bg fps world draw handler (perform steppers)
where
perform [] _time world = world
perform (stepper:steppers) time world = perform steppers time (stepper time world)
currentTime :: IORef Float
currentTime = unsafePerformIO $ newIORef 0
playInScene :: Display
-> Color
-> Int
-> world
-> Scene world
-> (Float -> Event -> world -> world)
-> [Float -> Float -> world -> world]
-> IO ()
playInScene display bg fps world scene handler steppers
= G.playIO display bg fps world drawSceneNow performHandler (advanceTimeAndPerform steppers)
where
drawSceneNow world
= do
{ now <- readIORef currentTime
; return $ drawScene scene now world
}
performHandler event world
= do
{ now <- readIORef currentTime
; return $ handler now event world
}
advanceTimeAndPerform steppers deltaT world
= do
{ now <- readIORef currentTime
; let future = now + deltaT
; writeIORef currentTime future
; perform steppers future deltaT world
}
perform [] _now _deltaT world = return world
perform (stepper:steppers) now deltaT world = perform steppers now deltaT (stepper now deltaT world)
data Animation = Animation [Picture] Float Float
animation :: [Picture] -> Float -> Float -> Animation
animation = Animation
noAnimation :: Animation
noAnimation = animation [] 1 0
animationPicture :: Animation -> Float -> Maybe Picture
animationPicture (Animation pics delay start) time
| start > time = Nothing
| i >= length pics = Nothing
| otherwise = Just $ pics !! i
where
i = round ((time start) / delay)
data Scene world
= Picturing (Float -> world -> Picture)
| Translating ( world -> Point) (Scene world)
| Rotating ( world -> Float) (Scene world)
| Scaling ( world -> (Float, Float)) (Scene world)
| Scenes [Scene world]
picture :: Picture -> Scene world
picture p = picturing (const p)
picturing :: (world -> Picture) -> Scene world
picturing worldToPic = Picturing (const worldToPic)
animating :: (world -> Animation) -> Picture -> Scene world
animating anim defaultPic
= Picturing (\currentTime world -> fromMaybe defaultPic $ animationPicture (anim world) currentTime)
translating :: (world -> Point) -> Scene world -> Scene world
translating = Translating
rotating :: (world -> Float) -> Scene world -> Scene world
rotating = Rotating
scaling :: (world -> (Float, Float)) -> Scene world -> Scene world
scaling = Scaling
scenes :: [Scene world] -> Scene world
scenes = Scenes
drawScene :: Scene world -> Float -> world -> Picture
drawScene scene time world = drawS scene
where
drawS (Picturing draw) = draw time world
drawS (Translating movement scene) = let (x, y) = movement world in translate x y (drawS scene)
drawS (Rotating rotation scene) = rotate (rotation world) (drawS scene)
drawS (Scaling scaling scene) = let (xf, yf) = scaling world in scale xf yf (drawS scene)
drawS (Scenes scenes) = pictures $ map drawS scenes