free-game 0.9.3.1 → 0.9.3.2

raw patch · 8 files changed

+72/−197 lines, 8 filesdep +colorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: colors

API changes (from Hackage documentation)

Files

• Graphics/UI/FreeGame.hs +6/−4
• Graphics/UI/FreeGame/Base.hs +4/−1
• Graphics/UI/FreeGame/Data/Color.hs +0/−138
• Graphics/UI/FreeGame/Data/Font.hs +5/−4
• Graphics/UI/FreeGame/GUI.hs +4/−5
• Graphics/UI/FreeGame/GUI/GLFW.hs +41/−38
• Graphics/UI/FreeGame/Util.hs +9/−4
• free-game.cabal +3/−3

@@ -17,14 +17,15 @@     module Graphics.UI.FreeGame.Base,
     module Graphics.UI.FreeGame.Data.Bitmap,
     module Graphics.UI.FreeGame.Data.Font,
-    module Graphics.UI.FreeGame.Data.Color,
     module Graphics.UI.FreeGame.GUI,
     module Graphics.UI.FreeGame.Util,
     module Graphics.UI.FreeGame.Text,
     module Graphics.UI.FreeGame.Types,
-    module Linear,
     module Control.Monad,
-    module Control.Applicative
+    module Control.Applicative,
+    module Data.Color,
+    module Data.Color.Names,
+    module Linear
 ) where
 
 import Graphics.UI.FreeGame.Base
@@ -34,7 +35,8 @@ import Graphics.UI.FreeGame.Text
 import Graphics.UI.FreeGame.Data.Bitmap
 import Graphics.UI.FreeGame.Data.Font
-import Graphics.UI.FreeGame.Data.Color
+import Data.Color
+import Data.Color.Names
 import qualified Graphics.UI.FreeGame.GUI.GLFW as GLFW
 import Control.Monad.Free.Church
 import Data.Default

@@ -42,9 +42,9 @@ import Control.Applicative.Free as Ap import Control.Monad.IO.Class import Data.Monoid+import Data.Color import Graphics.UI.FreeGame.Data.Bitmap import Graphics.UI.FreeGame.Data.Wave-import Graphics.UI.FreeGame.Data.Color import Graphics.UI.FreeGame.Internal.Finalizer import Graphics.UI.FreeGame.Internal.Raindrop import Linear hiding (rotate)@@ -180,6 +180,9 @@  class FromFinalizer m where     fromFinalizer :: FinalizerT IO a -> m a++instance FromFinalizer (FinalizerT IO) where+    fromFinalizer = id  data SpecialKey = KeySpace     | KeyEsc

