diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011 Michael Sloan. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/gtk-toy.cabal b/gtk-toy.cabal new file mode 100644 --- /dev/null +++ b/gtk-toy.cabal @@ -0,0 +1,27 @@ +Name: gtk-toy +Version: 0.1.0 +Cabal-Version: >= 1.6 +Synopsis: Convenient Gtk canvas with mouse and keyboard input. +Category: Graphics, GUI +Description: + The Gtk Toy Framework is a simplifying interface over Gtk for creating + applications which draw things and interact with the mouse and keyboard. It + handles the minutae of setting up the Gtk window and canvas, and processes + the input events into more palatable data structures. +License: BSD3 +License-file: LICENSE +Author: Michael Sloan +Maintainer: Michael Sloan +Stability: experimental +Build-Type: Simple +Source-repository head + type: git + location: git://github.com/mgsloan/gtk-toy.git + +Library + Extensions: TupleSections, ViewPatterns + Build-Depends: base >= 4.2 && < 4.6, + gtk >= 0.12.0 && < 0.13.0, + containers + Hs-source-dirs: src + Exposed-Modules: Graphics.UI.Gtk.Toy diff --git a/src/Graphics/UI/Gtk/Toy.hs b/src/Graphics/UI/Gtk/Toy.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Gtk/Toy.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE TupleSections, ViewPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.UI.Gtk.Toy +-- Copyright : (c) 2011 Michael Sloan +-- License : BSD-style (see the LICENSE file) +-- Maintainer : Michael Sloan +-- Stability : experimental +-- Portability : GHC only +-- +-- The Gtk Toy Framework is an interface over Gtk for creating applications +-- which draw things and use the mouse or keyboard. +-- +-- It handles the minutiae of setting up the Gtk window and canvas, and +-- processes mouse and keyboard inputs into more palatable data structures. +----------------------------------------------------------------------------- +module Graphics.UI.Gtk.Toy + ( + KeyInfo, KeyTable, InputState(..), Interactive(..) + , runToy, quitToy + + -- * InputState Accessors + , keyInfo, keyHeld, mouseHeld + + -- * Utilities + -- | Functions to allow for writing simpler, pure implementations of the + -- different members of Interactive. + , simpleTick, simpleDisplay, simpleMouse, simpleKeyboard + , quitKeyboard + + ) where + +import Control.Monad (when) +import Data.IORef +import qualified Data.Map as M +import qualified Graphics.UI.Gtk as G +import qualified Graphics.UI.Gtk.Gdk.Events as E + +-- | Information about the most recent key-state transition. +-- The tuple contains whether the button was pressed, @True@, or released, @False, +-- at what time in msec, with which GTK modifiers. +type KeyInfo = (Bool, Int, [G.Modifier]) + +-- | A map of GTK keynames to last-received event regarding each respective +-- key. This can be interpreted as the current keyboard state - a key is +-- down if it was last seen being pressed. +type KeyTable = M.Map String KeyInfo + +data InputState = InputState + { mousePos :: (Double, Double) -- ^ The most recent mouse position + , keyTable :: KeyTable -- ^ Map from key-name to most recent event + } + +-- | A KeyEvent tuple specifies whether the key was pressed or not, and +-- which key was pressed. @(Right Char)@ is yielded for keys which would +-- normally correspond to character insertions, while @(Left String) provides +-- GTK-convention names for the rest. +type KeyEvent = (Bool, Either String Char) + +-- | A MouseEvent is @Nothing@ if it's a mouse motion event, and otherwise +-- provides mouse press information. +type MouseEvent = Maybe (Bool, Int) + +-- | A class for things which can be drawn and change within an interactive +-- context. The default method implementations do nothing. +class Interactive a where + + -- | @tick@ is (ideally) called every 30ms. The bool result indicates if the + -- graphics need to be refreshed. + tick :: InputState -> a -> IO (a, Bool) + + -- | @display@ is called when the rendering needs to be refreshed. + display :: G.DrawWindow -> InputState -> a -> IO a + + -- | @mouse@ is called when the mouse moves or presses occur. + mouse :: MouseEvent -> InputState -> a -> IO a + + -- | @keyboard@ is called on key-presses. + keyboard :: KeyEvent -> InputState -> a -> IO a + + -- No-op defaults. + tick _ = return . (, False) + display _ _ = return + mouse _ _ = return + keyboard _ _ = return + +-- InputState Queries. + +-- | Gets the information for the most recent key event of the named key. +keyInfo :: String -> InputState -> Maybe KeyInfo +keyInfo name = M.lookup name . keyTable + +-- | Gets whether the named key is currently thought to be held down. +keyHeld :: String -> InputState -> Bool +keyHeld name (keyInfo name -> Just (True, _, _)) = True +keyHeld _ _ = False + +-- | Postfixes "_L" and "_R" on the key name, and returns true if either of +-- those keys are being held. +eitherHeld :: String -> InputState -> Bool +eitherHeld key inp = (keyHeld (key ++ "_L") inp || keyHeld (key ++ "_R") inp) + +-- | Yields whether the mouse button (1st parameter) is considered pressed +-- in the passed InputState. +mouseHeld :: Int -> InputState -> Bool +mouseHeld ix = keyHeld ("Mouse" ++ show ix) + +-- | Converts a pure state transform to a function for Interactive 'tick'. +simpleTick :: (a -> a) + -> InputState -> a -> IO (a, Bool) +simpleTick f _ = return . (, True) . f + +-- | Converts a diagram projection to a function for Interactive 'display'. +simpleDisplay :: (G.DrawWindow -> a -> a) + -> G.DrawWindow -> InputState -> a -> IO a +simpleDisplay f dw _ = return . f dw + +-- | Converts a function which responds to mouse-presses, and transforms state +-- accordingly to a function for Interactive 'mouse'. +simpleMouse :: (MouseEvent -> (Double, Double) -> a -> a) + -> (MouseEvent -> InputState -> a -> IO a) +simpleMouse f c inp = return . f c (mousePos inp) + +-- | Converts a function which responds to mouse-presses, and transforms state +-- accordingly to a function for Interactive 'mouse'. +simpleMouseClick :: ((Bool, Int) -> (Double, Double) -> a -> a) + -> (MouseEvent -> InputState -> a -> IO a) +simpleMouseClick f (Just c) inp = return . f c (mousePos inp) +simpleMouseClick _ _ _ = return + +simpleMousePos :: ((Double, Double) -> a -> a) + -> (MouseEvent -> InputState -> a -> IO a) +simpleMousePos f _ inp = return . f (mousePos inp) + +-- | Converts a function which responds to key-presses, and transforms state +-- accordingly to a function for Interactive 'keyboard'. +simpleKeyboard :: (KeyEvent -> a -> a) + -> (KeyEvent -> InputState -> a -> IO a) +simpleKeyboard f e _ = return . f e + +-- | A definition for the keyboard handler that just calls "quitToy" when +-- Escape is pressed. +quitKeyboard :: KeyEvent -> InputState -> a -> IO a +quitKeyboard (True, (Left "Escape")) _ x = quitToy >> return x +quitKeyboard _ _ x = return x + +-- | Like it says on the can. This is a synonym for 'Graphics.UI.Gtk.mainQuit' +quitToy :: IO () +quitToy = G.mainQuit + +-- | Main program entrypoint. This is how you turn an instance of Interactive +-- into an application. +runToy :: Interactive a => a -> IO () +runToy toy = do + G.initGUI + + window <- G.windowNew + canvas <- G.drawingAreaNew + state <- newIORef (InputState (0, 0) M.empty, toy) + + let doRedraw = G.widgetQueueDraw canvas >> return True + G.windowSetDefaultSize window 640 480 + + G.onKeyPress window $ (>> doRedraw) . handleKey state + G.onKeyRelease window $ (>> doRedraw) . handleKey state + + G.onMotionNotify window True $ (>> doRedraw) . handleMotion state + G.onButtonPress window $ (>> doRedraw) . handleButton state + G.onButtonRelease window $ (>> doRedraw) . handleButton state + + G.onExposeRect canvas $ \(G.Rectangle x y w h) -> do + let r = ((x, y), (x + w, y + h)) + dw <- G.widgetGetDrawWindow canvas + sz <- G.widgetGetSize canvas + (inp, x) <- readIORef state + x' <- display dw inp x + writeIORef state (inp, x') + + G.set window $ [G.containerChild G.:= canvas] + G.widgetShowAll window + + let tickHandler = do + st@(inp, _) <- readIORef state + (state', redraw) <- uncurry tick st + when redraw (doRedraw >> return ()) + writeIORef state (inp, state') + return True + + G.timeoutAddFull tickHandler G.priorityDefaultIdle 30 + + G.mainGUI + where + +handleKey :: Interactive a => IORef (InputState, a) -> E.Event -> IO () +handleKey st ev = do + (InputState p m, x) <- readIORef st + let inp' = InputState p (M.insert name (pres, time, mods) m) + x' <- keyboard (pres, maybe (Left name) Right char) inp' x + writeIORef st (inp', x') + where + name = E.eventKeyName ev + char = E.eventKeyChar ev + time = fromIntegral $ E.eventTime ev + mods = E.eventModifier ev + pres = not $ E.eventRelease ev + +handleMotion :: Interactive a => IORef (InputState, a) -> E.Event -> IO () +handleMotion st ev = do + (InputState p m, x) <- readIORef st + let inp' = InputState pos m + x' <- mouse Nothing inp' x + writeIORef st (inp', x') + where + pos = (E.eventX ev, E.eventY ev) + +handleButton :: Interactive a => IORef (InputState, a) -> E.Event -> IO () +handleButton st ev = do + when (click == E.SingleClick || click == E.ReleaseClick) $ do + (InputState p m, x) <- readIORef st + let m' = M.insert ("Mouse" ++ show but) (pressed, time, mods) m + inp' = InputState pos m' + x' <- mouse (Just (pressed, but)) inp' x + writeIORef st (inp', x') + where + pos = (E.eventX ev, E.eventY ev) + time = fromIntegral $ E.eventTime ev + mods = E.eventModifier ev + click = E.eventClick ev + pressed = click /= E.ReleaseClick + but = case E.eventButton ev of + E.LeftButton -> 0 + E.RightButton -> 1 + E.MiddleButton -> 2 +--TODO: guaranteed to not be 0,1,2? + E.OtherButton ix -> ix