http://pastebin.com/2CS1k1Zq
In this game i need to get step the game forward every half a second or so while occasionally getting input to change direction. These too things seem impossible to do with haskell is there a way to do it? Currently I am having an mv tread stall exception.
Update: Found the hWaitForInput function in System.IO which is essentially the same as waitFor.
Here is some code largely based on this answer.
The main difference I made is that the thread waiting for a key press does not perform the getChar directly. The result communicated in the MVar is an indication of timeout or that a key press has occurred. It is the responsibility of the main thread to actually get the character. This prevents a possible race condition in case the char reading thread is killed between getting the character and putting it into the MVar.
import Control.Concurrent
import Control.Monad
import Data.Maybe
import System.IO
import Control.Exception
data Event = CharReady | TimedOut
withRawStdin :: IO a -> IO a
withRawStdin = bracket uncook restore . const
where
uncook = do
oldBuffering <- hGetBuffering stdin
oldEcho <- hGetEcho stdin
hSetBuffering stdin NoBuffering
hSetEcho stdin False
return (oldBuffering, oldEcho)
restore (oldBuffering, oldEcho) = do
hSetBuffering stdin oldBuffering
hSetEcho stdin oldEcho
waitFor :: Int -> IO Event
waitFor delay = do
done <- newEmptyMVar
withRawStdin . bracket (start done) cleanUp $ \_ -> takeMVar done
where
start done = do
t1 <- forkIO $ hLookAhead stdin >> putMVar done CharReady
t2 <- forkIO $ threadDelay delay >> putMVar done TimedOut
return (t1, t2)
cleanUp (t1, t2) = do
killThread t1
killThread t2
loop state = do
if state <= 0
then putStrLn "Game over."
else do putStrLn $ "Rounds to go: " ++ show state
e <- waitFor 3000000
case e of
TimedOut -> do putStrLn "Too late!"; loop state
CharReady -> do c <- getChar -- should not block
if c == 'x'
then do putStrLn "Good job!"; loop (state-1)
else do putStrLn "Wrong key"; loop state
main = loop 3
Related
I was trying to compile a haskell game code, this code generates three thread, one for infinite loop, one for collecting user's interaction, one for triggering the events. However, the code cannot be compiled and I don't know why.
Here's the code:
module Main where
import Control.Concurrent
import Control.Monad
import System.IO
import System.Random
import Text.Printf
data Msg = C Char | Time
data Event = C Char | Time Char
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
hSetEcho stdin False
-- shared resources
chan <- newEmptyMVar
removedDigits <- newEmptyMVar
unmatchedDigits <- newEmptyMVar
numberOfGuesses <- newEmptyMVar
--starting the generating thread and the user thread
forkIO $ generatingThread chan
forkIO $ userThread chan
--the main loop
if mainloop chan == True then "Congratulations! You won!" else "Better luck next time!"
return()
mainloop :: Chan c -> Bool
let mainloop = do
if length unmatchedDigits >= 10
then return False
Event <- readChan c
if Event == "timer"
then unmatchedDigits ++ param
else if testGuessedNumber param unmatchedDigits == True
then
removeMatchedDigit
if length unmatchedDigits == 0
then return True
mainloop c
-- Generating Thread aka event thread generating the random numbers
generatingThread :: Chan msgChan -> IO ()
generatingThread msgChan = forever $ do
publishTimerEvent msgChan 1000000
publishTimerEvent :: Chan msgChan -> Int delay ()
publishTimerEvent msgChan = do
c <- getRandomChar
putMVar msgChan ("timer" c)
threadDelay newDelay
velocity <- 0.9
if delay * velocity < 100
then newDelay <- 100
else newDelay <- delay * velocity
publishTimerEvent msgChan newDelay
getRandomChar :: Char c ()
getRandomChar = do
i <- randomRIO (0,9)
let c = "0123456789" !! i
return c
-- User Thread
userThread :: MVar Msg -> IO ()
userThread chan = forever $ do
c <- getChar
putMVar chan (C c)
showStr(show c)
testGuessedNumber :: Int -> Int -> Bool
testGuessedNumber a b
| a == b = True
| otherwise = False
-- Shows the given string at the left edge of the current terminal line after
-- having blanked out the first 20 characters on that line.
showStr :: String -> IO ()
showStr s = putStr ("\r" ++ replicate 20 ' ' ++ "\r" ++ s)
The error is "test.hs:36:3: error: parse error on input ‘Event’"
Variable names can not begin with uppercase letters, such as Event. Try renaming the variable to something like event.
In Haskell, all if ... then ... else blocks must have all their components; what would the result be otherwise?
The problem is that the compiler was expecting an else, but it actually got Event. That said, you have more problems than a simple parse error. return does not do what you think it does. For example, this code will print hi.
main = do
return ()
putStrLn "hi"
The return function simply lifts a value into a monad, it doesn't stop the computation or anything like that. Here is what your probably want to have:
...
if length unmatchedDigits >= 10
then return False
else do
Event <- readChan c
if Event == "timer"
then ...
else ...
This way, nothing happens after the if block, so the function just ends there, with the last value as False (if length unmatchedDigits >= 10) or continues on properly (if length unmatchedDigits < 10).
You also almost certainly don't want to use Event (uppercase E), because that would mean it is a data constructor. You probably meant event (lowercase e), which is just an ordinary variable name.
Additionally: This is very, very non-idiomatic Haskell. You definitely don't need MVars in this situation, and certainly not four of them. Chans are not the same thing as MVars, and you don't need either one unless you are doing heavy-duty multi-threading. I highly recommend you completely rewrite this and try to minimize the amount of code that uses IO (it should be maybe 10-15 lines of IO code in this example, probably less).
This is not Java; you don't need to name your variables in your type signature (Chan msgChan -> Int delay ()), nor do you need to write wrapper functions for standard library functions to monomorphize their type. testGuessedNumber is literally the same function as (==).
You will have much more success if you revisit basic, pure function syntax and understand how problems are solved in Haskell than with trying to emulate another language. Read some LYAH or Real World Haskell.
When I test some simple cases about threaded codes,
I found some loop hang without hFlush stdout even it does not use any print things.
import Control.Concurrent
import System.IO
import Data.IORef
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait sw = loop
where
loop = do
v <- readIORef sw
--hFlush stdout -- without this, hang
if v
then return()
else loop
monitor sw = forkIO $ loop
where
loop = do
v <- readIORef sw
print v
delay 1
loop
main = do
sw <- newIORef False
forkIO $ do
delay 4
writeIORef sw True
monitor sw
wait sw
--putStrLn "End"
This code hangs whether monitor sw and putStrLn "End" exist or not.
However, just uncomment hFlush stdout in wait, it works properly and ends.
This also happens with a code using MVar.
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: MVar Bool -> IO ()
wait sw = loop
where loop = do
v <- readMVar sw
hFlush stdout -- without this, hangs
if v
then return ()
else loop
main :: IO ()
main = do
sw <- newMVar False
forkIO $ do
delay 4
modifyMVar_ sw (\_ -> return True)
wait sw
These two codes will run properly when running by runghc.
However, the codes below are not hanging without hFlush stdout.
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: MVar Bool -> IO ()
wait sw = loop
where loop = do
v <- readMVar sw
if v
then return ()
else loop
main :: IO ()
main = do
sw <- newEmptyMVar
forkIO $ do
delay 4
putMVar sw True
wait sw
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import System.IO
delay :: Int -> IO ()
delay = threadDelay . (* 1000000)
wait :: TVar Bool -> IO ()
wait sw = atomically $ do
v <- readTVar sw
unless v retry
main :: IO ()
main = do
sw <- newTVarIO False
forkIO $ do
delay 4
atomically $ writeTVar sw True
wait sw
I know that there are difference. But I couldn't find out why some codes hang.
Is stdout is related with handling thread?
Could you explain why the loops are hanging or not without hFlush stdout?
Additional:
1. I've tested this codes with GHC 7.10.2 {OS X, Windows}
Most likely the compiler optimized the wait into non-allocating busy loop. Runtime system just doesn't have a chance to interrupt it to let the child thread to run. You can "fix" by adding any action that allocates or yields, e.g. hFlush or threadDelay. Also you can compile the code with -fno-omit-yields.
See also: https://ghc.haskell.org/trac/ghc/ticket/367 and https://ghc.haskell.org/trac/ghc/ticket/10639
I'm trying to make a program that print arrows until the user press enter (see code bellow).
The problem is that when I press enter, I see the "stop" string in the console, but it doesn't change the value of m in the outputArrows function.
How can I share the state?
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
waitForInput m = do
getLine
putStrLn "stop"
putMVar m True
outputArrows m = do
stop <- readMVar m
unless stop $ do
threadDelay 1000000
putStr ">"
outputArrows m
main = do
m <- newMVar False
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
Your putMVar doesn't actually put a new value in the MVar but blocks indefinitely. MVars are like boxes that can hold only a single value. If you want to replace the value, you need to take out the old value first.
If you don't need the blocking behavior of MVar, you should just use a regular IORef or possibly a TVar if you need to ensure that more complex operations run atomically.
You should use swapMVar instead of putMVar. As mentioned by #shang, putMVar blocks until the MVar is empty, so the putMVar never finishes:
waitForInput m = do
getLine
putStrLn "stop"
swapMVar m True
Alternatively, you could just use an empty MVar () as a boolean flag:
waitForInput :: MVar () -> IO ()
waitForInput m = do
getLine
putStrLn "stop"
putMVar m ()
outputArrows :: MVar () -> IO ()
outputArrows m = do
running <- isEmptyMVar m
when running $ do
threadDelay 1000000
putStr ">"
outputArrows m
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
m <- newEmptyMVar
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
The following program creates two threads running concurrently, that each sleep for a random amount of time, before printing a line of text to stdout.
import Control.Concurrent
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer str = forkIO . forever $ do
randomDelay 1000000 -- μs
putStrLn str
main = do
printer "Hello"
printer "World"
return ()
The output generally looks something like
>> main
Hello
World
World
Hello
WoHrelld
o
World
Hello
*Interrupted
>>
How do you ensure that only one thread can write to stdout at a time? This seems like the kind of thing that STM should be good at, but all STM transactions must have the type STM a for some a, and an action that prints to the screen has type IO a, and there doesn't seem to be a way to embed IO into STM.
The way to handle output with STM is to have an output queue that is shared between all threads and which is processed by a single thread.
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer queue str = forkIO . forever $ do
randomDelay 1000000 -- μs
atomically $ writeTChan queue str
prepareOutputQueue = do
queue <- newTChanIO
forkIO . forever $ atomically (readTChan queue) >>= putStrLn
return queue
main = do
queue <- prepareOutputQueue
printer queue "Hello"
printer queue "World"
return ()
Locking in the way you're describing isn't possible usingSTM. This is because STM is based on optimistic locking and so every transaction must be restartable at any point. If you embedded an IO operation into STM, it could be executed multiple times.
Probably the easiest solution for this problem is to use a MVar as a lock:
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer lock str = forkIO . forever $ do
randomDelay 1000000
withMVar lock (\_ -> putStrLn str)
main = do
lock <- newMVar ()
printer lock "Hello"
printer lock "World"
return ()
In this solution the lock is passed as an argument to printer.
Some people prefer to declare the lock as a top-level global variable, but currently this requires unsafePerformIO and relies on properties of GHC that AFAIK aren't part of the Haskell Language Report (in particular, it relies on the fact that a global variable with non-polymorphic type is evaluated at most once during the execution of a program).
A bit of research, based on Petr Pudlák's answer shows that there is a module Control.Concurrent.Lock in the concurrent-extra package that provides an abstraction around MVar ()-based locks.
The solution using that library is
import Control.Concurrent
import qualified Control.Concurrent.Lock as Lock
import Control.Monad
import System.Random
randomDelay t = randomRIO (0, t) >>= threadDelay
printer lock str = forkIO . forever $ do
randomDelay 1000
Lock.with lock (putStrLn str)
main = do
lock <- Lock.new
printer lock "Hello"
printer lock "World"
return ()
This is the example using global lock as mentioned by Petr.
import Control.Concurrent
import Control.Monad
import System.Random
import Control.Concurrent.MVar (newMVar, takeMVar, putMVar, MVar)
import System.IO.Unsafe (unsafePerformIO)
{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()
printer x = forkIO . forever $ do
randomDelay 100000
() <- takeMVar lock
let atomicPutStrLn str = putStrLn str >> putMVar lock ()
atomicPutStrLn x
randomDelay t = randomRIO (0, t) >>= threadDelay
main = do
printer "Hello"
printer "World"
return ()
You can actually implement a lock using STM if you want, though an MVar will almost certainly perform better.
newtype Lock = Lock (TVar Status)
data Status = Locked | Unlocked
newLocked :: IO Lock
newLocked = Lock <$> newTVarIO Locked
newUnlocked :: IO Lock
newUnlocked = Lock <$> newTVarIO Unlocked
-- | Acquire a lock.
acquire :: Lock -> IO ()
acquire (Lock tv) = atomically $
readTVar tv >>= \case
Locked -> retry
Unlocked -> writeTVar tv Locked
-- | Try to acquire a lock. If the operation succeeds,
-- return `True`.
tryAcquire :: Lock -> IO Bool
tryAcquire (Lock tv) = atomically $
readTVar tv >>= \case
Locked -> pure False
Unlocked -> True <$ writeTVar tv Locked
-- | Release a lock. This version throws an exception
-- if the lock is unlocked.
release :: Lock -> IO ()
release (Lock tv) = atomically $
readTVar tv >>= \case
Unlocked -> throwSTM DoubleRelease
Locked -> writeTVar tv Unlocked
data DoubleRelease = DoubleRelease deriving Show
instance Exception DoubleRelease where
displayException ~DoubleRelease = "Attempted to release an unlocked lock."
-- | Release a lock. This version does nothing if
-- the lock is unlocked.
releaseIdempotent :: Lock -> IO ()
releaseIdempotent (Lock tv) = atomically $ writeTVar tv Unlocked
-- | Get the status of a lock.
isLocked :: Lock -> IO Status
isLocked (Lock tv) = readTVarIO tv
acquire/release pairs need careful masking and exception handling, much like primitive MVar operations. The documentation suggests, but does not actually state, that STM operations are interruptible when they retry; assuming this is true, the same approach used for withMVar will work here. Note: I've opened a GHC ticket to document retry interruptibility.
The function below wants to either receive and ack or wait until its duetime has come and return.
Now, it works when it receives and ack. It works correctly when no ack is received and waits until duetime.
When the duetime is reached it freezes. It seems that it is not exiting my self constructed loop correctly. I have also tried with if-then-else, but same result. I do not want to use whileM.
How do I correctly exit the loop?
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
unless (B.unpack a == "ack") (when (now' < duetime') (waitAck s duetime'))
print (B.unpack a)
return ()
The correct solution is to race two threads, one that waits for the ack, and one that waits for the time. Kill the one that loses the race. Perhaps this (untested) code will give you a hint about how:
import Control.Concurrency.MVar
withTimeout :: Int -> IO a -> IO (Maybe a)
withTimeout n io = do
mvar <- newEmptyMVar
timeout <- forkIO (threadDelay n >> putMVar mvar Nothing)
action <- forkIO (io >>= putMVar mvar . Just)
result <- takeMVar mvar
killThread timeout
killThread action
return result
waitAck s timeout = withTimeout timeout go where
go = do
(a, _) <- recvFrom s 4711
if B.unpack a == "ack" then print (B.unpack a) else go
edit: It seems that base provides System.Timeout.timeout for exactly this purpose. Its implementation is more likely to be correct than this one, too.
That's not an iterative loop. You don't place any conditions on the stuff after the recursive call, so when the conditions finally fail, the whole thing will unwind, printing once for every recursive call. I suspect that might be enough to make it appear frozen.
Try something like this:
waitAck s duetime' = do
print ("in")
(a, _) <- recvFrom s 4711
now' <- getPOSIXTime
if B.unpack a == "ack" || now' >= duetime'
then print (B.unpack a)
else waitAck s duetime'