@@ -1,138 +0,0 @@-{-# LANGUAGE Rank2Types #-}
------------------------------------------------------------------------------
--- |
--- Module      :  Graphics.UI.FreeGame.Data.Color
--- Copyright   :  (C) 2013 Fumiaki Kinoshita
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--- Stability   :  provisional
--- Portability :  non-portable
---
--- Colors and its operations
-----------------------------------------------------------------------------
-module Graphics.UI.FreeGame.Data.Color (
-    -- * The type
-    Color(..)
-    -- * Color operations
-    , blend
-    -- * Lenses
-    , _Red, _Green, _Blue, _Alpha, _8Bit
-    , _Hue, _Saturation, _Brightness
-    -- * Basic colors
-    , white, black, red, green, blue, yellow, cyan, magenta
-    ) where
-
-import Data.String
-import Data.Char
-import Data.Profunctor
-import Data.Word
-
--- | A color that has red, green, blue, alpha as its component.
-data Color = Color Float Float Float Float deriving (Show, Eq, Ord)
-
--- | @'_8Bit' :: Iso' 'Float' 'Word8'@
-_8Bit :: forall p f. (Profunctor p, Functor f) => p Word8 (f Word8) -> p Float (f Float)
-_8Bit = dimap (floor.(*255)) (fmap ((/255) . fromIntegral))
-
--- | @'_Red' :: Lens' 'Color' 'Float'@
-_Red :: Functor f => (Float -> f Float) -> Color -> f Color
-_Red f (Color r g b a) = fmap (\r' -> Color r' g b a) (f r)
-
--- | @'_Green' :: Lens' 'Color' 'Float'@
-_Green :: Functor f => (Float -> f Float) -> Color -> f Color
-_Green f (Color r g b a) = fmap (\g' -> Color r g' b a) (f g)
-
--- | @'_Blue' :: Lens' 'Color' 'Float'@
-_Blue :: Functor f => (Float -> f Float) -> Color -> f Color
-_Blue f (Color r g b a) = fmap (\b' -> Color r g b' a) (f b)
-
--- | @'_Alpha' :: Lens' 'Color' 'Float'@
-_Alpha :: Functor f => (Float -> f Float) -> Color -> f Color
-_Alpha f (Color r g b a) = fmap (\a' -> Color r g b a') (f a)
-
-argb :: Float -> Float -> Float -> Float -> Color
-argb a r g b = Color r g b a
-
--- | @'_Hue' :: Lens' 'Color' 'Float'@
-_Hue :: Functor f => (Float -> f Float) -> Color -> f Color
-_Hue f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\h' -> hsv_rgb h' s v (argb a)) (f h)
-
--- | @'_Saturation' :: Lens' 'Color' 'Float'@
-_Saturation :: Functor f => (Float -> f Float) -> Color -> f Color
-_Saturation f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\s' -> hsv_rgb h s' v (argb a)) (f s)
-
--- | @'_Brightness' :: Lens' 'Color' 'Float'@
-_Brightness :: Functor f => (Float -> f Float) -> Color -> f Color
-_Brightness f (Color r g b a) = rgb_hsv r g b $ \h s v -> fmap (\v' -> hsv_rgb h s v' (argb a)) (f v)
-
-rgb_hsv :: Float -> Float -> Float -> (Float -> Float -> Float -> a) -> a
-rgb_hsv r g b f = f h (s / maxC) maxC where
-    maxC = r `max` g `max` b
-    minC = r `min` g `min` b
-    s = maxC - minC
-    h | maxC == r = (g - b) / s * 60
-      | maxC == g = (b - r) / s * 60 + 120
-      | maxC == b = (r - g) / s * 60 + 240
-      | otherwise = undefined
-
-hsv_rgb :: Float -> Float -> Float -> (Float -> Float -> Float -> a) -> a
-hsv_rgb h s v r
-    | h' == 0 = r v t p
-    | h' == 1 = r q v p
-    | h' == 2 = r p v t
-    | h' == 3 = r p q v
-    | h' == 4 = r t p v
-    | h' == 5 = r v p q
-    | otherwise = undefined
-    where
-        h' = floor (h / 60) `mod` 6 :: Int
-        f = h / 60 - fromIntegral h'
-        p = v * (1 - s)
-        q = v * (1 - f * s)
-        t = v * (1 - (1 - f) * s)    
-
-hf :: Char -> Float
-hf x = fromIntegral (digitToInt x) / 15
-
-hf' :: Char -> Char -> Float
-hf' x y = fromIntegral (digitToInt x * 16 + digitToInt y) / 255
-
-instance IsString Color where
-    fromString xs@[r,g,b,a] | all isHexDigit xs = Color (hf r) (hf g) (hf b) (hf a)
-    fromString xs@[r,g,b] | all isHexDigit xs = Color (hf r) (hf g) (hf b) 1
-    fromString xs@[r1,r0,g1,g0,b1,b0,a1,a0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) (hf' a1 a0)
-    fromString xs@[r1,r0,g1,g0,b1,b0] | all isHexDigit xs = Color (hf' r1 r0) (hf' g1 g0) (hf' b1 b0) 1
-    fromString x = error $ "Invalid color representation: " ++ x
-
--- | Blend two colors.
-blend :: Float -> Color -> Color -> Color
-blend t (Color r0 g0 b0 a0) (Color r1 g1 b1 a1) = Color
-    (r0 * (1 - t) + r1 * t)
-    (g0 * (1 - t) + g1 * t)
-    (b0 * (1 - t) + b1 * t)
-    (a0 * (1 - t) + a1 * t)
-
-white :: Color
-white = Color 1.0 1.0 1.0 1.0
-
-black :: Color
-black = Color 0.0 0.0 0.0 1.0
-
-red :: Color
-red = Color 1.0 0.0 0.0 1.0
-
-green :: Color
-green = Color 0.0 1.0 0.0 1.0
-
-blue :: Color
-blue = Color 0.0 0.0 1.0 1.0
-
-yellow :: Color
-yellow = Color 1.0 1.0 0.0 1.0
-
-cyan :: Color
-cyan = Color 0.0 1.0 1.0 1.0
-
-magenta :: Color
-magenta = Color 1.0 0.0 1.0 1.0

@@ -28,6 +28,7 @@ import qualified Data.Map as M
 import Data.Word
 import Linear
+import Graphics.UI.FreeGame.Base
 import Graphics.UI.FreeGame.Types
 import Graphics.UI.FreeGame.Data.Bitmap
 import Graphics.UI.FreeGame.Internal.Finalizer
@@ -50,8 +51,8 @@ data Font = Font FT_Face (Float, Float) (BoundingBox Float) (IORef (M.Map (Float, Char) RenderedChar))
 
 -- | Create a 'Font' from the given file.
-loadFont :: FilePath -> IO Font
-loadFont path = alloca $ \p -> do
+loadFont :: MonadIO m => FilePath -> m Font
+loadFont path = liftIO $ alloca $ \p -> do
     runFreeType $ withCString path $ \str -> ft_New_Face freeType str 0 p
     f <- peek p
     b <- peek (bbox f)
@@ -96,8 +97,8 @@ resolutionDPI :: Int
 resolutionDPI = 300
 
-charToBitmap :: Font -> Float -> Char -> FinalizerT IO RenderedChar
-charToBitmap (Font face _ _ refCache) pixel ch = do
+charToBitmap :: FromFinalizer m => Font -> Float -> Char -> m RenderedChar
+charToBitmap (Font face _ _ refCache) pixel ch = fromFinalizer $ do
     cache <- liftIO $ readIORef refCache
     case M.lookup (siz, ch) cache of
         Nothing -> do

@@ -21,20 +21,19 @@ ) where
 
 import Graphics.UI.FreeGame.Base
-import Graphics.UI.FreeGame.Data.Color
 import Graphics.UI.FreeGame.Data.Bitmap
 import Graphics.UI.FreeGame.Internal.Finalizer
 import Graphics.UI.FreeGame.Internal.Raindrop
 import Control.Applicative
-import Control.Applicative.Free (Ap)
 import Data.Default
+import Data.Color
 import Linear hiding (rotate)
 
 -- | A 'Functor' which represents graphical user interfaces.
 type GUI = UI GUIBase
 
 -- | The base of 'GUI'.
-data GUIBase a = Input (Ap GUIInput a) | Draw (Picture a) deriving Functor
+data GUIBase a = Input (GUIInput a) | Draw (Picture a) deriving Functor
 
 -- | _Draw :: Traversal' (GUIBase a) (Picture a)
 _Draw :: Applicative f => (Picture a -> f (Picture a)) -> GUIBase a -> f (GUIBase a)
@@ -42,7 +41,7 @@ _Draw _ x = pure x
 
 -- | _Input :: Traversal' (GUIBase a) (Ap GUIInput a)
-_Input :: Applicative f => (Ap GUIInput a -> f (Ap GUIInput a)) -> GUIBase a -> f (GUIBase a)
+_Input :: Applicative f => (GUIInput a -> f (GUIInput a)) -> GUIBase a -> f (GUIBase a)
 _Input f (Input o) = fmap Input (f o)
 _Input _ x = pure x
 
@@ -150,6 +149,6 @@         , _windowTitle = "free-game"
         , _windowed = True
         , _cursorVisible = True
-        , _clearColor = white
+        , _clearColor = Color 1 1 1 1
         , _windowOrigin = V2 0 0
         }

