hw.hs

{-# LANGUAGE ViewPatterns #-}

import Data.List

dropPieces :: [String] -> [String]
dropPieces (top:mid:rows) =
  let willDrop = zipWith (\t m -> m == '-' && t /= '-') top mid
      newTopRow = (\(t,m,w) -> if w then '-' else t) <$> (zip3 top mid willDrop)
      newMidRow = (\(t,m,w) -> if w then t else m) <$> (zip3 top mid willDrop)
  in
    newTopRow:(dropPieces (newMidRow:rows))
dropPieces (top:rows) = top:[]
dropPieces _ = []

fixpoint :: (Eq a) => (a -> a) -> a -> a
fixpoint f a@(f -> a') = case a' == a of
  True -> a'
  False -> fixpoint f a'
 
dropAll :: [String] -> [String]
dropAll = fixpoint dropPieces

shear :: Int -> [[a]] -> [[a]]
shear n b = snd $ mapAccumL (\n' row -> (n' + n, take (length row) . drop n' $ cycle row)) 0 b

checkHoriz :: [String] -> Bool
checkHoriz b = or $ fmap ((<) 3 . maximum . (<$>) length . group) b
checkVert = checkHoriz . transpose
checkDiag n b = checkVert $ shear n b

isComplete :: [String] -> Bool
isComplete b = or [checkHoriz b, checkVert b, checkDiag 1 b, checkDiag (-1) b]

emptyBoard :: Int -> Int -> [String]
emptyBoard x y = replicate y $ replicate x '-'

entry_point_1 = playMove '1'
  
playMove :: Char -> Int -> [String] -> [String]
playMove player move b@(isComplete -> done) = case done of
  True -> b
  False -> let (pre, _:post) = splitAt move (head b)
               newTop = pre ++ (player:post)
           in newTop:(tail b)

entry_point_2 = playMoves '1'
  
playMoves :: Char -> [Int] -> [String] -> [String]
playMoves player moves b = foldl (\board move -> playMove player move board) b moves 

entry_point_3 :: [Int] -> [String] -> [String]
entry_point_3 moves b = foldl (\board (move, player) -> playMove player move board) b (zip moves (cycle ['1'..(maxPlayer b)]))
  where
    maxPlayer :: [String] -> Char
    maxPlayer b = maximum $ maximum <$> b