133 lines
3.7 KiB
Haskell
133 lines
3.7 KiB
Haskell
import System.IO
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Control.Monad
|
|
import Data.Random
|
|
import Data.Random.Distribution.Categorical
|
|
import System.Console.ANSI
|
|
import Control.Lens
|
|
|
|
-- Logic
|
|
|
|
-- probability to get a 4
|
|
prob4 :: Double
|
|
prob4 = 0.1
|
|
|
|
type Position = [[Int]]
|
|
|
|
combine, shift :: [Int]->[Int]
|
|
combine (x:y:l) | x==y = (2*x) : combine l
|
|
combine (x:l) = x : combine l
|
|
combine [] = []
|
|
|
|
shift l = take (length l) $ combine (filter (>0) l) ++ [0,0..]
|
|
|
|
reflect :: [[a]] ->[[a]]
|
|
reflect = map reverse
|
|
|
|
type Move = Position -> Position
|
|
|
|
left, right, up, down :: Move
|
|
left = map shift
|
|
right = reflect . left . reflect
|
|
up = transpose . left . transpose
|
|
down = transpose . right . transpose
|
|
|
|
progress :: Eq a => (a -> a) -> a -> Maybe a
|
|
progress f pos = if pos==next_pos then Nothing else Just next_pos where next_pos= f pos
|
|
|
|
lost, win:: Position -> Bool
|
|
lost pos = all isNothing [progress move pos| move<-[left,right,up,down] ]
|
|
|
|
win = any $ any (>=2048)
|
|
|
|
go :: Position -> Maybe Move -> Maybe Position
|
|
go pos move = move >>= flip progress pos
|
|
|
|
|
|
{-
|
|
-- Adding 2 or 4 without lens:
|
|
update l i a = l1 ++ a : l2 where (l1,_:l2)=splitAt i l
|
|
indicesOf l = [0..length l-1]
|
|
|
|
add a x y pos = update pos y $ update (pos !! y) x a
|
|
|
|
add2or4 :: Position -> RVar Position
|
|
add2or4 pos = do
|
|
(x,y) <- randomElement [(x,y) | y<-indicesOf pos, x<-indicesOf (pos!!y), pos!!y!!x ==0 ]
|
|
a <- categorical [(0.9::Double,2), (0.1,4) ]
|
|
return $ add a x y pos
|
|
-}
|
|
|
|
-- or with lens:
|
|
indicesOf :: [a] -> [ReifiedTraversal' [a] a]
|
|
indicesOf l = [ Traversal $ ix i | i <- [0..length l - 1] ]
|
|
|
|
indices2Of :: [[a]] -> [ReifiedTraversal' [[a]] a]
|
|
indices2Of ls = [ Traversal $ i.j | Traversal i <- indicesOf ls, let Just l = ls ^? i, Traversal j <- indicesOf l]
|
|
|
|
add2or4 :: Position -> RVar Position
|
|
add2or4 pos = do
|
|
xy <- randomElement [ xy | Traversal xy <- indices2Of pos, pos ^? xy == Just 0 ]
|
|
a <- categorical [(1-prob4, 2), (prob4, 4) ]
|
|
return $ pos & xy .~ a
|
|
-- Easy, is'n it'?
|
|
|
|
-- Main loop
|
|
play :: Position -> IO ()
|
|
play pos = do
|
|
c <- getChar
|
|
case go pos $ lookup c [('D',left),('C',right),('A',up),('B',down)] of
|
|
Nothing -> play pos
|
|
Just pos1 -> do
|
|
pos2 <- sample $ add2or4 pos1
|
|
draw pos2
|
|
when (win pos2 && not (win pos)) $ putStrLn $ "You win! You may keep going."
|
|
if lost pos2 then putStrLn "You lost!"
|
|
else play pos2
|
|
|
|
main :: IO ()
|
|
main = do
|
|
pos <- sample $ add2or4 $ replicate 4 (replicate 4 0)
|
|
draw pos
|
|
play pos
|
|
|
|
-- Rendering
|
|
-- See https://en.wikipedia.org/wiki/ANSI_escape_code#Colors
|
|
colors =
|
|
[(0,"\ESC[38;5;234;48;5;250m ")
|
|
,(2,"\ESC[38;5;234;48;5;255m 2 ")
|
|
,(4,"\ESC[38;5;234;48;5;230m 4 ")
|
|
,(8,"\ESC[38;5;15;48;5;208m 8 ")
|
|
,(16,"\ESC[38;5;15;48;5;209m 16 ")
|
|
,(32,"\ESC[38;5;15;48;5;203m 32 ")
|
|
,(64,"\ESC[38;5;15;48;5;9m 64 ")
|
|
,(128,"\ESC[38;5;15;48;5;228m 128 ")
|
|
,(256,"\ESC[38;5;15;48;5;227m 256 ")
|
|
,(512,"\ESC[38;5;15;48;5;226m 512 ")
|
|
,(1024,"\ESC[38;5;15;48;5;221m 1024")
|
|
,(2048,"\ESC[38;5;15;48;5;220m 2048")
|
|
,(4096,"\ESC[38;5;15;48;5;0m 4096")
|
|
,(8192,"\ESC[38;5;15;48;5;0m 8192")
|
|
,(16384,"\ESC[38;5;15;48;5;0m16384")
|
|
,(32768,"\ESC[38;5;15;48;5;0m32768")
|
|
,(65536,"\ESC[38;5;15;48;5;0m65536")
|
|
,(131072,"\ESC[38;5;15;48;5;90m131072")
|
|
]
|
|
|
|
showTile x = fromJust (lookup x colors) ++ "\ESC[B\^H\^H\^H\^H\^H \ESC[A\ESC[C"
|
|
|
|
draw :: Position -> IO ()
|
|
draw pos = do
|
|
setSGR [Reset]
|
|
clearScreen
|
|
hideCursor
|
|
hSetEcho stdin False
|
|
hSetBuffering stdin NoBuffering
|
|
setSGR [SetConsoleIntensity BoldIntensity]
|
|
putStr "\ESC[38;5;234;48;5;248m" -- set board color
|
|
setCursorPosition 0 0
|
|
replicateM_ 13 $ putStrLn $ replicate 26 ' '
|
|
setCursorPosition 1 1
|
|
putStrLn $ intercalate "\n\n\n\ESC[C" $ concatMap showTile `map` pos
|