@@ -12,15 +12,14 @@ ----------------------------------------------------------------------------
 module Graphics.UI.FreeGame.GUI.GLFW (runGame) where
 import Control.Applicative
-import Control.Applicative.Free as Ap
 import Control.Monad
 import Control.Monad.Free.Church
 import Control.Monad.IO.Class
 import Data.IORef
+import Data.Color
 import Foreign.ForeignPtr
 import Graphics.UI.FreeGame.Base
 import Graphics.UI.FreeGame.Data.Bitmap
-import Graphics.UI.FreeGame.Data.Color
 import Graphics.UI.FreeGame.Internal.Finalizer
 import Graphics.UI.FreeGame.GUI
 import Graphics.Rendering.OpenGL.Raw.ARB.Compatibility
@@ -75,7 +74,7 @@                 GL.matrixMode $= GL.Modelview 0
             cont
 
-data Texture = Texture GL.TextureObject !Int !Int
+type Texture = (GL.TextureObject, Int, Int)
 
 bool :: a -> a -> Bool -> a
 bool r _ False = r
@@ -119,20 +118,18 @@         $ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA8 siz 0
         . GL.PixelData GL.RGBA GL.UnsignedInt8888
     finalizer $ GL.deleteObjectNames [tex]
-    return $ Texture tex width height
+    return (tex, width, height)
 
