{-# LANGUAGE NamedFieldPuns #-} module Exercise08 where import Data.Bits ( Bits((.&.), shiftL, shiftR, (.|.)) ) import Data.List (sortOn, find, foldl', group, groupBy, sort, transpose, zip4, mapAccumL ) import System.Random (mkStdGen, randoms, randomIO, Random) import Data.Function (on) import Data.Bifunctor (Bifunctor(first)) -- import GHC.IO.Unsafe (unsafePerformIO) import Data.Tree (unfoldTree, rootLabel, Tree(Node), levels, flatten) import Data.Maybe (fromJust) -- import Debug.Trace (trace) -- Player is either 1 or -1 type Player = Int -- A field is just an Int value where the absolute gives the number of pieces on the field -- and the sign corresponds to the player -- e.g. -3 would mean there are three blobs in this field of player -1 type Field = Int type Row = [Field] type Column = [Field] -- boards are rectangles represented as a list of rows type Board = [Row] -- A position on the board is represented as (row, column) -- (0,0) is the top left corner, coordinate values increase towards the bottom right type Pos = (Int, Int) -- A size represented as (height,width) type Size = (Int, Int) -- A strategy takes the player who's move it is, optionally takes a list of double values -- to allow for probabilistic strategies, takes the current board and gives back the position -- of the move the player should do type Strategy = [Double] -> Player -> Board -> Pos -- A stateful strategy can additionally pass some object between invocations type StatefulStrategyFunc a = a -> [Double] -> Player -> Board -> (Pos, a) -- first value is the state object to pass to the first invocation of each game type StatefulStrategy a = (a, StatefulStrategyFunc a) defaultSize :: (Int, Int) defaultSize = (9,6) -- Some useful helper functions row :: Board -> Int -> Row row = (!!) column :: Board -> Int -> Column column = row . transpose width :: Board -> Int width (x : _) = length x width _ = 0 height :: Board -> Int height = length size :: Board -> Size size b = (height b, width b) getCell :: Pos -> Board -> Field getCell (y, x) b = b !! y !! x -- pretty print a single cell showCell :: Field -> String showCell c = "- +" !! succ (signum c) : show (abs c) -- pretty print the given board showBoard :: Board -> String showBoard = unlines . map (unwords . map showCell) -- print a board to the console printBoard :: Board -> IO () printBoard = putStr . showBoard -- check if a position is one a board of the given size isValidPos :: Size -> Pos -> Bool isValidPos (r, c) (y, x) = y >= 0 && y < r && x >= 0 && x < c {- x.1 -} allMoves :: Size -> [Pos] allMoves si | si == defaultSize = [(0,0),(0,1),(0,2),(0,3),(0,4),(0,5),(1,0),(1,1),(1,2),(1,3),(1,4),(1,5),(2,0),(2,1),(2,2),(2,3),(2,4),(2,5),(3,0),(3,1),(3,2),(3,3),(3,4),(3,5),(4,0),(4,1),(4,2),(4,3),(4,4),(4,5),(5,0),(5,1),(5,2),(5,3),(5,4),(5,5),(6,0),(6,1),(6,2),(6,3),(6,4),(6,5),(7,0),(7,1),(7,2),(7,3),(7,4),(7,5),(8,0),(8,1),(8,2),(8,3),(8,4),(8,5)] allMoves (r, c) = concatMap ((<$> [0..c - 1]) . (,)) [0..r - 1] allNeighbours :: Size -> [[Pos]] allNeighbours si | si == defaultSize = [[(1,0),(0,1)],[(1,1),(0,2),(0,0)],[(1,2),(0,3),(0,1)],[(1,3),(0,4),(0,2)],[(1,4),(0,5),(0,3)],[(1,5),(0,4)],[(2,0),(0,0),(1,1)],[(2,1),(0,1),(1,2),(1,0)],[(2,2),(0,2),(1,3),(1,1)],[(2,3),(0,3),(1,4),(1,2)],[(2,4),(0,4),(1,5),(1,3)],[(2,5),(0,5),(1,4)],[(3,0),(1,0),(2,1)],[(3,1),(1,1),(2,2),(2,0)],[(3,2),(1,2),(2,3),(2,1)],[(3,3),(1,3),(2,4),(2,2)],[(3,4),(1,4),(2,5),(2,3)],[(3,5),(1,5),(2,4)],[(4,0),(2,0),(3,1)],[(4,1),(2,1),(3,2),(3,0)],[(4,2),(2,2),(3,3),(3,1)],[(4,3),(2,3),(3,4),(3,2)],[(4,4),(2,4),(3,5),(3,3)],[(4,5),(2,5),(3,4)],[(5,0),(3,0),(4,1)],[(5,1),(3,1),(4,2),(4,0)],[(5,2),(3,2),(4,3),(4,1)],[(5,3),(3,3),(4,4),(4,2)],[(5,4),(3,4),(4,5),(4,3)],[(5,5),(3,5),(4,4)],[(6,0),(4,0),(5,1)],[(6,1),(4,1),(5,2),(5,0)],[(6,2),(4,2),(5,3),(5,1)],[(6,3),(4,3),(5,4),(5,2)],[(6,4),(4,4),(5,5),(5,3)],[(6,5),(4,5),(5,4)],[(7,0),(5,0),(6,1)],[(7,1),(5,1),(6,2),(6,0)],[(7,2),(5,2),(6,3),(6,1)],[(7,3),(5,3),(6,4),(6,2)],[(7,4),(5,4),(6,5),(6,3)],[(7,5),(5,5),(6,4)],[(8,0),(6,0),(7,1)],[(8,1),(6,1),(7,2),(7,0)],[(8,2),(6,2),(7,3),(7,1)],[(8,3),(6,3),(7,4),(7,2)],[(8,4),(6,4),(7,5),(7,3)],[(8,5),(6,5),(7,4)],[(7,0),(8,1)],[(7,1),(8,2),(8,0)],[(7,2),(8,3),(8,1)],[(7,3),(8,4),(8,2)],[(7,4),(8,5),(8,3)],[(7,5),(8,4)]] allNeighbours si = map (neighbors si) $ allMoves si allCriticalMasses :: Size -> [Int] allCriticalMasses si | si == defaultSize = [2,3,3,3,3,2,3,4,4,4,4,3,3,4,4,4,4,3,3,4,4,4,4,3,3,4,4,4,4,3,3,4,4,4,4,3,3,4,4,4,4,3,3,4,4,4,4,3,2,3,3,3,3,2] allCriticalMasses si = map (criticalMass si) $ allMoves si criticalMass :: Size -> Pos -> Int criticalMass _ (0, 0) = 2 criticalMass (_, c) (0, x) | x == c - 1 = 2 | otherwise = 3 criticalMass (r, _) (y, 0) | y == r - 1 = 2 | otherwise = 3 criticalMass (r, c) (y, x) | (r - 1, c - 1) == (y, x) = 2 | y == r - 1 || x == c - 1 = 3 | otherwise = 4 emptyBoard :: Size -> Board emptyBoard (r, c) = replicate r (replicate c 0) -- Check if the given player can put an orb on the given position canPlaceOrb :: Player -> Pos -> Board -> Bool canPlaceOrb p pos b = case getCell pos b of 0 -> True x -> signum x == p -- Check if the given player has won the game, -- you can assume that the opponent has made at least one move before hasWon :: Player -> Board -> Bool hasWon p = not . any ((-p `elem`) . map signum) gameOver :: Board -> Bool gameOver b = hasWon 1 b || hasWon (-1) b -- the list of neighbors of a cell, sorted in row major (ie. sort neighbours == neighbours) neighbors :: Size -> Pos -> [Pos] neighbors si (y, x) = filter (isValidPos si) [(y - 1, x), (y, x - 1), (y, x + 1), (y + 1, x)] -- update a single position on the board -- f: function that modifies the number of orbs in the cell -- p: player to whom the updated cell should belong updatePos :: (Int -> Int) -> Player -> Pos -> Board -> Board updatePos f p (y, x) b = rs ++ [c ++ [signum p * f (abs e)] ++ c'] ++ rs' where (rs, r:rs') = splitAt y b (c, e:c') = splitAt x r {- x.2 -} -- value, position, critical mass, neighbours type DecoBoard = [(Int, Pos, Int, [Pos])] decorateBoard :: Size -> Board -> DecoBoard decorateBoard size board = zip4 (concat board) (allMoves size) (allCriticalMasses size) (allNeighbours size) undecorateBoard :: DecoBoard -> Board undecorateBoard = map (map (\(val, _, _, _) -> val)) . groupBy ((==) `on` \(_, (y, _), _, _) -> y) asPlayer :: Player -> Int -> Int asPlayer 1 = id asPlayer _ = negate updateTile :: (Int -> Int) -> Player -> Int -> Int updateTile f pl = asPlayer pl . f . abs groupCount :: (Eq a, Integral b) => [a] -> [(a, b)] groupCount xs = map (\xs -> (head xs, fromIntegral $ length xs)) $ group xs -- place an orb for the given player in the given cell putOrb :: Player -> Pos -> Board -> Board putOrb pl pos board = undecorateBoard $ snd $ putOrbs pl [(pos, 1)] $ decorateBoard (size board) board putOrbs :: Player -> [(Pos, Int)] -> DecoBoard -> (Int, DecoBoard) putOrbs _ [] board = (1, board) putOrbs pl toPlace board | gameWon = (1, boardOverflowed) | otherwise = let (cost, newBoard) = putOrbs pl sortedPlaces boardOverflowed in (cost + 1, newBoard) where (_, boardPlaced) = mapAccumL placeR toPlace board ((toPlace', gameWon), boardOverflowed) = mapAccumL overflowR ([], True) boardPlaced sortedPlaces = groupCount $ sort toPlace' placeR [] dt = ([], dt) placeR ((placePos, cnt):poss) (val, pos, cm, ns) | placePos == pos = (poss, (updateTile (+ cnt) pl val, pos, cm, ns)) | otherwise = ((placePos, cnt):poss, (val, pos, cm, ns)) overflowR (overflowedAcc, gameWonAcc) (val, pos, cm, ns) | abs val < cm = ((overflowedAcc, gameWonAcc'), (val, pos, cm, ns)) | otherwise = ((ns ++ overflowedAcc, gameWonAcc'), (updateTile (subtract cm) pl val, pos, cm, ns)) where gameWonAcc' = gameWonAcc && (val == 0 || signum val == pl) {- x.3 -} {-WETT-} data GamePreNode = GamePreNode { player1 :: Player, position1 :: Pos, board1 :: DecoBoard, cost1 :: Int } deriving (Show, Eq) data GameNode = GameNode { score :: Infinite Int, player :: Player, position :: Pos, board :: DecoBoard, cost :: Int } deriving (Show, Eq) type GameTree = Tree GameNode type Scoring = DecoBoard -> Infinite Int scoreBoardDum :: Player -> Scoring scoreBoardDum (-1) = negate . scoreBoardDum 1 scoreBoardDum 1 = {- (\scs -> trace (show scs) finalScore scs) -} finalScore . foldl' ff (0, 0, 0) where finalScore (0, b, _) | b > 1 = NInf finalScore (a, 0, _) | a > 1 = Inf finalScore (_, _, sc) = Only sc -- ff (p1, p2, total) (val, (y, x), cm, _) ff (p1, p2, total) (val, _, cm, _) | val > 0 = (p1 + 1, p2, total + score) | val < 0 = (p1, p2 + 1, total + score) | otherwise = (p1, p2, total) where score = -- where score = (val + (((y + x) .&. 1) `shiftL` 1)) * case cm of 2 -> 6 * val 3 -> 4 * val 4 -> 3 * val _ -> undefined -- | val > 0 = (p1 + val, p2) -- | otherwise = (p1, p2 + val) -- where score = (12 * val) `div` cm scoreBoardDum _ = undefined -- return is really a subset of a DecoBoard but oh well, poss must be sorted findTiles :: [Pos] -> DecoBoard -> DecoBoard findTiles _ [] = [] findTiles (pos1:poss) ((val, pos2, cm, ns):ts) | pos1 == pos2 = (val, pos2, cm, ns) : findTiles poss ts findTiles poss (_:ts) = findTiles poss ts scoreBoardBrilliant :: Player -> Scoring scoreBoardBrilliant (-1) board = negate $ scoreBoardBrilliant 1 board scoreBoardBrilliant 1 board = finalScore countA countB boardScore where -- count both players' tiles (countA, countB) = foldl' f (0, 0) board f (a, b) (val, _, _, _) | val > 0 = (a + 1, b) | val < 0 = (a, b + 1) | otherwise = (a, b) -- find all tiles with at least one orb and lookup all their neighbours relevantOrbs = [(val, cm, findTiles ns board) | (val, _, cm, ns) <- board, val /= 0] scoreTile (val, cm, ns) = val + (signum val * case sum $ map (scoreNeighbour val) ns of 0 -> (case cm of { 3 -> 2; 2 -> 3; _ -> 0 }) + (if abs val == cm - 1 then 2 else 0) x -> x) -- if the neighbour belongs to the enemy, subtract 5 - cm from the score (ie. add cm - 5) scoreNeighbour valA (valB, _, cm, _) | abs valB == cm - 1 && signum valA /= signum valB = cm - 5 | otherwise = 0 boardScore = {- trace (show relevantOrbs) -} sum $ map scoreTile relevantOrbs finalScore a 0 _ | a > 1 = Inf finalScore 0 b _ | b > 1 = NInf finalScore _ _ sc = Only sc scoreBoardBrilliant _ _ = undefined baseCost :: Int baseCost = 1 -- value, position, critical mass, neighbours -- OK withAllValidMoves :: GamePreNode -> [GamePreNode] withAllValidMoves GamePreNode {player1, position1, board1, cost1} = [case putOrbs player1 [(pos, 1)] board1 of (cost, newBoard) -> GamePreNode {player1=negate player1, position1=pos, board1=newBoard, cost1=baseCost{- + cost -}} | (val, pos, cm, _) <- board1, val == 0 || signum val == player1] withScore :: Scoring -> GamePreNode -> GameNode withScore sf GamePreNode {player1, position1, board1, cost1} = GameNode {score=sf board1, player=player1, position=position1, board=board1, cost=cost1} -- pl is maximizing player (ie. the AI) unfoldGameNode :: Player -> (GamePreNode -> (GameNode, [GamePreNode])) unfoldGameNode pl gpn | finite $ score gn = (gn, withAllValidMoves gpn) | otherwise = (gn, [] {- undefined -}) where gn = withScore (scoreBoardDum pl) gpn --TODO: cutoff terminal nodes! (done) --TODO: rewrite to use Int (with maxBound/minBound) instead of infinite int? --seperate hashmap for neighbours/critical masses? --TODO: sometimes finds no move (-69, -420) --> this is because all moves are a guaranteed loss, i think --optimize costs, maybe add base? --improve heuristic --profiling --let GameNode {position=posDef} = rootLabel $ head sts in posDef negamax :: Player -> Int -> Infinite Int -> Infinite Int -> GameTree -> (Infinite Int, Pos) negamax pl1 costDepth _ _ (Node GameNode {score=sc, player, position} _) | costDepth <= 0 || infinite sc = {- trace "terminal/costDepth" -} (if pl1 == player then sc else negate sc, position) {- TODO: replace _ with [] above and remove cond || infinite sc -} negamax pl1 costDepth alpha beta (Node GameNode {score, player, position, cost} sts) = case foldr ff (alpha, NInf, let GameNode {position=posDef} = rootLabel $ head sts in posDef) sts of (_, score', pos') -> {- trace ("cdepth: " ++ show costDepth ++ " pos: " ++ show pos') -} (score', pos') where negamax' = (first negate .) . negamax pl1 (costDepth - cost) (negate beta) ff _ (maxAlpha, maxScore, bestPos) | maxAlpha >= beta = (maxAlpha, maxScore, bestPos) ff gn (maxAlpha, maxScore, bestPos) | nextScore > maxScore = (max maxAlpha nextScore, nextScore, case gn of Node GameNode {position} _ -> position) | otherwise = (maxAlpha, maxScore, bestPos) where (nextScore, _) = negamax' (negate maxAlpha) gn -- ff = undefined -- ff gn (alpha', score) -- negamax' gn negamax1 :: Int -> GameTree -> Pos negamax1 costDepth gn = let Node GameNode {player} _ = gn in snd $ negamax player costDepth NInf Inf gn costDepth :: Int costDepth = 3 -- Your strategy strategy :: Strategy strategy _ pl board = {- trace ("AI is player: " ++ show pl ++ "\nAI sees:\n" ++ showBoard board ++ "AI chose: " ++ show choice) -} choice where choice = negamax1 costDepth $ unfoldBoard pl board unfoldBoard :: Player -> Board -> Tree GameNode unfoldBoard pl board = unfoldTree (unfoldGameNode pl) GamePreNode {player1=pl, position1=(-1,-1), board1=decorateBoard (size board) board, cost1=baseCost} -- adds state to a strategy that doesn't use it wrapStrategy :: Strategy -> StatefulStrategy Int wrapStrategy strat = (0, \s r p b -> (strat r p b, succ s)) putAndRead :: (Read a) => String -> IO a putAndRead str = do putStr str readLn -- {-# NOINLINE showGameStateAndGetMove #-} -- showGameStateAndGetMove :: Player -> Board -> Pos -- showGameStateAndGetMove pl board = unsafePerformIO $ putAndRead ("You are player " ++ show pl ++ "\n" ++ showBoard board ++ "Your move: ") -- humanStrategy :: Strategy -- humanStrategy _ = showGameStateAndGetMove board2 :: Board board2 = [[-1,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,0], [0,0,0,0,0,1], [0,0,0,0,1,-1]] board3 :: Board board3 = [[0,2,0], [2,-3,2], [0,2,0]] board4 :: Board board4 = [[0,-2,0], [0,2,0], [0,0,0]] takeDepth :: Int -> Tree a -> Tree a takeDepth 0 (Node l _) = Node l [] takeDepth n (Node l sts) = Node l (map (takeDepth (n - 1)) sts) --seems OK -- map (map (\GameNode {score=sc,player=pl,position=pos} -> (sc,pl,pos))) $ take 2 $ levels $ unfoldBoard 1 board2 --not OK -- >>> negamax1 4 $ unfoldBoard 1 board2 -- independent of player, most likely in negamax -- (8,5) -- unfoldBoard 1 board2 -- chooseMoveNegamax :: (Player -> Scoring) -> Maybe GameTree -> [Double] -> Player -> Board -> (Pos, Maybe GameTree) -- chooseMoveNegamax sf Nothing _ pl board = undefined -- chooseMoveNegamax sf (Just gt) _ pl board = undefined -- -- A strategy takes the player who's move it is, optionally takes a list of double values -- -- to allow for probabilistic strategies, takes the current board and gives back the position -- -- of the move the player should do -- type Strategy = [Double] -> Player -> Board -> Pos -- -- A stateful strategy can additionally pass some object between invocations -- type StatefulStrategyFunc a = a -> [Double] -> Player -> Board -> (Pos, a) -- -- first value is the state object to pass to the first invocation of each game -- type StatefulStrategy a = (a, StatefulStrategyFunc a) -- the actual strategy submissions -- if you want to use state modify this instead of strategy -- additionally you may change the Int in this type declaration to any type that is usefully for your strategy -- strategyState :: StatefulStrategy Int -- strategyState = wrapStrategy strategy -- (Nothing, chooseMoveNegamax scoreBoardDum) filterOwnMove :: Pos -> GameTree -> Maybe GameTree filterOwnMove pos (Node _ sts) = Just $ fromJust $ find (\(Node GameNode {position} _) -> position == pos) sts filterEnemyMove :: Board -> GameTree -> GameTree filterEnemyMove b (Node _ sts) = fromJust $ find (sameAsFlatBoard . board . rootLabel) sts where flatBoard = concat b sameAsFlatBoard = and . zipWith (\bv (dbv, _, _, _) -> bv == dbv) flatBoard costDepthNegamax :: Int -- costDepthNegamax = floor (3.5 * fromIntegral baseCost) costDepthNegamax = 3 negamaxStrategy :: Maybe GameTree -> [Double] -> Player -> Board -> (Pos, Maybe GameTree) negamaxStrategy Nothing l pl board = negamaxStrategyOwnTree tree pl where tree = unfoldBoard pl board negamaxStrategy (Just oldTree) _ pl board = negamaxStrategyOwnTree tree pl where tree = filterEnemyMove board oldTree negamaxStrategyOwnTree :: GameTree -> Player -> (Pos, Maybe GameTree) negamaxStrategyOwnTree tree pl = (move, filterOwnMove move tree) where move = negamax1 costDepthNegamax tree strategyState :: StatefulStrategy (Maybe GameTree) strategyState = (Nothing, negamaxStrategy) {-TTEW-} main :: IO () main = playAndPrint defaultSize strategyState strategyState -- Simulate a game between two strategies on a board of the given size and -- returns the state of the board before each move together with the player that won the game play :: [Int] -> Size -> StatefulStrategy a -> StatefulStrategy b -> [(Board, Pos)] play rss (r, c) (isa, sa) (isb, sb) = go rss isa sa isb sb 1 0 (replicate r (replicate c 0)) where -- type signature is necessary, inferred type is wrong! go :: [Int] -> a -> StatefulStrategyFunc a -> b -> StatefulStrategyFunc b -> Player -> Int -> Board -> [(Board, Pos)] go (rs:rss) stc sc stn sn p n b | won = [] | valid = (b, m) : go rss stn sn st' sc (-p) (succ n) (putOrb p m b) | otherwise = [] where won = n > 1 && hasWon (-p) b (m, st') = sc stc (mkRandoms rs) p b valid = isValidPos (size b) m && canPlaceOrb p m b go [] _ _ _ _ _ _ _ = undefined -- helper stuff that would probably be better off in its own file data Infinite a = NInf | Only a | Inf deriving (Show, Eq, Ord) infComb :: Infinite a -> Infinite a -> Infinite a infComb Inf NInf = undefined infComb NInf Inf = undefined infComb Inf _ = Inf infComb NInf _ = NInf infComb _ Inf = Inf infComb _ NInf = NInf infComb (Only _) (Only _) = undefined finite :: Infinite a -> Bool finite (Only _) = True finite _ = False infinite :: Infinite a -> Bool infinite (Only _) = False infinite _ = True instance Num a => Num (Infinite a) where (Only x) + (Only y) = Only $ x + y x + y = infComb x y (Only x) * (Only y) = Only $ x * y x * y = infComb x y abs Inf = Inf abs NInf = Inf abs (Only x) = Only $ abs x signum Inf = Only 1 signum NInf = Only $ -1 signum (Only x) = Only $ signum x fromInteger = Only . fromIntegral negate Inf = NInf negate NInf = Inf negate (Only x) = Only $ negate x instance Bounded (Infinite a) where minBound = NInf maxBound = Inf --this instance isn't perfect instance (Bounded a, Enum a) => Enum (Infinite a) where toEnum = Only . toEnum fromEnum (Only x) = fromEnum x fromEnum _ = errorWithoutStackTrace "Inf/NInf argument to fromEnum" drawTreeGraphviz :: (a -> a -> String) -> (a -> String) -> Tree a -> String drawTreeGraphviz edgeLabeller nodeLabeller tree = "digraph Tree {\n" ++ unlines (fst $ draw' (0 :: Integer) tree) ++ "}\n" where draw' idn (Node l []) = ([nstmt idn l], idn + 1) draw' idn1 (Node l xs) = foldl' (ff idn1 l) ([nstmt idn1 l], idn1 + 1) xs ff pidn pl (stmts, idn) (Node l xs) = let (subStmts, nidn) = draw' idn (Node l xs) in (estmt pidn idn pl l : subStmts ++ stmts, nidn) nstmt idn l = "n" ++ show idn ++ " [label=\"" ++ nodeLabeller l ++ "\"];" estmt idn1 idn2 l1 l2 = "n" ++ show idn1 ++ " -> n" ++ show idn2 ++ " [label=\"" ++ edgeLabeller l1 l2 ++ "\"];" edgeLabellerV :: GameNode -> GameNode -> String edgeLabellerV GameNode {player} GameNode {position} = take 1 (show $ signum player) ++ "@" ++ show position nodeLabellerV :: GameNode -> String nodeLabellerV GameNode {score=Only x} = show x nodeLabellerV GameNode {score=Inf} = "∞" nodeLabellerV GameNode {score=NInf} = "-∞" -- Play a game and print it to the console playAndPrint :: Size -> StatefulStrategy a -> StatefulStrategy b -> IO () playAndPrint size sa sb = do seed <- randomIO -- let seed = 42 let moves = play (mkRandoms seed) size sa sb putStr $ unlines (zipWith showState moves $ cycle ['+', '-']) ++ "\n" ++ (case length moves `mod` 2 of { 1 -> "Winner: +"; 0 -> "Winner: -"; _ -> undefined }) ++ "\n" ++ "View at https://vmnipkow16.in.tum.de/christmas2020/embed.html#i" ++ base64 (1 : t size ++ concatMap (t . snd) moves) ++ "\n" where showState (b, pos) p = showBoard b ++ p : " places at " ++ show pos ++ "\n" -- showState _ _ = "" t (a, b) = [a, b] mkRandoms :: Random a => Int -> [a] mkRandoms = randoms . mkStdGen base64 :: [Int] -> String base64 xs = case xs of [] -> "" [a] -> f1 a : f2 a 0 : "==" [a, b] -> f1 a : f2 a b : f3 b 0 : "=" a : b : c : d -> f1 a : f2 a b : f3 b c : f4 c : base64 d where alphabet = (!!) "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" f1 a = alphabet $ shiftR a 2 f2 a b = alphabet $ shiftL (a .&. 3 ) 4 .|. shiftR b 4 f3 b c = alphabet $ shiftL (b .&. 15) 2 .|. shiftR c 6 f4 c = alphabet $ c .&. 63