Data commit

Task/2048/Haskell/2048.hs

@@ -0,0 +1,132 @@
+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