free-game 0.2.0.0 → 0.3.0.0
raw patch · 11 files changed
+322/−416 lines, 11 filesdep +GLFW-bdep +OpenGLdep +StateVardep −parallel-iodep ~basebinary-added
Dependencies added: GLFW-b, OpenGL, StateVar, vect
Dependencies removed: parallel-io
Dependency ranges changed: base
Files
- Graphics/FreeGame.hs +1/−18
- Graphics/FreeGame/Backends/DXFI.hs +0/−315
- Graphics/FreeGame/Backends/GLFW.hs +200/−0
- Graphics/FreeGame/Base.hs +9/−52
- Graphics/FreeGame/Bitmap.hs +20/−11
- Graphics/FreeGame/Input.hs +4/−4
- Graphics/FreeGame/Sound.hs +0/−5
- Graphics/FreeGame/Util.hs +33/−3
- examples/logo.png binary
- examples/test.hs +41/−0
- free-game.cabal +14/−8
Graphics/FreeGame.hs view
@@ -2,7 +2,6 @@ module Graphics.FreeGame ( module Graphics.FreeGame.Base ,module Graphics.FreeGame.Bitmap - ,module Graphics.FreeGame.Sound ,module Graphics.FreeGame.Input ,module Graphics.FreeGame.Util ,runGame @@ -10,22 +9,6 @@ import Graphics.FreeGame.Base import Graphics.FreeGame.Bitmap -import Graphics.FreeGame.Sound import Graphics.FreeGame.Input import Graphics.FreeGame.Util - -#ifdef mingw32_HOST_OS -import qualified Graphics.FreeGame.Backends.DXFI as DXFI -#endif - - --- | Run the 'Game'. -runGame :: GameParam - -> Game a - -> IO (Maybe a) - -#ifdef mingw32_HOST_OS -runGame = DXFI.runGame -#else -runGame = undefined -#endif+import Graphics.FreeGame.Backends.GLFW
− Graphics/FreeGame/Backends/DXFI.hs
@@ -1,315 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.FreeGame.Backends.DXFI --- Copyright : (C) 2012 Fumiaki Kinoshita --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Fumiaki Kinsohita <fumiexcel@gmail.com> --- Stability : provisional --- Portability : non-portable --- --- DirectX Backend ----------------------------------------------------------------------------- -module Graphics.FreeGame.Backends.DXFI (runGame) where -import Graphics.FreeGame.Base -import Graphics.FreeGame.Bitmap -import Graphics.FreeGame.Input -import Graphics.FreeGame.Sound -import Control.Concurrent.ParallelIO.Local -import Control.Monad.Trans -import Control.Monad.State -import Control.Monad.Free -import Data.Bits -import Data.Unique -import Data.Word -import Data.Array.Repa -import qualified Data.IntMap as IM -import Foreign.Ptr -import Foreign.C.Types -import Foreign.C.String -import Foreign.Marshal.Alloc -import Foreign.Storable -import Codec.Picture.Repa -import System.FilePath.Windows -import System.Random -import GHC.Conc - -type Handle = CInt -foreign import ccall "DXFI_LoadImage" dxfi_LoadImage :: CWString -> IO Handle -foreign import ccall "DXFI_LoadImageMatrix" dxfi_LoadImageMatrix :: CWString -> Int -> Int -> Int -> Int -> Int -> Ptr Handle -> IO () -foreign import ccall "DXFI_CropImage" dxfi_CropImage :: Int -> Int -> Int -> Int -> Handle -> IO Handle -foreign import ccall unsafe "DXFI_DrawImage" dxfi_DrawImage :: Int -> Int -> Handle -> Bool -> IO () -foreign import ccall unsafe "DXFI_DrawImageScaledWithAngle" dxfi_DrawImageBy :: Int -> Int -> Double -> Double -> Handle -> Bool -> Bool -> IO () -foreign import ccall "DXFI_IsKeyPressed" dxfi_IsKeyPressed :: Int -> IO Bool -foreign import ccall "DXFI_Initialize" dxfi_Initialize :: IO () -foreign import ccall "DXFI_Release" dxfi_Release :: IO () -foreign import ccall "DXFI_GetTickCount" dxfi_GetTickCount :: Bool -> IO Int -foreign import ccall "DXFI_SetLogging" dxfi_SetLogging :: Bool -> IO () -foreign import ccall "DXFI_SetWindowMode" dxfi_SetWindowMode :: Bool -> IO () -foreign import ccall "DXFI_SetWindowSize" dxfi_SetWindowSize :: Int -> Int -> IO () -foreign import ccall "DXFI_SetWindowCaption" dxfi_SetWindowCaption :: CWString -> IO () -foreign import ccall "DXFI_SetDrawingDestination" dxfi_SetDrawingDestination :: Int -> IO () -foreign import ccall "DXFI_Wait" dxfi_Wait :: Int -> IO () -foreign import ccall "DXFI_ClearScreen" dxfi_ClearScreen :: Ptr () -> IO () -foreign import ccall "DXFI_SetBackgroundColor" dxfi_setBackgroundColor :: Int -> Int -> Int -> IO () -foreign import ccall "DXFI_FlipScreen" dxfi_FlipScreen :: IO () -foreign import ccall "DXFI_AcceptMessage" processMessage :: IO Int -foreign import ccall "DXFI_SetSoundVolumeOnce" dxfi_SetSoundVolumeOnce :: Int -> Handle -> IO () -foreign import ccall "DXFI_SetSoundPanOnce" dxfi_SetSoundPanOnce :: Int -> Handle -> IO () -foreign import ccall "DXFI_LoadSound" dxfi_LoadSound :: CWString -> Int -> Int -> IO Handle -foreign import ccall "DXFI_PlaySound" dxfi_PlaySound :: Handle -> Int -> Bool -> IO () -foreign import ccall "DXFI_IsPlayingSound" dxfi_IsPlayingSound :: Handle -> IO Bool -foreign import ccall "DXFI_CreateARGB8ColorBaseImage" dxfi_CreateARGB8ColorBaseImage :: Int -> Int -> Ptr a -> IO () -foreign import ccall unsafe "DXFI_SetPixelBaseImage" dxfi_SetPixelBaseImage :: Ptr a -> Int -> Int -> Word8 -> Word8 -> Word8 -> Word8 -> IO () -foreign import ccall "DXFI_ReleaseBaseImage" dxfi_ReleaseBaseImage :: Ptr a -> IO () -foreign import ccall "DXFI_CreateGraphFromBaseImage" dxfi_CreateGraphFromBaseImage :: Ptr a -> IO Handle -foreign import ccall "DXFI_Helper_SizeOfBaseImage" dxfi_Helper_SizeOfBaseImage :: IO Int -foreign import ccall "DXFI_DeleteImage" dxfi_DeleteImage :: Handle -> IO () -foreign import ccall "DXFI_DeleteSound" dxfi_DeleteSound :: Handle -> IO () -foreign import ccall "DXFI_GetMouseInput" dxfi_GetMouseInput :: IO Int -foreign import ccall "DXFI_GetMouseWheelRotVol" dxfi_GetMouseWheelRotVol :: IO Int -foreign import ccall "DXFI_GetMousePoint" dxfi_GetMousePoint :: Ptr CInt -> Ptr CInt -> IO () - -loadImage :: Bitmap -> IO Handle -loadImage bmp = do - let img = bitmapData bmp - let Z :. height :. width :. _ = extent img - bimg <- dxfi_Helper_SizeOfBaseImage >>= mallocBytes - dxfi_CreateARGB8ColorBaseImage width height bimg - withPool numCapabilities $ \pool -> parallel_ pool [ - forM_ [0..width-1] $ \x -> - let r = (img !) $ Z :. y :. x :. 3 - g = (img !) $ Z :. y :. x :. 2 - b = (img !) $ Z :. y :. x :. 1 - a = (img !) $ Z :. y :. x :. 0 - in dxfi_SetPixelBaseImage bimg x y r g b a - | y <- [0..height-1]] - h <- dxfi_CreateGraphFromBaseImage bimg - dxfi_ReleaseBaseImage bimg - free bimg - return h - -unloadImage :: Handle -> IO () -unloadImage = dxfi_DeleteImage - -drawPicture' :: IM.IntMap Handle -> Picture -> IO () -drawPicture' m picture = forM_ (trans picture) $ \(_, (x, y), s, a, h) -> dxfi_DrawImageBy (floor x) (floor y) s a h True False where - trans (Image u) = [(False, (0,0), 1, 0, m IM.! hashUnique u)] - trans (Transform pic) = [(True, (x, y), s, a, h) | (_, (x, y), s, a, h) <- trans pic] - trans (NoTransform pic) = [(False, (x, y), s, a, h) | (_, (x, y), s, a, h) <- trans pic] - trans (Translate (dx, dy) pic) = [(f, (x + dx, y + dy), s, a, h) | (f, (x, y), s, a, h) <- trans pic] - trans (Rotate t pic) = [(f, (x * cos t - y * sin t, x * sin t + y * cos t), s, if f then a + t else a, h) | (f, (x, y), s, a, h) <- trans pic] - trans (Scale k pic) = [(f, (k * x, k * y), if f then k * s else s, a, h) | (f, (x, y), s, a, h) <- trans pic] - trans (Pictures ps) = concatMap trans ps - -loadSound' :: FilePath -> IO Handle -loadSound' path = withCWString path $ \x -> dxfi_LoadSound x 3 (-1) - -playSound' :: IM.IntMap Handle -> Sound -> IO () -playSound' m (Wave u) = do - let h = m IM.! hashUnique u - dxfi_PlaySound h 1 True - -unloadSound :: Handle -> IO () -unloadSound = dxfi_DeleteSound - -data SystemState = SystemState - { - sysLoadedImages :: IM.IntMap Handle - ,sysLoadedSounds :: IM.IntMap Handle - ,sysStartTime :: Int - ,sysFrameCount :: Int - ,sysRandomGen :: StdGen - ,sysTimeCriteria :: Int - } - -runGame :: GameParam -> Game a -> IO (Maybe a) -runGame param game = do - dxfi_SetWindowMode (windowed param) - uncurry dxfi_SetWindowSize (windowSize param) - dxfi_SetLogging False - withCWString (windowTitle param) dxfi_SetWindowCaption - - dxfi_Initialize - dxfi_SetDrawingDestination (-2) - - time <- dxfi_GetTickCount False - gen <- maybe getStdGen (return . mkStdGen) $ randomSeed param - result <- run [] [] game `evalStateT` SystemState IM.empty IM.empty time 0 gen time - - dxfi_Release - - return result - where - run :: [Int] -> [Int] -> Game a -> StateT SystemState IO (Maybe a) - run is ss (Pure a) = do - st <- get - lift $ forM_ is $ unloadImage . (sysLoadedImages st IM.!) - lift $ forM_ ss $ unloadSound . (sysLoadedSounds st IM.!) - put $ st { sysLoadedImages = foldr IM.delete (sysLoadedImages st) is - , sysLoadedSounds = foldr IM.delete (sysLoadedSounds st) ss } - return (Just a) - - run is ss (Free x) = case x of - - DrawPicture pic cont -> do - st <- get - lift $ drawPicture' (sysLoadedImages st) pic - run is ss cont - - PlaySound sound cont -> do - st <- get - lift $ playSound' (sysLoadedSounds st) sound - run is ss cont - - AskInput key cont -> lift (isPressed key) >>= run is ss . cont - - Randomness r cont -> do - st <- get - let (v, g) = randomR r (sysRandomGen st) - put $ st {sysRandomGen = g} - run is ss $ cont v - - LoadPicture path cont -> do - st <- get - h <- lift $ loadImage path - u <- lift $ newUnique - put $ st { sysLoadedImages = IM.insert (hashUnique u) h (sysLoadedImages st) } - run (hashUnique u:is) ss $ cont (Image u) - - LoadSound path cont -> do - st <- get - h <- lift $ loadSound' path - u <- lift $ newUnique - put $ st { sysLoadedSounds = IM.insert (hashUnique u) h (sysLoadedSounds st) } - run is (hashUnique u:ss) $ cont (Wave u) - - GetMouseState cont -> do - (x, y) <- lift $ alloca $ \px -> alloca $ \py -> - dxfi_GetMousePoint px py >> (,) `liftM` peek px `ap` peek py - b <- lift $ dxfi_GetMouseInput - w <- lift $ dxfi_GetMouseWheelRotVol - run is ss $ cont $ MouseState (fromIntegral x, fromIntegral y) (testBit b 0) (testBit b 2) (testBit b 1) w - - EmbedIO m -> lift m >>= run is ss - - Bracket m -> run is ss m >>= maybe (return Nothing) (run is ss) - - GetRealTime cont -> lift (dxfi_GetTickCount False) >>= run is ss . cont . (/1000) . fromIntegral - - ResetRealTime cont -> do - st <- get - t <- lift $ dxfi_GetTickCount False - put $ st { sysTimeCriteria = t } - run is ss cont - - Tick cont -> do - lift dxfi_FlipScreen - - time <- lift $ dxfi_GetTickCount False - st@(SystemState _ _ startTime frameCount _ _) <- get - lift $ dxfi_Wait $ (frameCount * 1000) `div` framePerSecond param - time + startTime - - if time - startTime >= 1000 - then put $ st {sysStartTime = time, sysFrameCount = 0} - else put $ st {sysFrameCount = succ frameCount} - - p <- lift processMessage - - if (p == 0) - then pre >> run is ss cont - else return Nothing - where - pre = do - lift (dxfi_ClearScreen nullPtr) - lift $ dxfi_setBackgroundColor 255 255 255 - -isPressed = dxfi_IsKeyPressed . k - where - k KeyEsc = 0x01 - k (KeyChar '1') = 0x02 - k (KeyChar '2') = 0x03 - k (KeyChar '3') = 0x04 - k (KeyChar '4') = 0x05 - k (KeyChar '5') = 0x06 - k (KeyChar '6') = 0x07 - k (KeyChar '7') = 0x08 - k (KeyChar '8') = 0x09 - k (KeyChar '9') = 0x0A - k (KeyChar '0') = 0x0B - k (KeyChar '-') = 0x0C - k KeyBackspace = 0x0E - k KeyTab = 0x0F - k (KeyChar 'Q') = 0x10 - k (KeyChar 'W') = 0x11 - k (KeyChar 'E') = 0x12 - k (KeyChar 'R') = 0x13 - k (KeyChar 'T') = 0x14 - k (KeyChar 'Y') = 0x15 - k (KeyChar 'U') = 0x16 - k (KeyChar 'I') = 0x17 - k (KeyChar 'O') = 0x18 - k (KeyChar 'P') = 0x19 - k (KeyChar '[') = 0x1A - k (KeyChar ']') = 0x1B - k KeyEnter = 0x1C - k KeyLeftControl = 0x1D - k (KeyChar 'A') = 0x1E - k (KeyChar 'S') = 0x1F - k (KeyChar 'D') = 0x20 - k (KeyChar 'F') = 0x21 - k (KeyChar 'G') = 0x22 - k (KeyChar 'H') = 0x23 - k (KeyChar 'J') = 0x24 - k (KeyChar 'K') = 0x25 - k (KeyChar 'L') = 0x26 - k (KeyChar ';') = 0x27 - k KeyLeftShift = 0x2A - k (KeyChar '\\') = 0x2B - k (KeyChar 'Z') = 0x2C - k (KeyChar 'X') = 0x2D - k (KeyChar 'C') = 0x2E - k (KeyChar 'V') = 0x2F - k (KeyChar 'B') = 0x30 - k (KeyChar 'N') = 0x31 - k (KeyChar 'M') = 0x32 - k (KeyChar ',') = 0x33 - k (KeyChar '.') = 0x34 - k (KeyChar '/') = 0x35 - k KeyRightShift = 0x36 - k KeySpace = 0x39 - k KeyF1 = 0x3B - k KeyF2 = 0x3C - k KeyF3 = 0x3D - k KeyF4 = 0x3E - k KeyF5 = 0x3F - k KeyF6 = 0x40 - k KeyF7 = 0x41 - k KeyF8 = 0x42 - k KeyF9 = 0x43 - k KeyF10 = 0x44 - k KeyNumLock = 0x45 - k KeyPad7 = 0x47 - k KeyPad8 = 0x48 - k KeyPad9 = 0x49 - k KeyPad4 = 0x4B - k KeyPad5 = 0x4C - k KeyPad6 = 0x4D - k KeyPad1 = 0x4F - k KeyPad2 = 0x50 - k KeyPad3 = 0x51 - k KeyPad0 = 0x52 - k KeyF11 = 0x57 - k KeyF12 = 0x58 - k KeyF13 = 0x64 - k KeyF14 = 0x65 - k KeyF15 = 0x66 - k KeyHome = 0xC7 - k KeyUp = 0xC8 - k KeyLeft = 0xCB - k KeyRight = 0xCD - k KeyEnd = 0xCF - k KeyDown = 0xD0 - k KeyInsert = 0xD2 - k KeyDelete = 0xD3
+ Graphics/FreeGame/Backends/GLFW.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ImplicitParams, ScopedTypeVariables #-} +module Graphics.FreeGame.Backends.GLFW (runGame) where +import Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL.GL as GL +import Graphics.FreeGame.Base +import Graphics.FreeGame.Bitmap +import qualified Graphics.FreeGame.Input as I +import Codec.Picture.Repa +import Control.Monad.Free +import Control.Monad +import System.Random +import Data.Unique +import Data.IORef +import Data.Array.Repa as R +import Data.StateVar +import qualified Data.Array.Repa.Repr.ForeignPtr as RF +import Foreign.ForeignPtr +import qualified Data.IntMap as IM +import Unsafe.Coerce +import Data.Vect +import System.Mem + +data Texture = Texture {texObj :: GL.TextureObject, texWidth :: Int, texHeight :: Int} + +installTexture :: Bitmap -> IO Texture +installTexture bmp = do + [tex] <- GL.genObjectNames 1 + GL.textureBinding GL.Texture2D GL.$= Just tex + + fptr <- liftM RF.toForeignPtr $ computeP $ bitmapData bmp + let (width, height) = bitmapSize bmp + withForeignPtr fptr + $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 (GL.TextureSize2D (gsizei width) (gsizei height)) 0 + . GL.PixelData GL.RGBA GL.UnsignedInt8888 + + return $ Texture tex width height + +drawPic :: (?refTextures :: IORef (IM.IntMap Texture)) => Picture -> IO () +drawPic (Image u) = do + Texture tex width height <- liftM (IM.! hashUnique u) $ readIORef ?refTextures + let (w, h) = (fromIntegral width / 2, fromIntegral height / 2) + GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Repeat) + GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Repeat) + GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest) + GL.texture GL.Texture2D $= GL.Enabled + GL.textureFunction $= GL.Combine + GL.textureBinding GL.Texture2D $= Just tex + GL.currentColor $= GL.Color4 1.0 1.0 1.0 1.0 + GL.renderPrimitive GL.Polygon $ zipWithM_ + (\(pX, pY) (tX, tY) -> do + GL.texCoord $ GL.TexCoord2 (gf tX) (gf tY) + GL.vertex $ GL.Vertex2 (gf pX) (gf pY)) + [(-w, -h), (w, -h), (w, h), (-w, h)] + [(0,0), (1.0,0), (1.0,1.0), (0,1.0)] + GL.texture GL.Texture2D GL.$= GL.Disabled + +drawPic (Rotate theta p) = GL.preservingMatrix $ GL.rotate (gf theta) (GL.Vector3 0 0 (-1)) >> drawPic p +drawPic (Scale (Vec2 sx sy) p) = GL.preservingMatrix $ GL.scale (gf sx) (gf sy) 1 >> drawPic p +drawPic (Translate (Vec2 tx ty) p) = GL.preservingMatrix $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0) >> drawPic p +drawPic (Pictures ps) = mapM_ drawPic ps + +runGame :: GameParam -> Game a -> IO (Maybe a) +runGame param game = do + initialize + pf <- openGLProfile + let ?windowWidth = fst $ windowSize param + ?windowHeight = snd $ windowSize param + openWindow $ defaultDisplayOptions { + displayOptions_width = fromIntegral ?windowWidth + ,displayOptions_height = fromIntegral ?windowHeight + ,displayOptions_displayMode = Window + ,displayOptions_windowIsResizable = False + ,displayOptions_openGLProfile = pf + } + setWindowTitle $ windowTitle param + GL.lineSmooth $= GL.Enabled + GL.blend $= GL.Enabled + GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha) + GL.shadeModel $= GL.Smooth + GL.clearColor $= GL.Color4 1 1 1 1 + ref <- newIORef IM.empty + ref' <- newIORef 0 + let ?refTextures = ref + ?refFrame = ref' + ?frameTime = 1 / fromIntegral (framePerSecond param) + r <- run [] game + + closeWindow + terminate + return r + where + run :: (?windowWidth :: Int, ?windowHeight :: Int + , ?refTextures :: IORef (IM.IntMap Texture) + , ?refFrame :: IORef Int + , ?frameTime :: Double) => [Int] -> Game a -> IO (Maybe a) + run is (Pure x) = do + m <- readIORef ?refTextures + GL.deleteObjectNames [texObj $ m IM.! i | i <- is] + modifyIORef ?refTextures $ flip (foldr IM.delete) is + return (Just x) + run is (Free f) = case f of + EmbedIO m -> m >>= run is + Bracket m -> run [] m >>= maybe (return Nothing) (run is) + Tick cont -> do + swapBuffers + t <- getTime + n <- readIORef ?refFrame + sleep (fromIntegral n * ?frameTime - t) + if t > 1 + then resetTime >> writeIORef ?refFrame 0 + else writeIORef ?refFrame (succ n) + + r <- windowIsOpen + if r + then GL.clear [GL.ColorBuffer] >> performGC >> run is cont + else return Nothing + AskInput key fcont -> keyIsPressed (mapKey key) >>= run is . fcont + GetMouseState fcont -> do + (x, y) <- getMousePosition + b0 <- mouseButtonIsPressed MouseButton0 + b1 <- mouseButtonIsPressed MouseButton1 + b2 <- mouseButtonIsPressed MouseButton1 + w <- getMouseWheel + run is $ fcont $ I.MouseState (Vec2 (fromIntegral x) (fromIntegral y)) b0 b2 b1 w + DrawPicture pic cont -> do + GL.preservingMatrix $ do + GL.loadIdentity + GL.scale (gf 1) (-1) 1 + GL.ortho 0 (fromIntegral ?windowWidth) 0 (fromIntegral ?windowHeight) 0 (-100) + GL.matrixMode $= GL.Modelview 0 + drawPic pic + GL.matrixMode $= GL.Projection + run is cont + LoadPicture bmp fcont -> do + tex <- installTexture bmp + u <- newUnique + modifyIORef ?refTextures $ IM.insert (hashUnique u) tex + run (hashUnique u:is) $ fcont (Image u) + + mapKey k = case k of + I.KeyChar c -> CharKey c + I.KeySpace -> KeySpace + I.KeyF1 -> KeyF1 + I.KeyF2 -> KeyF2 + I.KeyF3 -> KeyF3 + I.KeyF4 -> KeyF4 + I.KeyF5 -> KeyF5 + I.KeyF6 -> KeyF6 + I.KeyF7 -> KeyF7 + I.KeyF8 -> KeyF8 + I.KeyF9 -> KeyF9 + I.KeyF10 -> KeyF10 + I.KeyF11 -> KeyF11 + I.KeyF12 -> KeyF12 + I.KeyF13 -> KeyF13 + I.KeyF14 -> KeyF14 + I.KeyF15 -> KeyF15 + I.KeyEsc -> KeyEsc + I.KeyUp -> KeyUp + I.KeyDown -> KeyDown + I.KeyLeft -> KeyLeft + I.KeyRight -> KeyRight + I.KeyLeftShift -> KeyLeftShift + I.KeyRightShift -> KeyLeftShift + I.KeyLeftControl -> KeyLeftCtrl + I.KeyRightControl -> KeyRightCtrl + I.KeyTab -> KeyTab + I.KeyEnter -> KeyEnter + I.KeyBackspace -> KeyBackspace + I.KeyInsert -> KeyInsert + I.KeyDelete -> KeyDel + I.KeyPageUp -> KeyPageup + I.KeyPageDown -> KeyPagedown + I.KeyHome -> KeyHome + I.KeyEnd -> KeyEnd + I.KeyPad0 -> KeyPad0 + I.KeyPad1 -> KeyPad1 + I.KeyPad2 -> KeyPad2 + I.KeyPad3 -> KeyPad3 + I.KeyPad4 -> KeyPad4 + I.KeyPad5 -> KeyPad5 + I.KeyPad6 -> KeyPad6 + I.KeyPad7 -> KeyPad7 + I.KeyPad8 -> KeyPad8 + I.KeyPad9 -> KeyPad9 + I.KeyPadDivide -> KeyPadDivide + I.KeyPadMultiply -> KeyPadMultiply + I.KeyPadSubtract -> KeyPadSubtract + I.KeyPadAdd -> KeyPadAdd + I.KeyPadDecimal -> KeyPadDecimal + I.KeyPadEqual -> KeyPadEqual + I.KeyPadEnter -> KeyPadEnter + +gf :: Float -> GL.GLfloat +{-# INLINE gf #-} +gf x = unsafeCoerce x + +gsizei :: Int -> GL.GLsizei +{-# INLINE gsizei #-} +gsizei x = unsafeCoerce x
Graphics/FreeGame/Base.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.FreeGame.Base @@ -20,16 +20,12 @@ ,transPicture ,defaultGameParam ,tick - ,playSound ,drawPicture ,loadPicture ,askInput - ,loadSound + ,getMouseState ,embedIO ,bracket - ,getRealTime - ,resetRealTime - ,randomness ) where import Control.Monad.Free @@ -37,9 +33,8 @@ import Control.Monad import Graphics.FreeGame.Bitmap import Graphics.FreeGame.Input -import Graphics.FreeGame.Sound -import System.Random import Data.Unique +import Data.Vect type Game = Free GameAction @@ -51,28 +46,16 @@ | DrawPicture Picture cont | LoadPicture Bitmap (Picture -> cont) - | PlaySound Sound cont - | LoadSound FilePath (Sound -> cont) - | AskInput Key (Bool -> cont) | GetMouseState (MouseState -> cont) - | GetRealTime (Float -> cont) - | ResetRealTime cont - - | forall a. Random a => Randomness (a, a) (a -> cont) - instance Functor GameAction where fmap f (DrawPicture a cont) = DrawPicture a (f cont) fmap f (LoadPicture a cont) = LoadPicture a (f . cont) - fmap f (PlaySound a cont) = PlaySound a (f cont) - fmap f (LoadSound a cont) = LoadSound a (f . cont) fmap f (AskInput a cont) = AskInput a (f . cont) - fmap f (Randomness a cont) = Randomness a (f . cont) + fmap f (GetMouseState cont) = GetMouseState (f . cont) fmap f (EmbedIO m) = EmbedIO (fmap f m) fmap f (Bracket m) = Bracket (fmap f m) - fmap f (GetRealTime cont) = GetRealTime (f . cont) - fmap f (ResetRealTime cont) = ResetRealTime (f cont) fmap f (Tick cont) = Tick (f cont) -- | Finalize the current frame and refresh the screen. @@ -95,14 +78,6 @@ loadPicture :: MonadFree GameAction m => Bitmap -> m Picture loadPicture img = wrap $ LoadPicture img return --- | Play 'Sound'. -playSound :: MonadFree GameAction m => Sound -> m () -playSound sound = wrap $ PlaySound sound (return ()) - --- | Create 'Sound' from file. -loadSound :: MonadFree GameAction m => FilePath -> m Sound -loadSound path = wrap $ LoadSound path return - -- | Is the specified key is pressed? askInput :: MonadFree GameAction m => Key -> m Bool askInput key = wrap $ AskInput key return @@ -111,18 +86,6 @@ getMouseState :: MonadFree GameAction m => m MouseState getMouseState = wrap $ GetMouseState return --- | Get elapsed time since program began or 'resetRealTime' was called. -getRealTime :: MonadFree GameAction m => m Float -getRealTime = wrap $ GetRealTime return - --- | Reset the elapsed time. -resetRealTime :: MonadFree GameAction m => m () -resetRealTime = wrap $ ResetRealTime (return ()) - --- | Get random value from specified range. -randomness :: (Random r, MonadFree GameAction m) => (r, r) -> m r -randomness r = wrap $ Randomness r return - -- | Apply the function to all pictures in 'DrawPicture'. transPicture :: (Picture -> Picture) -> GameAction cont -> GameAction cont transPicture f (DrawPicture p cont) = DrawPicture (f p) cont @@ -132,19 +95,14 @@ data Picture -- | An abstract image object. = Image Unique - -- | Allow image transforming at Rotate/Scale. - | Transform Picture - -- | Don't allow image transforming at Rotate/Scale. - | NoTransform Picture -- | Combined picture from some pictures. | Pictures [Picture] - -- | Rotated picture counterclockwise by the given angle (in radians). - | Rotate Double Picture + -- | Rotated picture counterclockwise by the given angle (in degrees). + | Rotate Float Picture -- | Scaled picture. - | Scale Double Picture + | Scale Vec2 Picture -- | A picture moved by the given coordinate. - | Translate (Double, Double) Picture - + | Translate Vec2 Picture -- | Parameters of the application. data GameParam = GameParam { @@ -152,8 +110,7 @@ ,windowSize :: (Int, Int) ,windowTitle :: String ,windowed :: Bool - ,randomSeed :: Maybe Int } defaultGameParam :: GameParam -defaultGameParam = GameParam 60 (640,480) "free-game" True Nothing+defaultGameParam = GameParam 60 (640,480) "free-game" True
Graphics/FreeGame/Bitmap.hs view
@@ -11,21 +11,24 @@ -- Manipulating bitmaps ---------------------------------------------------------------------------- -module Graphics.FreeGame.Bitmap (Bitmap, bitmapData, loadBitmapFromFile, cropBitmap) where +module Graphics.FreeGame.Bitmap (Bitmap, bitmapData, bitmapSize, loadBitmapFromFile, cropBitmap, Font, loadFont, charToBitmap) where import Control.Applicative import Codec.Picture.Repa import Data.Array.Repa as R import Data.Word -import qualified Data.Array.Repa.Repr.ForeignPtr as RF import Data.Array.IArray as A import qualified Graphics.Rendering.TrueType.STB as TT newtype Bitmap = Bitmap { bitmapData :: R.Array D DIM3 Word8 } +-- | Get the size of the 'Bitmap'. +bitmapSize :: Bitmap -> (Int, Int) +bitmapSize bmp = let (Z :. h :. w :. _) = R.extent (bitmapData bmp) in (w, h) + -- | Create 'Bitmap' from given path. loadBitmapFromFile :: FilePath -> IO Bitmap -loadBitmapFromFile path = Bitmap <$> delay <$> imgData <$> either error id <$> (readImageRGBA path) +loadBitmapFromFile path = Bitmap <$> delay <$> imgData <$> either error id <$> readImageRGBA path -- | Extract bitmap from the specified range. cropBitmap :: Bitmap -- ^original bitmap @@ -36,18 +39,24 @@ newtype Font = Font TT.BitmapCache -loadFontFromFile :: FilePath -> (Float, Float) -> IO Font -loadFontFromFile path sc = do +-- create 'Font' from given file. +loadFont :: FilePath -> Float -> IO Font +loadFont path size = do tt <- TT.loadTTF path o <- head <$> TT.enumerateFonts tt font <- TT.initFont tt o - Font <$> TT.newBitmapCache font False sc + Just g <- TT.findGlyph font '|' + TT.BBox (x0,y0) (x1,y1) <- TT.getGlyphBoundingBox font g + let s = size/fromIntegral (x1-x0) + Font <$> TT.newBitmapCache font False (s, s) -charToBitmap :: Font -> Char -> IO (Maybe (Bitmap, Float)) -charToBitmap (Font cache) ch = do +-- render 'Bitmap' of given character by specified 'Font' and color(RGB). +charToBitmap :: Font -> (Word8, Word8, Word8) -> Char -> IO (Maybe (Bitmap, Float, Float, Float)) +charToBitmap (Font cache) (red,green,blue) ch = do r <- TT.getCachedBitmap cache ch case r of - Just (TT.CBM bmp@(TT.Bitmap (w,h) _) _ (TT.HMetrics adv _)) -> do + Just (TT.CBM bmp@(TT.Bitmap (w,h) _) (ox,oy) (TT.HMetrics adv _)) -> do ar <- TT.bitmapArray bmp - return $ Just (Bitmap $ fromFunction (Z :. h :. w :. 4) (\(Z:.y:.x:._) -> ar A.! (y, x)), adv) - Nothing -> return Nothing+ let pixel (Z:.y:.x:.c) = [ar A.! (y, x), red, green, blue] !! c + return $ Just (Bitmap $ fromFunction (Z :. h :. w :. 4) pixel, fromIntegral ox / 2, fromIntegral oy / 2, adv) + Nothing -> return Nothing
Graphics/FreeGame/Input.hs view
@@ -13,12 +13,14 @@ module Graphics.FreeGame.Input where -data MouseState = MouseState { position :: (Double, Double) +import Data.Vect + +data MouseState = MouseState { mousePosition :: Vec2 , leftButton :: Bool , middleButton :: Bool , rightButton :: Bool , mouseWheel :: Int - } deriving (Eq, Ord, Show) + } deriving Show data Key = KeyChar Char @@ -51,8 +53,6 @@ | KeyEnter | KeyBackspace | KeyInsert - | KeyNumLock - | KeyBegin | KeyDelete | KeyPageUp | KeyPageDown
− Graphics/FreeGame/Sound.hs
@@ -1,5 +0,0 @@-module Graphics.FreeGame.Sound where - -import Data.Unique - -data Sound = Wave Unique
Graphics/FreeGame/Util.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.FreeGame.Util @@ -8,16 +9,45 @@ -- Stability : provisional -- Portability : portable -- --- Transforming Game monads ---------------------------------------------------------------------------- -module Graphics.FreeGame.Util where +module Graphics.FreeGame.Util (untickGame, randomness, degrees, radians, withRenderString, loadPictureFromFile) where +import Control.Applicative +import Control.Monad import Control.Monad.Free import qualified Control.Monad.Trans.Free as T import Graphics.FreeGame.Base +import Graphics.FreeGame.Bitmap +import System.Random +import Data.Vect +import Data.Word -- | Run 'Game' as one frame. untickGame :: Game a -> Game (Game a) untickGame (Pure a) = Pure (Pure a) untickGame (Free (Tick cont)) = Pure cont -untickGame (Free fm) = Free $ fmap untickGame fm+untickGame (Free fm) = Free $ fmap untickGame fm + +-- | Get a random value from the given range. +randomness :: (Random r, MonadFree GameAction m) => (r, r) -> m r +randomness r = embedIO $ randomRIO r + +degrees :: Float -> Float +{-# INLINE degrees #-} +degrees x = x / pi * 180 + +radians :: Float -> Float +{-# INLINE radians #-} +radians x = x / 180 * pi + +withRenderString :: Font -> (Word8, Word8, Word8) -> String -> (Picture -> Game a) -> Game a +withRenderString font color str action = bracket $ render str 0 >>= action . Pictures + where + render [] _ = return [] + render (c:cs) x = do + Just (b, o, h, w) <- embedIO $ charToBitmap font color c + (:) <$> Translate (Vec2 (x + w + o) h) <$> loadPicture b + <*> render cs (x + w) + +loadPictureFromFile :: FilePath -> Game Picture +loadPictureFromFile = embedIO . loadBitmapFromFile >=> loadPicture
+ examples/logo.png view
binary file changed (absent → 1893 bytes)
+ examples/test.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ImplicitParams #-} +import Graphics.FreeGame +import Control.Applicative +import Control.Monad +import Data.Vect + +act :: (?pic :: Picture) => Vec2 -> Vec2 -> Bool -> Game () +act pos@(Vec2 x y) vel@(Vec2 dx dy) btn = do + + drawPicture $ Translate pos $ Rotate (degrees $ angle2 vel) ?pic + + let dx' | x <= 0 = abs dx + | x >= 640 = -(abs dx) + | otherwise = dx + dy' | y <= 0 = abs dy + | y >= 480 = -(abs dy) + | otherwise = dy + + mouse <- getMouseState + vel' <- if not btn && leftButton mouse && norm (mousePosition mouse &- pos) < 32 + then (&*3) <$> sinCos <$> randomness (0, 2 * pi) + else return (Vec2 dx' dy') + tick + act (pos &+ vel) vel' (leftButton mouse) + +initial :: (?pic :: Picture) => Game () +initial = do + x <- randomness (0,640) + y <- randomness (0,480) + a <- randomness (0, 2 * pi) + act (Vec2 x y) (sinCos a &* 4) False + +main = runGame defaultGameParam $ do + pic <- loadPictureFromFile "logo.png" + let ?pic = pic + run (replicate 24 initial) + where + run ms = do + ms' <- mapM untickGame ms + tick + run ms'
free-game.cabal view
@@ -1,5 +1,5 @@ name: free-game -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Create graphical applications for free. description: Create something graphical with useful free monads. @@ -14,7 +14,7 @@ . * That's all! . - In windows, free-game requires DXFI.dll. You can obtain it from <http://botis.org/shared/dist/DXFI-0.2.dll>. + There are experimental implementation of text rendering, but it yields strange pictures. homepage: https://github.com/fumieval/free-game license: BSD3 @@ -25,24 +25,30 @@ category: Graphics build-type: Simple cabal-version: >=1.8 - +extra-source-files: + examples/test.hs + examples/logo.png + library exposed-modules: Graphics.FreeGame , Graphics.FreeGame.Util - , Graphics.FreeGame.Sound , Graphics.FreeGame.Input , Graphics.FreeGame.Bitmap , Graphics.FreeGame.Base - , Graphics.FreeGame.Backends.DXFI + , Graphics.FreeGame.Backends.GLFW + ghc-options: -fexcess-precision -- other-modules: - build-depends: base == 4.5.* + build-depends: base == 4.* , mtl >= 2.1 , containers >= 0.4 , free == 3.* , random == 1.* , repa >= 3.2 , JuicyPixels-repa >= 0.4 + , vect >= 0.4.6 , array >= 0.3 , filepath >= 1.3 - , parallel-io >= 0.3 - , stb-truetype >= 0.1+ , stb-truetype >= 0.1 + , OpenGL >= 2.5 + , GLFW-b >= 0.1 + , StateVar