Skip to content
Browse files

added 'real' random, saveguarded the user input

  • Loading branch information...
1 parent 93e77df commit 722f8a0cbd859d354926d5bbd6ad3c8ad07aac94 @epsilonhalbe committed Apr 9, 2011
Showing with 340 additions and 52 deletions.
  1. +51 −51 Mastermind.hs
  2. +279 −0 TAP.hs
  3. +10 −1 mm.t.hs
View
102 Mastermind.hs
@@ -1,56 +1,63 @@
-module Mastermind (reds, whites) where
+--module Mastermind (reds, whites, parseInts) where
{- my (=ε/2) haskellous version of the game called mastermind -}
import Data.List.Split (splitOneOf)
-{- has to be fetched with
+{- has to be fetched with
foo@bar~> cabal update
foo@bar~> cabal install split
-}
import Random
import Data.Maybe
-import Control.Applicative
+import Control.Applicative
+import System.IO
+main :: IO ()
main = do
- putStrLn "\nplease do give me a length"
- laength <- parseInt <$> getLine
- putStrLn "\n uuhm and the number of colours would be cool too"
- colours <- parseInt <$> getLine
- putStrLn ("laength="++show(laength)++" and colours="++show(colours))
- list_of_randoms <- return (take laength (randomRs (1,colours) (mkStdGen 42)::[Int])){-todo mkStdGen with system time-}
- game_loop list_of_randoms
- putStrLn "\nWant to play again??"
- c <- getChar
- regame c
- where regame c
- | elem c "yY" = do
- putStrLn "\ngame on mate"
- main
- | elem c "nN" = putStrLn "\nGame Over"
- | otherwise = do
- putStrLn "\nyou must type one of Yy to confirm or nN to abort"
- regame c
+ hSetBuffering stdin LineBuffering
+ seed <- newStdGen
+ putStrLn "\nplease do give me a length or accept that it will be 4"
+ laength <- fmap (head . (dvalue 4) . parseInts) getLine
+ putStrLn "\nuuhm and the number of colours would be cool too or accept a 5"
+ colours <- fmap (head . (dvalue 5) . parseInts) getLine
+-- putStrLn ("laength="++show(laength)++" and colours="++show(colours))
+ list_of_randoms <- return (take laength (randomRs (1,colours) seed::[Int])){-todo mkStdGen with system time-}
+-- putStrLn(show(list_of_randoms))
+ game_loop laength colours list_of_randoms
+ putStrLn "\nWant to play again??"
+ hSetBuffering stdin NoBuffering
+ c <- getChar
+ regame c
+ where regame c
+ | elem c "yY" = do
+ putStrLn "\ngame on mate"
+ main
+ | elem c "nN" = putStrLn "\nGame Over"
+ | otherwise = do
+ putStrLn "\nyou must type one of Yy to confirm or nN to abort"
+ c'<- getChar
+ regame c'
-{-the tricky thing about haskell is the return values - so i left it in this case - otherwise the type checker won't let me pass -}
-game_loop list_of_randoms = do
- list_of_guesses <- safe_get_n_check_guesslist
- if (list_of_guesses == list_of_randoms)
- then putStrLn "\ncorrect guess"
- else do
- putStrLn (show ((reds list_of_randoms list_of_guesses) ++ (whites list_of_randoms list_of_guesses)))
- game_loop list_of_randoms
+game_loop :: Int -> Int -> [Int] -> IO ()
+game_loop laength colours list_of_randoms = do
+ list_of_guesses <- fetch_guesslist laength colours
+ if (list_of_guesses == list_of_randoms)
+ then putStrLn "\ncorrect guess"
+ else do
+ putStrLn (show ((reds list_of_randoms list_of_guesses) ++ (whites list_of_randoms list_of_guesses)))
+ game_loop laength colours list_of_randoms
reds :: (Num a) => [a]->[a]->[a]{-denotes the right colours & right positions -}
reds randoms guesses = filter (==0) (zipWith (-) randoms guesses)
{- reds [1,2,3,4,5] [5,4,3,2,1] ~~> filter (==0) [-4,-2,0,2,5] ~~> [0] -}
whites :: (Num a) => [a]->[a]->[a] {- denotes the right colours but on wrong positions -}
whites randoms guesses = map (const 1) (
- filter (\x -> elem x guesses) (zipWith (*) randoms helper))
- where helper = (map (signum.abs) (zipWith (-) randoms guesses))
-{-
-whites [1,2,3,4,5] [5,4,3,2,1]
-~~> filter (\x -> elem x [5,4,3,2,1]) (zipWith (*) [1,2,3,4,5] [1,1,0,1,1]
+ filter (\x -> elem x guesses) (zipWith (*) randoms helper))
+ where helper = (map (signum.abs) (zipWith (-) randoms guesses))
+{-
+whites [1,2,3,4,5] [5,4,3,2,1]
+~~> filter (\x -> elem x [5,4,3,2,1]) (zipWith (*) [1,2,3,4,5] [1,1,0,1,1]
~~> filter (\x -> elem x [5,4,3,2,1]) [1,2,0,4,5] {- essentially deletes the "red" guesses -}
~~> [1,2,4,5]
~~> map (const 1) [1,2,4,5] ~~> [1,1,1,1]
@@ -60,7 +67,7 @@ helper [1,2,3,4,5] [5,4,3,2,1]
~~> [1,1,0,1,1]
{- for those who forgot their math:
-(signum.abs) x =
+(signum.abs) x =
| x == 0 = 0
| otherwise = 1 -}
-}
@@ -69,25 +76,18 @@ helper [1,2,3,4,5] [5,4,3,2,1]
maybeReads :: Read a => String -> Maybe a
maybeReads = fmap fst . listToMaybe . reads
---parse int from getLine
---default_on_empty :: a -> Int
---default_or_parseInt dvalue a = if a == [] then dvalue else a
-parseInt :: String -> Int
-parseInt = head . parseInts
-
+{- todo make default values-}
+dvalue :: (Show a) => a -> [a] -> [a]
+dvalue dfault x
+ | null x = [dfault]
+ | otherwise = x
parseInts :: String -> [Int]
parseInts = catMaybes . map maybeReads . splitOneOf ",.;: "
-safe_get_n_check_guesslist :: IO [Int]
-safe_get_n_check_guesslist = do
- putStrLn "\nplease do give me a sequence of 4 numbers between 1 and 5 separated by \",\"" {- 4 should be replaced by 'length' and 5 by 'colours' - fixeme -}
- parseInts <$> getLine
+fetch_guesslist ::Int -> Int -> IO [Int]
+fetch_guesslist l c = do
+ putStrLn ("\nplease do give me a sequence of "++show(l)++" numbers between 1 and "++show(c)++" separated by \",\"") {- 4 should be replaced by 'length' and 5 by 'colours' - fixeme -}
+ parseInts <$> getLine
-get_n_check_guesslist :: IO [Int]
-get_n_check_guesslist = do
- putStrLn "\nplease do give me a sequence of 4 numbers between 1 and 5 separated by \",\"" {- 4 should be replaced by 'length' and 5 by 'colours' - fixeme -}
- line <- getLine
- let tmp = splitOneOf ";:,. " line
- return $ map (\x -> read x:: Int) tmp
{- $ is evaluate; it returns the result of the input function - has to be used since line is an action "<-" and the action has to be evaluated; still a little mystery to me (= ε/2) -}
View
279 TAP.hs
@@ -0,0 +1,279 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module TAP (
+ planTests, planNoPlan, planSkipAll,
+ is, isnt, like, unlike, pass, fail, ok,
+ skip, skipIf, toDo,
+ diag, bailOut, runTests
+ ) where
+
+
+import Prelude hiding (fail)
+import System.IO
+import System.Exit
+import Control.Monad.State hiding (fail)
+import Control.Exception
+import Text.Regex.Posix
+
+
+data TAPState = TAPState {
+ planSet :: Bool,
+ noPlan :: Bool,
+ skipAll :: Bool,
+ testDied :: Bool,
+ expectedTests :: Int,
+ executedTests :: Int,
+ failedTests :: Int,
+ toDoReason :: Maybe String,
+ exitCode :: Int
+} deriving (Show)
+
+initState = TAPState {
+ planSet = False,
+ noPlan = False,
+ skipAll = False,
+ testDied = False,
+ expectedTests = 0,
+ executedTests = 0,
+ failedTests = 0,
+ toDoReason = Nothing,
+ exitCode = 0
+}
+
+
+newtype TAP a = TAP {
+ runTAP :: StateT TAPState IO a
+ } deriving (Monad, MonadIO, MonadState TAPState)
+
+
+_assertNotPlanned :: TAP ()
+_assertNotPlanned = do
+ ts <- get
+ when (planSet ts) $ _die "You tried to plan twice!"
+
+
+_assertPlanned :: TAP ()
+_assertPlanned = do
+ ts <- get
+ when (not $ planSet ts) $ _die $ "You tried to run a test without a plan!"
+ ++ " Gotta have a plan."
+
+
+_printPlan :: Int -> Maybe String -> IO ()
+_printPlan n plan = do
+ putStrLn $ "1.." ++ show n ++
+ case plan of
+ Just plan -> " # " ++ plan
+ otherwise -> ""
+
+
+planTests :: Int -> TAP ()
+planTests n = do
+ _assertNotPlanned
+ when (n == 0) $ _die $ "You said to run 0 tests!"
+ ++ " You've got to run something."
+ liftIO $ _printPlan n Nothing
+ modify (\x -> x {planSet = True, expectedTests = n})
+
+
+planNoPlan :: TAP ()
+planNoPlan = do
+ _assertNotPlanned
+ modify (\x -> x {planSet = True, noPlan = True})
+
+
+planSkipAll :: String -> TAP ()
+planSkipAll plan = do
+ _assertNotPlanned
+ liftIO . _printPlan 0 . Just $ "Skip " ++ plan
+ modify (\x -> x {planSet = True, skipAll = True})
+ _exit $ Just 0
+ return ()
+
+
+
+_matches :: String -> String -> Bool
+_matches "" _ = False
+_matches _ "" = False
+_matches target pattern = target =~ pattern :: Bool
+
+
+ok :: Bool -> Maybe String -> TAP Bool
+ok result msg = do
+ _assertPlanned
+ modify (\x -> x {executedTests = executedTests x + 1})
+
+ case msg of
+ Just s -> when (_matches s "^[0-9]+$") $ do
+ diag $ " You named your test '" ++ s
+ ++ "'. You shouldn't use numbers for your test names."
+ diag $ " Very confusing."
+ otherwise -> return ()
+
+ when (not result) $ do
+ liftIO $ putStr "not "
+ modify (\x -> x {failedTests = failedTests x + 1})
+
+ ts <- get
+ liftIO . putStr $ "ok " ++ (show $ executedTests ts)
+
+ case msg of
+ -- TODO: Escape s
+ Just s -> liftIO . putStr $ " - " ++ s
+ otherwise -> return ()
+
+ case (toDoReason ts) of
+ Just r -> liftIO . putStr $ " # TODO " ++ r
+ otherwise -> return ()
+
+ when (not result) $ do
+ modify (\x -> x {failedTests = failedTests x - 1})
+
+ liftIO $ putStrLn ""
+
+ -- TODO: STACK TRACE?
+
+ return result
+
+
+is :: (Show a, Eq a) => a -> a -> Maybe String -> TAP Bool
+is result expected msg = do
+ rc <- ok (result == expected) msg
+ when (not rc) $ do
+ diag $ " got: '" ++ (show result) ++ "'"
+ diag $ " expected: '" ++ (show expected) ++ "'"
+ return rc
+
+
+isnt :: (Show a, Eq a) => a -> a -> Maybe String -> TAP Bool
+isnt result expected msg = do
+ rc <- ok (result /= expected) msg
+ when (not rc) $ do
+ diag $ " got: '" ++ (show result) ++ "'"
+ diag $ " didn't expect: '" ++ (show expected) ++ "'"
+ return rc
+
+
+like :: String -> String -> Maybe String -> TAP Bool
+like target pattern msg = do
+ rc <- ok (_matches target pattern) msg
+ when (not rc) $ diag $ " '" ++ target ++ "' doesn't match '"
+ ++ pattern ++ "'"
+ return rc
+
+
+unlike :: String -> String -> Maybe String -> TAP Bool
+unlike target pattern msg = do
+ rc <- ok (not $ _matches target pattern) msg
+ when (not rc) $ diag $ " '" ++ target ++ "' matches '"
+ ++ pattern ++ "'"
+ return rc
+
+
+pass :: Maybe String -> TAP Bool
+pass s = ok True s
+
+
+fail :: Maybe String -> TAP Bool
+fail s = ok False s
+
+
+
+skip :: Int -> String -> TAP ()
+skip n reason = do
+ forM_ [1 .. n] (\n' -> do
+ modify (\x -> x {executedTests = executedTests x + 1})
+ ts <- get
+ liftIO . putStrLn $ "ok " ++ (show $ executedTests ts)
+ ++ " # skip: " ++ reason)
+ return ()
+
+
+skipIf :: Bool -> Int -> String -> TAP a -> TAP ()
+skipIf cond n reason tap = do
+ if cond
+ then skip n reason
+ else do
+ tap
+ return ()
+
+
+toDo :: String -> TAP a -> TAP ()
+toDo reason tap = do
+ modify (\x -> x {toDoReason = Just reason})
+ a <- tap
+ modify (\x -> x {toDoReason = Nothing})
+ return ()
+
+
+diag :: String -> TAP ()
+diag s = do
+ liftIO . putStrLn $ "# " ++ s
+
+
+bailOut :: String -> TAP a
+bailOut s = do
+ liftIO $ hPutStrLn stderr s
+ _exit $ Just 255
+
+
+_die :: String -> TAP a
+_die s = do
+ liftIO $ hPutStrLn stderr s
+ modify (\x -> x {testDied = True})
+ _exit $ Just 255
+
+
+_wrapup :: TAP ()
+_wrapup = do
+ ts <- get
+ let s n = if (n > 1) then "s" else ""
+ let err | not $ planSet ts = diag "Looks like your test died before it could output anything." >> return True
+ | testDied ts = diag ("Looks like your test died just after " ++ (show $ executedTests ts)) >> return True
+ | otherwise = return False
+ stop <- err
+ if stop
+ then return ()
+ else do
+ when ((not $ noPlan ts)&&((expectedTests ts) < (executedTests ts))) $ do
+ let extra = (executedTests ts) - (expectedTests ts)
+ diag $ "Looks like you planned " ++ (show $ expectedTests ts)
+ ++ " test" ++ (s $ expectedTests ts)
+ ++ " but ran " ++ (show extra) ++ " extra."
+ modify (\x -> x {exitCode = -1})
+
+ when ((not $ noPlan ts)&&((expectedTests ts) > (executedTests ts))) $ do
+ diag $ "Looks like you planned " ++ (show $ expectedTests ts)
+ ++ " test" ++ (s $ expectedTests ts)
+ ++ " but only ran " ++ (show $ executedTests ts)
+
+ when (failedTests ts > 0) $ do
+ diag $ "Looks like you failed " ++ (show $ failedTests ts)
+ ++ " test" ++ (s $ failedTests ts)
+ ++ " of " ++ (show $ executedTests ts)
+
+
+_exit :: Maybe Int -> TAP a
+_exit mrc = do
+ case mrc of
+ Just rc -> modify (\x -> x {exitCode = rc})
+ otherwise -> return ()
+ ts <- get
+ when (exitCode ts == 0) $ do
+ rc <- if ((noPlan ts)||(not $ planSet ts))
+ then return $ failedTests ts
+ else if ((expectedTests ts) < (executedTests ts))
+ then return $ (executedTests ts) - (expectedTests ts)
+ else return $ ((failedTests ts)
+ + ((expectedTests ts) - (executedTests ts)))
+ modify (\x -> x {exitCode = rc})
+
+ _wrapup
+ ts <- get
+ let rc = exitCode ts
+ liftIO . exitWith $ if (rc == 0) then ExitSuccess else ExitFailure rc
+
+
+runTests :: TAP a -> IO (a, TAPState)
+-- TODO: Add exception handling here?
+runTests s = runStateT (runTAP (s >> _exit Nothing)) initState
View
11 mm.t.hs
@@ -4,9 +4,18 @@ import TAP
import Mastermind
main = runTests $ do
- planTests 2
+ planTests 9
let list_of_randoms = [2,2,3,5]
is (reds [2,2,3,4] list_of_randoms) [0,0,0] $ Just "correct number and position"
+ is (reds [] list_of_randoms) [] $ Just "correct num and pos - fringe case: []"
+ is (reds [2,2,2,2,2] list_of_randoms) [0,0] $ Just "correct num and pos - fringe case: input list longer than list_of_randoms"
+
is (whites [1,4,2,2] list_of_randoms) [1,1] $ Just "correct number, but wrong position"
+ is (whites [] list_of_randoms) [] $ Just "correct num, wrong pos - fringe case: []"
+ is (whites [1,1,2,2,2] list_of_randoms) [1,1] $ Just "correct num, wrong pos - fringe case: input list longer than list_of_randoms"
+
+ is (parseInts "1,2,3,4,5") [1,2,3,4,5] $ Just "fetch number list from user input"
+ is (parseInts "") [] $ Just "fetch number list from user input - fringe case: \"\""
+ is (parseInts "a,b,c,1,2,3") [1,2,3] $ Just "fetch number list from user input - fringe case: letters in string"

0 comments on commit 722f8a0

Please sign in to comment.
Something went wrong with that request. Please try again.