From 37f8f51094c55cabd31d48b2335ff24010212258 Mon Sep 17 00:00:00 2001 From: Zack Corr Date: Sun, 7 Jul 2013 20:10:08 +1000 Subject: [PATCH] Initial commit --- .gitignore | 1 + Demo.hs | 21 +++ FRP/Helm.hs | 147 +++++++++++++++++++ FRP/Helm/Color.hs | 85 +++++++++++ FRP/Helm/Graphics.hs | 176 ++++++++++++++++++++++ FRP/Helm/Internal.hs | 15 ++ FRP/Helm/Keyboard.hs | 337 +++++++++++++++++++++++++++++++++++++++++++ FRP/Helm/Mouse.hs | 34 +++++ FRP/Helm/Window.hs | 17 +++ LICENSE | 19 +++ Setup.hs | 3 + helm.cabal | 52 +++++++ 12 files changed, 907 insertions(+) create mode 100644 .gitignore create mode 100644 Demo.hs create mode 100644 FRP/Helm.hs create mode 100644 FRP/Helm/Color.hs create mode 100644 FRP/Helm/Graphics.hs create mode 100644 FRP/Helm/Internal.hs create mode 100644 FRP/Helm/Keyboard.hs create mode 100644 FRP/Helm/Mouse.hs create mode 100644 FRP/Helm/Window.hs create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 helm.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1521c8b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist diff --git a/Demo.hs b/Demo.hs new file mode 100644 index 0000000..8414a14 --- /dev/null +++ b/Demo.hs @@ -0,0 +1,21 @@ +import Control.Applicative +import FRP.Elerea.Simple +import FRP.Helm +import qualified FRP.Helm.Keyboard as Keyboard +import qualified FRP.Helm.Window as Window + +data State = State { mx :: Double, my :: Double } + +step :: (Int, Int) -> State -> State +step (dx, dy) state = state { mx = (realToFrac dx) + mx state, my = (realToFrac dy) + my state } + +render :: (Int, Int) -> State -> Element +render (w, h) (State { .. }) = collage w h [move (mx, my) $ filled (rgb 1 1 1) $ square 100] + +main :: IO () +main = run $ do + dims <- Window.dimensions + arrows <- Keyboard.arrows + stepper <- transfer (State { mx = 0, my = 100 }) step arrows + + return $ render <$> dims <*> stepper diff --git a/FRP/Helm.hs b/FRP/Helm.hs new file mode 100644 index 0000000..b404383 --- /dev/null +++ b/FRP/Helm.hs @@ -0,0 +1,147 @@ +module FRP.Helm ( + radians, + degrees, + turns, + run, + module FRP.Helm.Color, + module FRP.Helm.Graphics, +) where + +import Data.IORef +import FRP.Elerea.Simple +import FRP.Helm.Color +import FRP.Helm.Graphics +import FRP.Helm.Internal (keyState) +import Graphics.Rendering.Cairo.Internal (imageSurfaceGetData) +import qualified Data.Map as Map +import qualified Graphics.UI.SDL as SDL +import qualified Graphics.Rendering.Cairo as Cairo + +{-| Attempt to change the window dimensions (and initialize the video mode if not already). + Will try to get a hardware accelerated window and then fallback to a software one. + Throws an exception if the software mode can't be used as a fallback. -} +requestDimensions :: Int -> Int -> IO SDL.Surface +requestDimensions w h = do + mayhaps <- SDL.trySetVideoMode w h 32 [SDL.HWSurface, SDL.DoubleBuf, SDL.Resizable] + + case mayhaps of + Just screen -> return screen + Nothing -> SDL.setVideoMode w h 32 [SDL.SWSurface, SDL.Resizable] + +-- |Converts radians into the standard angle measurement (radians). +radians :: Float -> Float +radians n = n + +-- |Converts degrees into the standard angle measurement (radians). +degrees :: Float -> Float +degrees n = n * pi / 180 + +{-| Converts turns into the standard angle measurement (radians). + Turns are essentially full revolutions of the unit circle. -} +turns :: Float -> Float +turns n = 2 * pi * n + +{-| Initializes and runs the game engine. The supplied signal generator is + constantly sampled for an element to render until the user quits. -} +run :: SignalGen (Signal Element) -> IO () +run gen = SDL.init [SDL.InitVideo] >> requestDimensions 800 600 >> start gen >>= run' + +run' :: IO Element -> IO () +run' smp = do + continue <- run'' + + if continue then smp >>= render >> run' smp else SDL.quit + +run'' :: IO Bool +run'' = do + event <- SDL.pollEvent + keys <- readIORef keyState + + case event of + SDL.NoEvent -> return True + SDL.Quit -> return False + SDL.VideoResize w h -> requestDimensions w h >> run'' + SDL.KeyDown (SDL.Keysym { symKey }) -> writeIORef keyState (Map.insert symKey True keys) >> run'' + SDL.KeyUp (SDL.Keysym { symKey }) -> writeIORef keyState (Map.insert symKey False keys) >> run'' + _ -> run'' + +render :: Element -> IO () +render element = SDL.getVideoSurface >>= render' element + +render' :: Element -> SDL.Surface -> IO () +render' element screen = do + src <- Cairo.createImageSurface format w h + ptr <- imageSurfaceGetData src + dest <- SDL.createRGBSurfaceFrom ptr w h 32 stride rshift gshift bshift 0 + + Cairo.renderWith src (render'' w h element) + SDL.blitSurface dest Nothing screen Nothing >> SDL.flip screen + + where + w = SDL.surfaceGetWidth screen + h = SDL.surfaceGetHeight screen + format = Cairo.FormatARGB32 + stride = Cairo.formatStrideForWidth format w + rshift = 0x00ff0000 + gshift = 0x0000ff00 + bshift = 0x000000ff + +render'' :: Int -> Int -> Element -> Cairo.Render () +render'' w h element = do + Cairo.setSourceRGB 0 0 0 + Cairo.rectangle 0 0 (fromIntegral w) (fromIntegral h) + Cairo.fill + + renderElement element + +renderElement :: Element -> Cairo.Render () +renderElement (CollageElement _ _ forms) = mapM renderForm forms >> return () +renderElement (ImageElement _ ) = return () + +withTransform :: Double -> Double -> Double -> Double -> Cairo.Render () -> Cairo.Render () +withTransform s t x y f = Cairo.save >> Cairo.scale s s >> Cairo.rotate t >> Cairo.translate x y >> f >> Cairo.restore + +setLineCap :: LineCap -> Cairo.Render () +setLineCap cap = + case cap of + Flat -> Cairo.setLineCap Cairo.LineCapButt + Round -> Cairo.setLineCap Cairo.LineCapRound + Padded -> Cairo.setLineCap Cairo.LineCapSquare + +setLineJoin :: LineJoin -> Cairo.Render () +setLineJoin join = + case join of + Smooth -> Cairo.setLineJoin Cairo.LineJoinRound + Sharp lim -> Cairo.setLineJoin Cairo.LineJoinMiter >> Cairo.setMiterLimit lim + Clipped -> Cairo.setLineJoin Cairo.LineJoinBevel + +setLineStyle :: LineStyle -> Cairo.Render () +setLineStyle (LineStyle { color = Color r g b a, .. }) = + Cairo.setSourceRGBA r g b a >> setLineCap cap >> setLineJoin join >> + Cairo.setLineWidth width >> Cairo.setDash dashing dashOffset >> Cairo.stroke + +setFillStyle :: FillStyle -> Cairo.Render () +setFillStyle (Solid (Color r g b a)) = Cairo.setSourceRGBA r g b a >> Cairo.fill + +renderForm :: Form -> Cairo.Render () +renderForm (Form { style = PathForm style p, .. }) = + withTransform scalar theta x y $ + setLineStyle style >> Cairo.moveTo hx hy >> mapM (\(x_, y_) -> Cairo.lineTo x_ y_) p >> return () + + where + (hx, hy) = head p + +renderForm (Form { style = ShapeForm style shape, .. }) = + withTransform scalar theta x y $ do + Cairo.newPath >> Cairo.moveTo hx hy >> mapM (\(x_, y_) -> Cairo.lineTo x_ y_) shape >> Cairo.closePath + + case style of + Left lineStyle -> setLineStyle lineStyle + Right fillStyle -> setFillStyle fillStyle + + where + (hx, hy) = head shape + +renderForm (Form { style = ImageForm _ _ _ _, .. }) = return () +renderForm (Form { style = ElementForm element, .. }) = withTransform scalar theta x y $ renderElement element +renderForm (Form { style = GroupForm m forms, .. }) = withTransform scalar theta x y $ Cairo.setMatrix m >> mapM renderForm forms >> return () diff --git a/FRP/Helm/Color.hs b/FRP/Helm/Color.hs new file mode 100644 index 0000000..f36129c --- /dev/null +++ b/FRP/Helm/Color.hs @@ -0,0 +1,85 @@ +module FRP.Helm.Color where + +data Color = Color { r :: !Double, g :: !Double, b :: !Double, a :: !Double } + +-- |Creates an RGB color. +rgb :: Double -> Double -> Double -> Color +rgb r g b = Color r g b 1 + +-- |Creates an RGB color, with transparency. +rgba :: Double -> Double -> Double -> Double -> Color +rgba = Color + +red :: Color +red = rgb 1 0 0 + +lime :: Color +lime = rgb 0 1 0 + +blue :: Color +blue = rgb 0 0 1 + +yellow :: Color +yellow = rgb 1 1 0 + +cyan :: Color +cyan = rgb 0 1 1 + +magenta :: Color +magenta = rgb 1 0 1 + +black :: Color +black = rgb 0 0 0 + +white :: Color +white = rgb 1 1 1 + +gray :: Color +gray = rgb 0.5 0.5 0.5 + +grey :: Color +grey = gray + +maroon :: Color +maroon = rgb 0.5 0 0 + +navy :: Color +navy = rgb 0 0 0.5 + +green :: Color +green = rgb 0 0.5 0 + +teal :: Color +teal = rgb 0 0.5 0.5 + +purple :: Color +purple = rgb 0.5 0 0.5 + +violet :: Color +violet = rgb 0.923 0.508 0.923 + +forestGreen :: Color +forestGreen = rgb 0.133 0.543 0.133 + +{- + +complement :: Color -> Color + +hsva :: Double -> Double -> Double -> Double -> Color + +hsv :: Double -> Double -> Double -> Color +-} + +{- +data Gradient = Linear (Double, Double) (Double, Double) [(Double, Color)] | + Radial (Double, Double) Double (Double, Double) Double [(Double, Color)] + + +-- |Creates a linear gradient. Takes an +linear :: (Double, Double) -> (Double, Double) -> [(Double, Color)] -> Gradient +linear = Linear + +-- |Creates a radial gradient. +radial :: (Double, Double) -> Double -> (Double, Double) -> Double -> [(Double, Color)] -> Gradient +radial = Radial +-} diff --git a/FRP/Helm/Graphics.hs b/FRP/Helm/Graphics.hs new file mode 100644 index 0000000..1deab6e --- /dev/null +++ b/FRP/Helm/Graphics.hs @@ -0,0 +1,176 @@ +module FRP.Helm.Graphics ( + Element(..), + Form(..), + FillStyle(..), + LineCap(..), + LineJoin(..), + LineStyle(..), + defaultLine, + solid, + dashed, + dotted, + FormStyle(..), + filled, + outlined, + traced, + sprite, + toForm, + group, + groupTransform, + rotate, + scale, + move, + moveX, + moveY, + collage, + Path, + path, + segment, + Shape, + polygon, + rect, + square, + oval, + circle, + ngon +) where + +import FRP.Helm.Color as Color +import Graphics.Rendering.Cairo.Matrix (Matrix, identity) + +data Element = CollageElement Int Int [Form] | + ImageElement String + +data Form = Form { + theta :: Double, + scalar :: Double, + x :: Double, + y :: Double, + style :: FormStyle +} +data FillStyle = Solid Color -- Texture String | Gradient Gradient +data LineCap = Flat | Round | Padded +data LineJoin = Smooth | Sharp Double | Clipped +data LineStyle = LineStyle { + color :: Color, + width :: Double, + cap :: LineCap, + join :: LineJoin, + dashing :: [Double], + dashOffset :: Double +} + +defaultLine :: LineStyle +defaultLine = LineStyle { + color = Color.rgb 0 0 0, + width = 1, + cap = Flat, + join = Sharp 10, + dashing = [], + dashOffset = 0 +} + +solid :: Color -> LineStyle +solid color = defaultLine { color = color } + +dashed :: Color -> LineStyle +dashed color = defaultLine { color = color, dashing = [8, 4] } + +dotted :: Color -> LineStyle +dotted color = defaultLine { color = color, dashing = [3, 3] } + +data FormStyle = PathForm LineStyle Path | + ShapeForm (Either LineStyle FillStyle) Shape | + ImageForm Int Int (Int, Int) String | + ElementForm Element | + GroupForm Matrix [Form] + +form :: FormStyle -> Form +form style = Form { theta = 0, scalar = 1, x = 0, y = 0, style = style } + +fill :: FillStyle -> Shape -> Form +fill style shape = form (ShapeForm (Right style) shape) + +filled :: Color -> Shape -> Form +filled color shape = fill (Solid color) shape + +{- +textured :: String -> Shape -> Form + +gradient :: Gradient -> + -} + +outlined :: LineStyle -> Shape -> Form +outlined style shape = form (ShapeForm (Left style) shape) + +traced :: LineStyle -> Path -> Form +traced style p = form (PathForm style p) + +sprite :: Int -> Int -> (Int, Int) -> String -> Form +sprite w h pos src = form (ImageForm w h pos src) + +toForm :: Element -> Form +toForm element = form (ElementForm element) + +group :: [Form] -> Form +group forms = form (GroupForm identity forms) + +groupTransform :: Matrix -> [Form] -> Form +groupTransform matrix forms = form (GroupForm matrix forms) + +rotate :: Double -> Form -> Form +rotate t f= f { theta = t + theta f } + +scale :: Double -> Form -> Form +scale n f = f { scalar = n + scalar f } + +move :: (Double, Double) -> Form -> Form +move (rx, ry) f = f { x = rx + x f, y = ry + y f } + +moveX :: Double -> Form -> Form +moveX x f = move (x, 0) f + +moveY :: Double -> Form -> Form +moveY y f = move (0, y) f + +collage :: Int -> Int -> [Form] -> Element +collage w h forms = CollageElement w h forms + +type Path = [(Double, Double)] + +path :: [(Double, Double)] -> Path +path points = points + +segment :: (Double, Double) -> (Double, Double) -> Path +segment p1 p2 = [p1,p2] + +type Shape = [(Double, Double)] + +polygon :: [(Double, Double)] -> Shape +polygon points = points + +rect :: Double -> Double -> Shape +rect w h = [(-hw, -hh), (-hw, hh), (hw, hh), (hw, -hh)] + where + hw = w / 2 + hh = h / 2 + +square :: Double -> Shape +square n = rect n n + +oval :: Double -> Double -> Shape +oval w h = map (\i -> (hw * cos (t * i), hh * sin (t * i))) [0 .. n - 1] + where + n = 50 + t = 2 * pi / n + hw = w / 2 + hh = h / 2 + +circle :: Double -> Shape +circle r = oval (2 * r) (2 * r) + +ngon :: Int -> Double -> Shape +ngon n r = map (\i -> (r * cos (t * i), r * sin (t * i))) [0 .. fromIntegral (n - 1)] + where + m = fromIntegral n + t = 2 * pi / m diff --git a/FRP/Helm/Internal.hs b/FRP/Helm/Internal.hs new file mode 100644 index 0000000..5109e18 --- /dev/null +++ b/FRP/Helm/Internal.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_HADDOCK hide #-} + +module FRP.Helm.Internal (keyState) where + +import Data.IORef +import System.IO.Unsafe +import qualified Data.Map as Map +import qualified Graphics.UI.SDL as SDL + +-- FIXME: This entire hacky module can be removed if a non-hacky SDL_GetKeyState can be bound. +-- I'm sorry, I really am. + +{-# NOINLINE keyState #-} +keyState :: IORef (Map.Map SDL.SDLKey Bool) +keyState = unsafePerformIO $ newIORef Map.empty diff --git a/FRP/Helm/Keyboard.hs b/FRP/Helm/Keyboard.hs new file mode 100644 index 0000000..7450e3e --- /dev/null +++ b/FRP/Helm/Keyboard.hs @@ -0,0 +1,337 @@ +module FRP.Helm.Keyboard ( + shift, + ctrl, + enter, + Key(..), + space, + arrows, + wasd +) where + +import Control.Applicative +import Data.IORef +import FRP.Elerea.Simple +import FRP.Helm.Internal (keyState) +import qualified Data.Map as Map +import qualified Graphics.UI.SDL as SDL + +data Key = BackspaceKey | + TabKey | + ClearKey | + EnterKey | + PauseKey | + EscapeKey | + SpaceKey | + ExclaimKey | + QuotedBlKey | + HashKey | + DollarKey | + AmpersandKey | + QuoteKey | + LeftParenKey | + RightParenKey | + AsteriskKey | + PlusKey | + CommaKey | + MinusKey | + PeriodKey | + SlashKey | + Num0Key | + Num1Key | + Num2Key | + Num3Key | + Num4Key | + Num5Key | + Num6Key | + Num7Key | + Num8Key | + Num9Key | + ColonKey | + SemicolonKey | + LessKey | + EqualsKey | + GreaterKey | + QuestionKey | + AtKey | + LeftBracketKey | + BackslashKey | + RightBracketKey | + CaretKey | + UnderscoreKey | + BackquoteKey | + AKey | + BKey | + CKey | + DKey | + EKey | + FKey | + GKey | + HKey | + IKey | + JKey | + LKey | + MKey | + NKey | + OKey | + PKey | + QKey | + RKey | + SKey | + TKey | + UKey | + VKey | + WKey | + XKey | + YKey | + ZKey | + DeleteKey | + Keypad0Key | + Keypad1Key | + Keypad2Key | + Keypad3Key | + Keypad4Key | + Keypad5Key | + Keypad6Key | + Keypad7Key | + Keypad8Key | + Keypad9Key | + KeypadPeriodKey | + KeypadDivideKey | + KeypadMultiplyKey | + KeypadMinusKey | + KeypadPlusKey | + KeypadEnterKey | + KeypadEqualsKey | + UpKey | + DownKey | + RightKey | + LeftKey | + InsertKey | + HomeKey | + EndKey | + PageUpKey | + PageDownKey | + F1Key | + F2Key | + F3Key | + F4Key | + F5Key | + F6Key | + F7Key | + F8Key | + F9Key | + F10Key | + F11Key | + F12Key | + F13Key | + F14Key | + F15Key | + NumLockKey | + CapsLockKey | + ScrollLockKey | + RShiftKey | + LShiftKey | + RCtrlKey | + LCtrlKey | + RAltKey | + LAltKey | + RMetaKey | + LMetaKey | + RSuperKey | + LSuperKey | + ComposeKey | + HelpKey | + PrintKey | + SysReqKey | + BreakKey | + MenuKey | + PowerKey | + EuroKey | + UndoKey + +-- |Whether either shift key is pressed. +shift :: SignalGen (Signal Bool) +shift = effectful $ (elem SDL.KeyModShift) <$> SDL.getModState + +-- |Whether either control key is pressed. +ctrl :: SignalGen (Signal Bool) +ctrl = effectful $ (elem SDL.KeyModCtrl) <$> SDL.getModState + +mapKey :: Key -> SDL.SDLKey +mapKey k = + case k of + BackspaceKey -> SDL.SDLK_BACKSPACE + TabKey -> SDL.SDLK_TAB + ClearKey -> SDL.SDLK_CLEAR + EnterKey -> SDL.SDLK_RETURN + PauseKey -> SDL.SDLK_PAUSE + EscapeKey -> SDL.SDLK_ESCAPE + SpaceKey -> SDL.SDLK_SPACE + ExclaimKey -> SDL.SDLK_EXCLAIM + QuotedBlKey -> SDL.SDLK_QUOTEDBL + HashKey -> SDL.SDLK_HASH + DollarKey -> SDL.SDLK_DOLLAR + AmpersandKey -> SDL.SDLK_AMPERSAND + QuoteKey -> SDL.SDLK_QUOTE + LeftParenKey -> SDL.SDLK_LEFTPAREN + RightParenKey -> SDL.SDLK_RIGHTPAREN + AsteriskKey -> SDL.SDLK_ASTERISK + PlusKey -> SDL.SDLK_PLUS + CommaKey -> SDL.SDLK_COMMA + MinusKey -> SDL.SDLK_MINUS + PeriodKey -> SDL.SDLK_PERIOD + SlashKey -> SDL.SDLK_SLASH + Num0Key -> SDL.SDLK_0 + Num1Key -> SDL.SDLK_1 + Num2Key -> SDL.SDLK_2 + Num3Key -> SDL.SDLK_3 + Num4Key -> SDL.SDLK_4 + Num5Key -> SDL.SDLK_5 + Num6Key -> SDL.SDLK_6 + Num7Key -> SDL.SDLK_7 + Num8Key -> SDL.SDLK_8 + Num9Key -> SDL.SDLK_9 + ColonKey -> SDL.SDLK_COLON + SemicolonKey -> SDL.SDLK_SEMICOLON + LessKey -> SDL.SDLK_LESS + EqualsKey -> SDL.SDLK_EQUALS + GreaterKey -> SDL.SDLK_GREATER + QuestionKey -> SDL.SDLK_QUESTION + AtKey -> SDL.SDLK_AT + LeftBracketKey -> SDL.SDLK_LEFTBRACKET + BackslashKey -> SDL.SDLK_BACKSLASH + RightBracketKey -> SDL.SDLK_RIGHTBRACKET + CaretKey -> SDL.SDLK_CARET + UnderscoreKey -> SDL.SDLK_UNDERSCORE + BackquoteKey -> SDL.SDLK_BACKQUOTE + AKey -> SDL.SDLK_a + BKey -> SDL.SDLK_b + CKey -> SDL.SDLK_c + DKey -> SDL.SDLK_d + EKey -> SDL.SDLK_e + FKey -> SDL.SDLK_f + GKey -> SDL.SDLK_g + HKey -> SDL.SDLK_h + IKey -> SDL.SDLK_i + JKey -> SDL.SDLK_j + LKey -> SDL.SDLK_l + MKey -> SDL.SDLK_m + NKey -> SDL.SDLK_n + OKey -> SDL.SDLK_o + PKey -> SDL.SDLK_p + QKey -> SDL.SDLK_q + RKey -> SDL.SDLK_r + SKey -> SDL.SDLK_s + TKey -> SDL.SDLK_t + UKey -> SDL.SDLK_u + VKey -> SDL.SDLK_v + WKey -> SDL.SDLK_w + XKey -> SDL.SDLK_x + YKey -> SDL.SDLK_y + ZKey -> SDL.SDLK_z + DeleteKey -> SDL.SDLK_DELETE + Keypad0Key -> SDL.SDLK_KP0 + Keypad1Key -> SDL.SDLK_KP1 + Keypad2Key -> SDL.SDLK_KP2 + Keypad3Key -> SDL.SDLK_KP3 + Keypad4Key -> SDL.SDLK_KP4 + Keypad5Key -> SDL.SDLK_KP5 + Keypad6Key -> SDL.SDLK_KP6 + Keypad7Key -> SDL.SDLK_KP7 + Keypad8Key -> SDL.SDLK_KP8 + Keypad9Key -> SDL.SDLK_KP9 + KeypadPeriodKey -> SDL.SDLK_KP_PERIOD + KeypadDivideKey -> SDL.SDLK_KP_DIVIDE + KeypadMultiplyKey -> SDL.SDLK_KP_MULTIPLY + KeypadMinusKey -> SDL.SDLK_KP_MINUS + KeypadPlusKey -> SDL.SDLK_KP_PLUS + KeypadEnterKey -> SDL.SDLK_KP_ENTER + KeypadEqualsKey -> SDL.SDLK_KP_EQUALS + UpKey -> SDL.SDLK_UP + DownKey -> SDL.SDLK_DOWN + RightKey -> SDL.SDLK_RIGHT + LeftKey -> SDL.SDLK_LEFT + InsertKey -> SDL.SDLK_INSERT + HomeKey -> SDL.SDLK_HOME + EndKey -> SDL.SDLK_END + PageUpKey -> SDL.SDLK_PAGEUP + PageDownKey -> SDL.SDLK_PAGEDOWN + F1Key -> SDL.SDLK_F1 + F2Key -> SDL.SDLK_F2 + F3Key -> SDL.SDLK_F3 + F4Key -> SDL.SDLK_F4 + F5Key -> SDL.SDLK_F5 + F6Key -> SDL.SDLK_F6 + F7Key -> SDL.SDLK_F7 + F8Key -> SDL.SDLK_F8 + F9Key -> SDL.SDLK_F9 + F10Key -> SDL.SDLK_F10 + F11Key -> SDL.SDLK_F11 + F12Key -> SDL.SDLK_F12 + F13Key -> SDL.SDLK_F13 + F14Key -> SDL.SDLK_F14 + F15Key -> SDL.SDLK_F15 + NumLockKey -> SDL.SDLK_NUMLOCK + CapsLockKey -> SDL.SDLK_CAPSLOCK + ScrollLockKey -> SDL.SDLK_SCROLLOCK + RShiftKey -> SDL.SDLK_RSHIFT + LShiftKey -> SDL.SDLK_LSHIFT + RCtrlKey -> SDL.SDLK_RCTRL + LCtrlKey -> SDL.SDLK_LCTRL + RAltKey -> SDL.SDLK_RALT + LAltKey -> SDL.SDLK_LALT + RMetaKey -> SDL.SDLK_RMETA + LMetaKey -> SDL.SDLK_LMETA + RSuperKey -> SDL.SDLK_RSUPER + LSuperKey -> SDL.SDLK_LSUPER + ComposeKey -> SDL.SDLK_COMPOSE + HelpKey -> SDL.SDLK_HELP + PrintKey -> SDL.SDLK_PRINT + SysReqKey -> SDL.SDLK_SYSREQ + BreakKey -> SDL.SDLK_BREAK + MenuKey -> SDL.SDLK_MENU + PowerKey -> SDL.SDLK_POWER + EuroKey -> SDL.SDLK_EURO + UndoKey -> SDL.SDLK_UNDO + +-- |Whether a specific key is pressed. +isDown :: Key -> SignalGen (Signal Bool) +isDown k = effectful $ (Map.findWithDefault False (mapKey k)) <$> readIORef keyState + +-- |Whether the shift key is pressed. +enter :: SignalGen (Signal Bool) +enter = isDown EnterKey + +-- |Whether the space key is pressed. +space :: SignalGen (Signal Bool) +space = isDown SpaceKey + +{- +keysDown :: SignalGen (Signal [Key]) +-} + +{-| A unit vector combined from the arrow keys. When no keys are being pressed + this signal samples to (0, 0), otherwise it samples to a specific direction + based on which keys are pressed. For example, pressing the left key results + in (-1, 0), the down key (0, 1), etc. -} +arrows :: SignalGen (Signal (Int, Int)) +arrows = do + up <- isDown UpKey + left <- isDown LeftKey + down <- isDown DownKey + right <- isDown RightKey + + return $ arrows' <$> up <*> left <*> down <*> right + +arrows' :: Bool -> Bool -> Bool -> Bool -> (Int, Int) +arrows' u l d r = (-1 * fromEnum l + 1 * fromEnum r, -1 * fromEnum u + 1 * fromEnum d) + +-- |Similar to the 'arrows' signal, but uses the W, A, S and D keys instead. +wasd :: SignalGen (Signal (Int, Int)) +wasd = do + w <- isDown WKey + a <- isDown AKey + s <- isDown SKey + d <- isDown DKey + + return $ arrows' <$> w <*> a <*> s <*> d diff --git a/FRP/Helm/Mouse.hs b/FRP/Helm/Mouse.hs new file mode 100644 index 0000000..b6e5458 --- /dev/null +++ b/FRP/Helm/Mouse.hs @@ -0,0 +1,34 @@ +module FRP.Helm.Mouse (position, x, y, isDown, Mouse(..)) where + +import Control.Applicative +import FRP.Elerea.Simple +import qualified Graphics.UI.SDL as SDL + +data Mouse = LeftMouse | MiddleMouse | RightMouse + +-- |The current mouse position. +position :: SignalGen (Signal (Int, Int)) +position = effectful $ (\(x_, y_, _) -> (x_, y_)) <$> SDL.getMouseState + +-- |The current x-coordinate of the mouse. +x :: SignalGen (Signal Int) +x = effectful $ (\(x_, _, _) -> x_) <$> SDL.getMouseState + +-- |The current y-coordinate of the mouse. +y :: SignalGen (Signal Int) +y = effectful $ (\(_, y_, _) -> y_) <$> SDL.getMouseState + +mapMouse m = + case m of + LeftMouse -> SDL.ButtonLeft + MiddleMouse -> SDL.ButtonMiddle + RightMouse -> SDL.ButtonRight + +{-| The current state of a certain mouse button. + True if the mouse is down, false otherwise. -} +isDown :: Mouse -> SignalGen (Signal Bool) +isDown m = effectful $ (\(_, _, b_) -> elem (mapMouse m) b_) <$> SDL.getMouseState + +{- +isClicked :: SignalGen (Signal Bool) + -} diff --git a/FRP/Helm/Window.hs b/FRP/Helm/Window.hs new file mode 100644 index 0000000..8a1ed22 --- /dev/null +++ b/FRP/Helm/Window.hs @@ -0,0 +1,17 @@ +module FRP.Helm.Window (dimensions, width, height) where + +import Control.Applicative +import FRP.Elerea.Simple +import qualified Graphics.UI.SDL as SDL + +-- |The current dimensions of the window. +dimensions :: SignalGen (Signal (Int, Int)) +dimensions = effectful $ (\s -> (SDL.surfaceGetWidth s, SDL.surfaceGetHeight s)) <$> SDL.getVideoSurface + +-- |The current width of the window. +width :: SignalGen (Signal Int) +width = effectful $ SDL.surfaceGetWidth <$> SDL.getVideoSurface + +-- |The current height of the window. +height :: SignalGen (Signal Int) +height = effectful $ SDL.surfaceGetHeight <$> SDL.getVideoSurface diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..055251e --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (C) 2013, Zack Corr + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to +deal in the Software without restriction, including without limitation the +rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN +NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, +DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR +OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR +THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..e8ef27d --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/helm.cabal b/helm.cabal new file mode 100644 index 0000000..7ab7159 --- /dev/null +++ b/helm.cabal @@ -0,0 +1,52 @@ +name: helm +version: 0.1 +synopsis: A functionally reactive game engine. +description: Helm is a functionally reactive game engine inspired by the Elm programming language. + Protective head gear for preventing headaches from game development provided! +homepage: http://github.com/z0w0/helm +bug-reports: http://github.com/z0w0/helm/issues +license: MIT +license-file: LICENSE +tested-with: GHC == 7.6.3 +extra-source-files: LICENSE, README.md +author: Zack Corr +maintainer: Zack Corr +copyright: (c) 2013, Zack Corr +category: Game Engine +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/z0w0/helm.git + +executable helm-demo + main-is: Demo.hs + build-depends: + base >= 4 && < 5, + helm >= 0.1 && < 1, + SDL >= 0.6.4 && < 1, + cairo >= 0.12.4 && < 1, + elerea >= 2.7.0 && < 3, + containers >= 0.5.0.0 && < 1 + default-language: Haskell2010 + default-extensions: RecordWildCards, NamedFieldPuns + ghc-options: -Wall + +library + exposed-modules: + FRP.Helm + FRP.Helm.Color + FRP.Helm.Graphics + FRP.Helm.Keyboard + FRP.Helm.Mouse + FRP.Helm.Window + build-depends: + base >= 4 && < 5, + SDL >= 0.6.4 && < 1, + cairo >= 0.12.4 && < 1, + elerea >= 2.7.0 && < 3, + containers >= 0.5.0.0 && < 1 + default-language: Haskell2010 + default-extensions: RecordWildCards, NamedFieldPuns + ghc-options: -Wall