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,
Scene, picture, picturing, animating, translating, rotating, scaling, scenes,
drawScene,
) where
import Data.IORef
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
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 -> pickPicture currentTime (anim world))
where
pickPicture now (Animation pics delay start)
| start > now = defaultPic
| i >= length pics = defaultPic
| otherwise = pics !! i
where
i = round ((now start) / delay)
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