Permalink
Browse files

Merge branch 'master' of https://github.com/glguy/vty-hangman-helper

  • Loading branch information...
2 parents 2b7dfe2 + afb7f46 commit 1df397eb1a5ea32b3c0fe5536049d014f142dac2 @glguy committed Jan 25, 2012
Showing with 43 additions and 55 deletions.
  1. +34 −55 VtyDriver.hs
  2. +9 −0 VtyMonad.hs
View
89 VtyDriver.hs
@@ -1,8 +1,6 @@
{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE ViewPatterns #-}
-module Main where
+module Main (main) where
-import Data.Char
import Data.List
import Data.Maybe
import Graphics.Vty
@@ -42,58 +40,44 @@ main = do
enterLetterMode :: GameState -> VIO ()
enterLetterMode g = do
- updateV (draw g Nothing [])
-
let validChoices = map fst (currentChoices (currentModel g))
genMask = generateMaskPrefix (currentMask (currentModel g))
-
- ev <- next_eventV
+ updateV (draw g Nothing [])
+ ev <- next_key
case ev of
- EvKey (KASCII (toUpper -> c)) [] | c `elem` validChoices ->
- enterMaskMode g c genMask
-
- EvKey KEsc [] -> return ()
-
- EvKey KBS [] | Just (h, c, xs) <- currentHistory g ->
- enterMaskMode h c xs
-
- _ -> enterLetterMode g
+ KASCII c | c `elem` validChoices -> enterMaskMode g c genMask
+ KBS | Just (h, c, xs) <- currentHistory g -> enterMaskMode h c xs
+ KEsc -> return ()
+ _ -> enterLetterMode g
enterMaskMode :: GameState -> Char -> [Maybe Char] -> VIO ()
enterMaskMode g c xs = do
+ let prevMask = currentMask (currentModel g)
+ growMask k = extendMask prevMask k xs
updateV (draw g (Just c) xs)
- let growMask k = extendMask (currentMask (currentModel g)) k xs
- ev <- next_eventV
+ ev <- next_key
case ev of
- EvKey (KASCII (toUpper -> k)) _ | k == c ->
- enterMaskMode g c (growMask (Just k))
-
- EvKey (KASCII ' ') _ -> enterMaskMode g c (growMask Nothing)
- EvKey (KASCII '.') _ -> enterMaskMode g c (growMask Nothing)
-
- EvKey KBS _ ->
- case retractMask (currentMask (currentModel g)) xs of
- Nothing -> enterLetterMode g
- Just xs' -> enterMaskMode g c xs'
-
- EvKey KEsc _ -> return ()
- EvKey KEnter _ ->
- case completeMask (currentMask (currentModel g)) xs of
- Nothing -> confirmMask c xs g
- Just xs' -> enterMaskMode g c xs'
-
- _ -> enterMaskMode g c xs
-
-confirmMask :: Char -> [Maybe Char] -> GameState -> VIO ()
-confirmMask c mask s =
+ KASCII k | k == c -> enterMaskMode g c (growMask (Just k))
+ KASCII ' ' -> enterMaskMode g c (growMask Nothing)
+ KASCII '.' -> enterMaskMode g c (growMask Nothing)
+ KBS -> case retractMask prevMask xs of
+ Nothing -> enterLetterMode g
+ Just ys -> enterMaskMode g c ys
+ KEnter -> case completeMask prevMask xs of
+ Nothing -> confirmMask g c xs
+ Just ys -> enterMaskMode g c ys
+ KEsc -> return ()
+ _ -> enterMaskMode g c xs
+
+confirmMask :: GameState -> Char -> [Maybe Char] -> VIO ()
+confirmMask s c mask =
case applyGuess c (Mask mask) (currentModel s) of
Left err -> fail ("Logic bug in mask generation: " ++ err)
- Right g ->
- enterLetterMode s
- { currentModel = g
- , currentMissCount = miss
- , currentHistory = Just (s, c, mask)
- }
+ Right g -> enterLetterMode GameState
+ { currentModel = g
+ , currentMissCount = miss
+ , currentHistory = Just (s, c, mask)
+ }
where
miss
| currentMask (currentModel s) == Mask mask = currentMissCount s + 1
@@ -154,7 +138,8 @@ draw s c xs =
<|> string def_attr (show (currentMask g))
cursor | isNothing c = Cursor 10 (image_height topbox)
- | otherwise = Cursor (genericLength xs + 10) (image_height topbox + 1)
+ | otherwise = Cursor (genericLength xs + 10)
+ (image_height topbox + 1)
g = currentModel s
wordlines = map (intercalate " ") (chunks 9 (currentWords g))
@@ -171,11 +156,11 @@ usedLettersText g = horiz_cat $ map pick alphabet
| otherwise = char (with_fore_color (with_style def_attr bold) red) x
drawMaskInput :: Bool -> Mask -> [Maybe Char] -> Image
-drawMaskInput False _ _ =
- string def_attr "New Mask:"
+drawMaskInput False _ _ = string def_attr "New Mask:"
drawMaskInput True (Mask previous) str
= string def_attr "New Mask: "
- <|> horiz_cat (zipWith drawMaskInputChar previous (map Just str ++ repeat Nothing))
+ <|> horiz_cat
+ (zipWith drawMaskInputChar previous (map Just str ++ repeat Nothing))
drawMaskInputChar :: Maybe Char -> Maybe (Maybe Char) -> Image
drawMaskInputChar x Nothing = char def_attr (fromMaybe '.' x)
@@ -232,9 +217,3 @@ chunks i xs = a : chunks i b
longerThan :: Int -> [a] -> Bool
longerThan i = not . null . drop i
-
-consume :: Int -> [(a,Int)] -> a
-consume i ((x,n):xs)
- | i < n = x
- | otherwise = consume (i - n) xs
-consume _ [] = error "consume: value too large"
View
9 VtyMonad.hs
@@ -1,5 +1,6 @@
module VtyMonad where
+import Data.Char
import Graphics.Vty
import Control.Exception (bracket)
@@ -23,5 +24,13 @@ updateV x = V (\vty -> update vty x)
next_eventV :: VIO Event
next_eventV = V next_event
+next_key :: VIO Key
+next_key = do
+ ev <- next_eventV
+ case ev of
+ EvKey (KASCII a) [] -> return (KASCII (toUpper a))
+ EvKey k [] -> return k
+ _ -> next_key
+
runV :: VIO a -> IO a
runV (V f) = bracket mkVty shutdown f

0 comments on commit 1df397e

Please sign in to comment.