-runInput :: Ap GUIInput a -> IO a
-runInput (Ap.Pure a) = pure a
-runInput (Ap.Ap v af) = (runInput af <*>) $ case v of
-    ICharKey ch cont -> cont <$> GLFW.keyIsPressed (GLFW.CharKey ch)
-    ISpecialKey x cont -> cont <$> GLFW.keyIsPressed (mapSpecialKey x)
-    IMouseButtonL cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton0
-    IMouseButtonR cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton1
-    IMouseButtonM cont -> cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton2
-    IMousePosition cont -> do
-        (x, y) <- GLFW.getMousePosition
-        return $ cont $ V2 (fromIntegral x) (fromIntegral y)
-    IMouseWheel cont -> cont <$> GLFW.getMouseWheel
+runInput :: GUIInput a -> IO a
+runInput (ICharKey ch cont) = cont <$> GLFW.keyIsPressed (GLFW.CharKey ch)
+runInput (ISpecialKey x cont) = cont <$> GLFW.keyIsPressed (mapSpecialKey x)
+runInput (IMouseButtonL cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton0
+runInput (IMouseButtonR cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton1
+runInput (IMouseButtonM cont) = cont <$> GLFW.mouseButtonIsPressed GLFW.MouseButton2
+runInput (IMousePosition cont) = do
+    (x, y) <- GLFW.getMousePosition
+    return $ cont $ V2 (fromIntegral x) (fromIntegral y)
+runInput (IMouseWheel cont) = cont <$> GLFW.getMouseWheel
 
 runPicture :: (?refTextures :: IORef (IM.IntMap Texture)) => Float -> Picture a -> FinalizerT IO a
 runPicture _ (LiftBitmap bmp@(BitmapData _ (Just h)) r) = do
@@ -148,19 +145,19 @@ runPicture _ (LiftBitmap bmp@(BitmapData _ Nothing) r) = do
     liftIO $ runFinalizerT $ installTexture bmp >>= liftIO . drawTexture
     return r
+runPicture sc (Translate (V2 tx ty) cont) = preservingMatrix' $ do
+    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
+    runPicture sc cont
 runPicture sc (RotateD theta cont) = preservingMatrix' $ do
     liftIO $ GL.rotate (gf (-theta)) (GL.Vector3 0 0 1)
     runPicture sc cont
 runPicture sc (Scale (V2 sx sy) cont) = preservingMatrix' $ do
     liftIO $ GL.scale (gf sx) (gf sy) 1
     runPicture (sc * max sx sy) cont
-runPicture sc (Translate (V2 tx ty) cont) = preservingMatrix' $ do
-    liftIO $ GL.translate (GL.Vector3 (gf tx) (gf ty) 0)
-    runPicture sc cont
 runPicture _ (PictureWithFinalizer m) = m
-runPicture sc (Colored (Color r g b a) cont) = do
+runPicture sc (Colored col cont) = do
     oldColor <- liftIO $ get GL.currentColor
-    liftIO $ GL.currentColor $= GL.Color4 (gf r) (gf g) (gf b) (gf a)
+    liftIO $ GL.currentColor $= unsafeCoerce col
     res <- runPicture sc cont
     liftIO $ GL.currentColor $= oldColor
     return res
@@ -189,7 +186,7 @@     return res
 
 runVertices :: MonadIO m => [V2 Float] -> m ()
-runVertices = mapM_ (\(V2 x y) -> liftIO $ GL.vertex $ GL.Vertex2 (gf x) (gf y))
+runVertices = liftIO . mapM_ (GL.vertex . mkVertex2)
 
 preservingMatrix' :: MonadIO m => m a -> m a
 preservingMatrix' m = do
@@ -198,26 +195,21 @@     liftIO $ glPopMatrix
     return r
 
-gf :: Float -> GL.GLfloat
-{-# INLINE gf #-}
-gf x = unsafeCoerce x
-
-gsizei :: Int -> GL.GLsizei
-{-# INLINE gsizei #-}
-gsizei x = unsafeCoerce x
-
 drawTexture :: Texture -> IO ()
-drawTexture (Texture tex width height) = do
-    let (w, h) = (fromIntegral width / 2, fromIntegral height / 2)
+drawTexture (tex, width, height) = do
+    let (w, h) = (fromIntegral width / 2, fromIntegral height / 2) :: (GL.GLfloat, GL.GLfloat)
     GL.texture GL.Texture2D $= GL.Enabled
     GL.textureFilter GL.Texture2D $= ((GL.Nearest, Nothing), GL.Nearest)
     GL.textureBinding GL.Texture2D $= Just tex
-    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.renderPrimitive GL.Polygon $ do
+        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 0
+        GL.vertex $ GL.Vertex2 (-w) (-h)
+        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 0
+        GL.vertex $ GL.Vertex2 w (-h)
+        GL.texCoord $ GL.TexCoord2 (1 :: GL.GLfloat) 1
+        GL.vertex $ GL.Vertex2 w h
+        GL.texCoord $ GL.TexCoord2 (0 :: GL.GLfloat) 1
+        GL.vertex $ GL.Vertex2 (-w) h
     GL.texture GL.Texture2D $= GL.Disabled
 
 mapSpecialKey :: SpecialKey -> GLFW.Key
@@ -269,3 +261,14 @@ mapSpecialKey KeyPadDecimal = GLFW.KeyPadDecimal
 mapSpecialKey KeyPadEqual = GLFW.KeyPadEqual
 mapSpecialKey KeyPadEnter = GLFW.KeyPadEnter
+
+mkVertex2 :: V2 Float -> GL.Vertex2 GL.GLfloat
+mkVertex2 = unsafeCoerce
+
+gf :: Float -> GL.GLfloat
+{-# INLINE gf #-}
+gf x = unsafeCoerce x
+
+gsizei :: Int -> GL.GLsizei
+{-# INLINE gsizei #-}
+gsizei x = unsafeCoerce x

@@ -17,6 +17,7 @@     (<&&>),
     (<||>),
     -- * Controlling
+    foreverTick,
     untick,
     untickInfinite,
     -- * Random
@@ -32,19 +33,23 @@     loadBitmaps,
     loadBitmapsWith
     ) where
+import Control.Applicative
 import Control.Monad
 import Control.Monad.Free
-import Control.Applicative
 import Data.Char
+import Data.Void
 import Graphics.UI.FreeGame.Base
 import Graphics.UI.FreeGame.Data.Bitmap
-import System.Random
 import Language.Haskell.TH
+import Linear
 import System.Directory
 import System.FilePath
 import System.IO.Unsafe
-import Data.Void
-import Linear
+import System.Random
+
+-- | An infinite loop that run 'tick' every frame after the given action.
+foreverTick :: MonadFree (UI n) m => m a -> m any
+foreverTick m = m >> (tick >> foreverTick m)
 
 -- | A lifted 'not'.
 notF :: Functor f => f Bool -> f Bool

@@ -1,5 +1,5 @@ name:                free-game
-version:             0.9.3.1
+version:             0.9.3.2
 synopsis:            Create graphical applications for free
 description:         Cross-platform GUI library based on free monads
 homepage:            https://github.com/fumieval/free-game
@@ -25,7 +25,6 @@     Graphics.UI.FreeGame.Base
     Graphics.UI.FreeGame.Data.Bitmap
     Graphics.UI.FreeGame.Data.Wave
-    Graphics.UI.FreeGame.Data.Color
     Graphics.UI.FreeGame.Data.Font
     Graphics.UI.FreeGame.Text
     Graphics.UI.FreeGame.GUI
@@ -59,4 +58,5 @@     linear >= 1.1 && < 1.3,
     vector == 0.10.*,
     JuicyPixels-repa >= 0.5.1,
-    data-default+    data-default,
+    colors == 0.1.*