Skip to content

Instantly share code, notes, and snippets.

@gfixler
Last active August 29, 2015 14:22
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save gfixler/010780e56a0b357ed084 to your computer and use it in GitHub Desktop.
Save gfixler/010780e56a0b357ed084 to your computer and use it in GitHub Desktop.
import Data.List ( transpose )
import Data.Monoid ( Monoid, mempty, mappend )
import System.IO ( BufferMode(NoBuffering)
, hSetBuffering, hSetEcho
, stdin, stdout, getChar
)
import Control.Monad ( forM_ )
newtype StdVal = StdVal Int deriving (Eq)
type Board a = [[a]]
board :: Int -> a -> Board a
board n = replicate n . replicate n
stdBoard :: Board StdVal
stdBoard = board 4 mempty
instance Enum StdVal where
fromEnum (StdVal x) = x
toEnum = StdVal
succ = toEnum . (*2) . fromEnum
pred = undefined
instance Monoid StdVal where
mempty = StdVal 0
mappend (StdVal x) (StdVal y) = StdVal $ x + y
instance Show StdVal where
show (StdVal x) = show x
showBoard = mapM_ print . map (map (\(StdVal x) -> x))
clump :: (Eq a, Monoid a) => [a] -> [a]
clump = filter (/= mempty)
smoosh :: (Eq a, Enum a) => [a] -> [a]
smoosh (x:y:ys) | x == y = succ x : smoosh ys
| otherwise = x : smoosh (y:ys)
smoosh xs = xs
slide :: (Eq a, Enum a, Monoid a) => [a] -> [a]
slide xs = take (length xs) $ (smoosh . clump) xs ++ repeat mempty
data Dir = U | D | L | R
move :: (Eq a, Enum a, Monoid a) => Dir -> Board a -> Board a
move U = transpose . map slide . transpose
move D = transpose . move R . transpose
move L = map slide
move R = map reverse . move L . map reverse
testBoard :: Board StdVal
testBoard = [ [StdVal 0, StdVal 0, StdVal 0, StdVal 0]
, [StdVal 1, StdVal 2, StdVal 4, StdVal 8]
, [StdVal 4, StdVal 2, StdVal 2, StdVal 0]
, [StdVal 2, StdVal 2, StdVal 2, StdVal 2]
]
main :: IO ()
main = do
forM_ [stdin, stdout] (flip hSetBuffering NoBuffering)
forM_ [stdin, stdout] (flip hSetEcho False)
loop testBoard
loop b = do
putStrLn ""
mapM_ print b
input b
input b = do
c <- getChar
case c of 'h' -> loop (move L b)
'j' -> loop (move D b)
'k' -> loop (move U b)
'l' -> loop (move R b)
'q' -> return ()
_ -> loop b
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment