mirror of
https://github.com/z0w0/helm.git
synced 2024-08-15 07:11:05 +03:00
Initial commit
This commit is contained in:
commit
37f8f51094
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
@ -0,0 +1 @@
|
|||||||
|
dist
|
21
Demo.hs
Normal file
21
Demo.hs
Normal file
@ -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
|
147
FRP/Helm.hs
Normal file
147
FRP/Helm.hs
Normal file
@ -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 ()
|
85
FRP/Helm/Color.hs
Normal file
85
FRP/Helm/Color.hs
Normal file
@ -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
|
||||||
|
-}
|
176
FRP/Helm/Graphics.hs
Normal file
176
FRP/Helm/Graphics.hs
Normal file
@ -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
|
15
FRP/Helm/Internal.hs
Normal file
15
FRP/Helm/Internal.hs
Normal file
@ -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
|
337
FRP/Helm/Keyboard.hs
Normal file
337
FRP/Helm/Keyboard.hs
Normal file
@ -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
|
34
FRP/Helm/Mouse.hs
Normal file
34
FRP/Helm/Mouse.hs
Normal file
@ -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)
|
||||||
|
-}
|
17
FRP/Helm/Window.hs
Normal file
17
FRP/Helm/Window.hs
Normal file
@ -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
|
19
LICENSE
Normal file
19
LICENSE
Normal file
@ -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.
|
52
helm.cabal
Normal file
52
helm.cabal
Normal file
@ -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 <zack@z0w0.me>
|
||||||
|
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
|
Loading…
Reference in New Issue
Block a user