http://www.uda30.com/QUIZ99/Quiz-42.htm Q217

coin.hs

module Main where

import Control.Monad
import Data.List (nub)

data Coin = Black | White | Blank deriving (Eq, Ord)

instance Show Coin where
  show Black = "●"
  show White = "○"
  show Blank = "_"

type Coins = [Coin]

ini :: Coins
ini = [Black, Black, Black, Black, White, White, White, White]

pp :: Coins -> String
pp coins = coins >>= show

pp5 :: (Coins, Coins, Coins, Coins) -> IO ()
pp5 (c1, c2, c3, c4) =
  putStrLn $ pp ini ++ " -> " ++ pp c1 ++ " -> " ++ pp c2 ++ " -> " ++ pp c3 ++ " -> " ++ pp c4

main :: IO ()
main = do
  mapM_ pp5 $ nub $ filter finish $ four ini

finish :: (Coins, Coins, Coins, Coins) -> Bool
finish (_, _, _, coins@(White:_)) = go1 coins
  where
    go1 (White:cs) = go2 cs
    go1 [] = True
    go1 _ = False
    go2 (Black:cs) = go1 cs
    go2 [] = True
    go2 _ = False
finish (_, _, _, coins@(Black:_)) = go2 coins
  where
    go1 (White:cs) = go2 cs
    go1 [] = True
    go1 _ = False
    go2 (Black:cs) = go1 cs
    go2 [] = True
    go2 _ = False
finish (_, _, _, _) = False

four :: Coins -> [(Coins, Coins, Coins, Coins)]
four cs0 = do
  cs1 <- next cs0
  cs2 <- next cs1
  cs3 <- next cs2
  cs4 <- next cs3
  return (strip cs1, strip cs2, strip cs3, strip cs4)

next :: Coins -> [Coins]
next coins = do
  (pair, coins') <- pick coins
  insert pair coins'

isBlank :: Coin -> Bool
isBlank Blank = True
isBlank _ = False

pick :: Coins -> [((Coin, Coin), Coins)]
pick coins = pick' (strip coins) []
  where
    pick' [] _ = []
    pick' [_] _ = []
    pick' (c1:c2:cs) acc
      | c1 /= Blank && c2 /= Blank = ((c1, c2), acc ++ [Blank, Blank] ++ cs) : pick' (c2:cs) (acc ++ [c1])
      | otherwise = pick' (c2:cs) (acc ++ [c1])

insert :: (Coin, Coin) -> Coins -> [Coins]
insert (c1, c2) coins = insert' [] (strip coins)
  where
    insert' [] (r1:r) = (c1:c2:r1:r) : insert' [r1] r
    insert' _ [_] = []
    insert' l [] = [l ++ [c1, c2]]
    insert' l (r1:r2:r)
      | r1 == Blank && r2 == Blank && (last l /= Blank || head r /= Blank) =
        (l ++ (c1:c2:r)) : insert' (l ++ [r2]) (r1:r)
      | otherwise =
        insert' (l ++ [r1]) (r2:r)

strip :: Coins -> Coins
strip = stripR . stripL
  where
    stripL (Blank:cs) = stripL cs
    stripL cs = cs
    stripR = reverse . stripL . reverse