main :: IO()
main = runCurses $ do
setEcho False
w <- defaultWindow
canvas <- newWindow 19 19 0 0
panel <- newPanel canvas
updateWindow canvas $ do
drawString "Hello world!"
render
waitFor w (\ev -> ev == EventCharacter 'q' || ev == EventCharacter 'Q')
waitFor :: Window -> (Event -> Bool) -> Curses ()
waitFor w p = loop where
loop = do
ev <- getEvent w Nothing
case ev of
Nothing -> loop
Just ev' -> unless (p ev') loop
Hello. It is a bit modified example of ncurses package.
Problem is that is do not display anything. In C API, as I remember, I have to refresh each window independently. But Haskell offer only render. Where I am wrong? I want to have some moveable widget.
You have just to call refreshPanels.
Related
I'm currently trying to create a snake-like game in haskell using hscurses in the terminal, and I'm having a bit of trouble implementing the input-functionality of the game. My problem is that whenever I hold down one of the movement keys, for example 'a', the character moves to the left for as many characters that were registered by the console. This leads to when I want to switch directions, for example down by pressing 's', the character keeps on moving to the left and the down-movement gets delayed.
res :: Int -> IO a -> IO (Maybe a)
res n f = concurrently (System.Timeout.timeout n f) (threadDelay n) >>= \(result, _) -> return
result
getInput :: IO Char
getInput = hSetEcho stdin False
>> hSetBuffering stdin NoBuffering
>> getChar
and the part of the main game-loop function that handles the input:
loop :: Window -> State -> Player -> IO State
loop window state player = do
threadDelay 1000000
k <- res 100 getInput
newState <- updateState player state
newPlayer <- movePlayer player k
render newState newPlayer window
and the movePlayer function:
movePlayer :: Player -> Maybe Char -> IO Player
movePlayer Player {xy=xy1, direction = d} k =
case k of
Just 'w' -> return Player {xy = (fst xy1, snd xy1-1), direction = Up}
Just 's' -> return Player {xy = (fst xy1, snd xy1+1), direction = Downie}
Just 'd' -> return Player {xy = (fst xy1+1, snd xy1), direction = Rightie}
Just 'a' -> return Player {xy = (fst xy1-1, snd xy1), direction = Leftie}
Nothing -> return Player {xy = addVecs xy1 (dirToVec d), direction = d}
_ -> return Player {xy = xy1, direction = d}
I can't figure out what the problem is, so any help is appreciated or if there's another method of implementing this input-functionality
Currently your input loop and your state update loop are tied together: there's always at most one input accepted per update. You will need to desynch them.
The low-tech alternative is to change the spot you currently have res 100 getInput to actually run getInput in a loop, and only keep the last Char it receives before blocking. The medium-tech alternative is to have two threads, one for reading input and one for doing state updates, with a shared MVar or similar saying what key was pressed last. The high-tech alternative is to use a library like brick to handle all of your input and output.
I'm trying to make a Timer in Haskell using gtk2hs.
I found an example on this website wiki.haskell Tutorial Threaded GUI
which I could successfully implement in my project. The only problem I'm facing is creating a restart button for the timer.
My goal is that when people pres the "New game" button, that a new game starts and that the timer resets.
If a want to just restart a game I can use this line of code
onClicked button1 (startNewGame table window)
, which works. The problem is I can't find a way to bind a the start timer function to a button.
I tried doing this:
onClicked button1 (do (startTimer box) (startNewGame table window))
Which does not work, also this does not work:
onClicked button1 (startTimer box)
How am I suppose to restart a thread correctly?
When I run this code:
onClicked button1 (startTimer box)
I get this error:
gui.hs:29:25:
Couldn't match type `ThreadId' with `()'
Expected type: IO ()
Actual type: IO ThreadId
In the return type of a call of `startTimer'
In the second argument of `onClicked', namely `(startTimer box)'
In a stmt of a 'do' block: onClicked button1 (startTimer box)
How can I bind the (startTimer box) function to a button?
Source code:
import Graphics.UI.Gtk
import SetTest
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Control.Monad.Trans(liftIO)
import Debug.Trace
import Control.Concurrent
import Control.Concurrent.MVar
import System.Exit
main :: IO ()
main = do
initGUI
window <- windowNew
set window [windowTitle := "Minesweeper",
windowDefaultWidth := 450, windowDefaultHeight := 200]
box <- vBoxNew False 0
containerAdd window box
button1 <- buttonNewWithLabel "New game"
boxPackStart box button1 PackGrow 0
widgetShowAll window
table <- tableNew 5 5 True
--onClicked button1 (do (startTimer box) (startNewGame table window))
--onClicked button1 (startTimer box)
onClicked button1 (startNewGame table window)
startTimer box
containerAdd window table
startNewGame table window
boxPackStart box table PackNatural 0
widgetShowAll window
onDestroy window mainQuit
mainGUI
startTimer :: BoxClass self => self -> IO ThreadId
startTimer box = do
timeLabel <- labelNew Nothing
boxPackStart box timeLabel PackNatural 0
forkIO $ do
let
printTime t = do{
threadDelay 1000000;
postGUIAsync $ labelSetText timeLabel (show t);
printTime (t+1)}
printTime 0
startNewGame:: (WidgetClass self, TableClass self1) => self1 -> self -> IO ()
startNewGame table window = let board = (SetTest.initialize 5 (5,5) (1,1)) :: MyBoard
in checkStatusGame table board window
:: (WidgetClass self, TableClass self1) =>
self1 -> MyBoard -> self -> IO ()
checkStatusGame table board window
| won board = do
cleanAndGenerateTable board table window True
(dialogMessage "hurray hurray hurray" "Gratz, you won!!!")
| lost board = do
(dialogMessage "Baby rage window" "Soz, you lost...")
cleanAndGenerateTable board table window True
| otherwise = (cleanAndGenerateTable board table window False)
cleanAndGenerateTable :: (WidgetClass self, TableClass self1) =>
MyBoard -> self1 -> self -> Bool -> IO ()
cleanAndGenerateTable board table window finished = do
let fieldList = [(x,y) | x <- [0 .. (height board)] , y <- [0 .. (width board)] ]
children <- containerGetChildren table
mapM_ (\child -> containerRemove table child >> widgetDestroy child) children
if finished
then mapM_(generateTableFinished board table window) fieldList
else mapM_ (generateTable board table window) fieldList
widgetShowAll window
generateTable board table window (x,y)
| Set.member (x,y) (flaggedCells board) = createButton "flag.jpg" (x,y) table board window
| Map.member (x,y) (clickedCells board) = createClickedButton (show (Map.findWithDefault (-1) (x,y) (clickedCells board))) (x,y) table
| otherwise = createButton "masked.png" (x,y) table board window
generateTableFinished board table window (x,y)
| Set.member (x,y) (bombs board) = createButtonNoAction "bomb.jpg" (x,y) table board window
| Map.member (x,y) (clickedCells board) = createClickedButton (show (Map.findWithDefault (-1) (x,y) (clickedCells board))) (x,y) table
| otherwise = createClickedButton (show (Map.findWithDefault (-1) (x,y) (maskedCells board))) (x,y) table
createButtonNoAction pth (x,y) table board window = do
button <- buttonNew
box <- hBoxNew False 0
image <- imageNewFromFile pth
boxPackStart box image PackRepel 0
containerAdd button box
tableAttachDefaults table button x (x+1) y (y+1)
createClickedButton lbl (x,y) table = do
button <- buttonNew
box <- hBoxNew False 0
label <- labelNew (Just lbl)
boxPackStart box label PackRepel 0
containerAdd button box
tableAttachDefaults table button x (x+1) y (y+1)
createButton pth (x,y) table board window = do
button <- buttonNew
box <- hBoxNew False 0
image <- imageNewFromFile pth
boxPackStart box image PackRepel 0
containerAdd button box
tableAttachDefaults table button x (x+1) y (y+1)
on button buttonReleaseEvent $ do
click <- eventButton
liftIO $ case click of { LeftButton -> (checkStatusGame table (SetTest.click (x,y) board) window); RightButton -> (checkStatusGame table (SetTest.flag (x,y) board) window) }
return False
return ()
dialogMessage title msg = do dialog <- messageDialogNew Nothing [] MessageOther ButtonsOk msg
set dialog [windowTitle := title]
widgetShowAll dialog
dialogRun dialog
widgetDestroy dialog
If you want to communicate with your timer thread, you will need to hand it a communication channel. An MVar seems appropriate here.
startTimer :: BoxClass self => self -> MVar Integer -> IO ThreadId
startTimer box timer = do
timeLabel <- labelNew Nothing
boxPackStart box timeLabel PackNatural 0
forkIO . forever $ do
threadDelay 1000000
t <- takeMVar timer
putMVar timer (t+1)
postGUIAsync $ labelSetText timeLabel (show t)
At the top of main, you can now create a fresh MVar with timer <- newMVar 0, and pass this to startTimer. In your button callback, you can takeMVar timer >> putMVar timer 0 to reset the timer.
I'm experimenting with threepenny-gui, trying to learn the FRP interface. I want to avoid all explicit shared state using accumE/accumB, instead of IORef:s. I have four different signals (start, stop, timer, reset) which all affect a global state and the user interface. I'm using accumE w $ concatenate <$> unions [e0, e1, e2, e3] to make the events share the same state w. Here is a short snippet which captures the essence of it (with only one signal):
data World = World { intW :: Int , runW :: UI () }
main :: IO ()
main = startGUI defaultConfig setup
setup :: Window -> UI ()
setup _ = do
(e0, fire) <- liftIO UI.newEvent
let e0' = action <$ e0
e <- accumE (World 0 (return ())) e0'
onEvent e $ \w -> void $ runW w
replicateM_ 5 . liftIO $ fire ()
where
action :: World -> World
action w = w { intW = succ $ intW w
, runW = liftIO . print $ intW w }
This seems to work fine (although I wonder if it is sane). However, if I instead change the event to have type Event (UI World -> UI World) (and remove the runW field), things go haywire:
data World = World { intW :: Int } deriving (Show)
main :: IO ()
main = startGUI defaultConfig setup
setup :: Window -> UI ()
setup _ = do
(e0, fire) <- liftIO UI.newEvent
let e0' = action <$ e0
e <- accumE (return (World 0)) e0'
onEvent e void
replicateM_ 5 . liftIO $ fire ()
where
action :: UI World -> UI World
action world = do
w <- world
let w' = w { intW = succ $ intW w }
liftIO $ print w'
return w'
It seems that all UI actions somehow get accumulated, and executed an increasing number of times with each event! I thought accumE was like a fold, where the accumulating state is replaced unless explicitly accumulated. What is the proper/best way of dealing with this problem in general?
WxHaskell and DragAndDrop
I would like to know how to use the following events handlers
: dropTargetOnData, dropTargetOnDrop, dropTargetOnEnter, dropTargetOnDragOver….[1]
Could you check if my current believes are corrects :
From wx Widgets/ wxPython [2] / [3] / [4] it looks like they need to be used to manage DragAndDrog for non trivial examples.
they are not actionable via an existing event like "on drag", etc..
I tried and create my own event. but it does not get "activated". [7]
besides, from the signatures [1], these look like being activated on DropTarget, unlike other events on Reactive/ Windows/Controls . Is It Correct ?
Heinrich created its own events "onText", (in reactive-Banana) but this is on a Control. [6]
Could someone confirm these events effectively worked for them in WxHaskell, and maybe hint how to do that
[1]:
from Graphics.UI.WXCore.Events , line 1933 onwards
Set an event handler that is called when the drop target can be filled with data.
This function require to use 'dropTargetGetData' in your event handler to fill data.
dropTargetOnData :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
...
-- | Set an event handler for an drop command in a drop target.
dropTargetOnDrop :: DropTarget a -> (Point -> IO Bool) -> IO ()
-- | Set an event handler for an enter command in a drop target.
dropTargetOnEnter :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
-- | Set an event handler for a drag over command in a drop target.
dropTargetOnDragOver :: DropTarget a -> (Point -> DragResult -> IO DragResult) -> IO ()
-- | Set an event handler for a leave command in a drop target.
dropTargetOnLeave :: DropTarget a -> (IO ()) -> IO ()
[2] : http://docs.wxwidgets.org/2.8/wx_wxdroptarget.html#wxdroptargetondrop
[3] : http://wiki.wxpython.org/DragAndDrop
[4] : http://www.blog.pythonlibrary.org/2012/06/20/wxpython-introduction-to-drag-and-drop/
[5] : http://wewantarock.wordpress.com/2011/06/17/how-does-wxhaskell-event-handling-work-part-1/
[6] : https://github.com/HeinrichApfelmus/reactive-banana/blob/master/reactive-banana-wx/src/Reactive/Banana/WX.hs L 88
[7] :
module Main where
import Graphics.UI.WX hiding (empty)
import Data.Maybe
import Control.Monad
import Graphics.UI.WX.Events
import Graphics.UI.WXCore.WxcClassesMZ
--import Graphics.UI.WXCore.WxcClassesAL
import Graphics.UI.WXCore.DragAndDrop
import Graphics.UI.WXCore.Events
main
= start dndtest
dndtest
= do
f <- frame [text := "Drag And Drop test"]
p <- panel f []
ok <- button p [text := "Ok"]
xinput <- textEntry p [text := "here :"] --textEntry
yinput <- staticText p [text := "drag me"]
zinput <- staticText p [text := "result me"]
set f [defaultButton := ok
,layout := container p $
margin 10 $
column 5 [boxed "coordinates" (grid 5 5 [[label "source:", hfill $ widget yinput]
,[label "target(focus first):", hfill $ widget xinput]
,[label "result:", hfill $ widget zinput]
])
,floatBottomRight $ row 5 [widget ok]]
]
set xinput [ on enter := onEnter]
set yinput [ ]
---------------------------------------------------------
--- meaningful stuff starts here
---------------------------------------------------------
-- prepare the drop source : create a DataObject and associate it with the source
textdata' <- textDataObjectCreate "text dropped"
src <- dropSource textdata' yinput
-- prepare the drop target: create a DataObject (placeholder here) and associate it with the target
textdata <- textDataObjectCreate ".."
drop <- dropTarget xinput textdata
set drop [ on onMyDrop := showMeDrop ] ---- <<<< I am expecting this to get fired but no ...
-- obj create a new event on drop invoking ..
-- and see if it is invoked
set yinput [ on drag := onDrag src ]
set xinput [ ] ------ <<<< I am expecting the target to react when dropped (Its DroopedTarget i fact)
set zinput [ on mouse := showMeE]
set ok [ on command := close f ]
return ()
--- this is the custom event, just a setter to fire dropTargetOnDrop. not sure at all this is the correct way.
onMyDrop = newEvent "onmyDrop" (\w -> ioError (userError ("attribute '" ++ "onmyDrop" ++ "' is write-only."))) dropTargetOnDrop
--dropTargetOnDrop :: DropTarget a -> (Point -> IO Bool) -> IO ()
--- the rest are jsut helper to see whats going on
showMeEo = putStr "showMeEo"
showMeDrop p = do
putStr "showMeDrop"
return True
onDrag s p = do
-- dragAndDrop :: DropSource a -> DragMode -> (DragResult -> IO ()) -> IO ()
dragAndDrop s Default (\r -> do {putStr "DnD handler called: "; putStrLn(show r); return ()})
putStrLn "on Drag activated:"
showMeE :: EventMouse -> IO ()
showMeE (MouseMotion point mod) = putStr "" --- discard meaningless Motion event
showMeE e = putStrLn $ show e
--
onEnter p = putStrLn $ "on Enter:" ++ show p
I am testing out the simple pong game found here: https://github.com/shangaslammi/frp-pong
The problem is that the keyboard controls work very badly - the keys are very unresponsive and often have a delay of a few seconds. I assume that the author wrote the code for Windows because he included a .bat file and so this is a Linux-specific problem.
Why is this happening?
I am unsure of where the problem would be, but here is the file Keyboard.hs:
import Data.Set (Set)
import qualified Data.Set as Set
import Graphics.UI.GLUT (Key(..), KeyState(..))
-- | Set of all keys that are currently held down
newtype Keyboard = Keyboard (Set Key)
-- | Create a new Keyboard
initKeyboard :: Keyboard
initKeyboard = Keyboard Set.empty
-- | Record a key state change in the given Keyboard
handleKeyEvent :: Key -> KeyState -> Keyboard -> Keyboard
handleKeyEvent k Down = addKey k
handleKeyEvent k Up = removeKey k
addKey :: Key -> Keyboard -> Keyboard
addKey k (Keyboard s) = Keyboard $ Set.insert k s
removeKey :: Key -> Keyboard -> Keyboard
removeKey k (Keyboard s) = Keyboard $ Set.delete k s
-- | Test if a key is currently held down in the given Keyboard
isKeyDown :: Keyboard -> Key -> Bool
isKeyDown (Keyboard s) k = Set.member k s
And setting the callbacks:
type KeyboardRef = IORef Keyboard
type TimeRef = IORef POSIXTime
type AccumRef = TimeRef
type PrevTimeRef = TimeRef
type GameRef = IORef (Rects, GameLogic)
type CallbackRefs = (AccumRef, PrevTimeRef, KeyboardRef, GameRef)
initCallbackRefs :: IO CallbackRefs
initCallbackRefs = do
accum <- newIORef secPerTick
prev <- getPOSIXTime >>= newIORef
keyb <- newIORef initKeyboard
cont <- newIORef ([],game)
return (accum, prev, keyb, cont)
-- | Update the Keyboard state according to the event
handleKeyboard :: CallbackRefs -> KeyboardMouseCallback
handleKeyboard (_, _, kb, _) k ks _ _ = modifyIORef kb (handleKeyEvent k ks)
The lack of a GLUT timer seemed to be the problem.
Here is a correctly working version by Rian Hunter:
https://github.com/rianhunter/frp-pong