Conway.hs

module Conway where

import Prelude hiding ((**))
import Data.List
import Data.Maybe
import Data.Ratio
import qualified Data.Map as M
import Control.Monad

data Face = H | T deriving (Show, Eq, Ord, Enum, Bounded)

fromBits :: [Bool] -> Integer
fromBits = foldl' (\n b -> if b then 2 * n + 1 else 2 * n) 0

(@@) :: Eq a => [a] -> [a] -> Integer
a @@ b = fromBits [and (zipWith (==) a' b) | a'@(_:_) <- tails a]

odds :: Eq a => [a] -> [a] -> (Integer, Integer)
odds a b = (a @@ a - a @@ b,
            b @@ b - b @@ a)

prob :: Eq a => [a] -> [a] -> Maybe Rational
prob a b | (x, y) <- odds a b, y /= 0 = Just (x % (x + y))
         | otherwise = Nothing

type WGraph a = M.Map a (M.Map a Rational)

mapClear :: (M.Map a Rational -> M.Map a Rational) -> WGraph a -> WGraph a
mapClear f = M.mapMaybe go
  where go n = let n' = f n in if M.null n' then Nothing else Just n'

probGraph :: (Ord a, Enum a, Bounded a) => Int -> WGraph [a]
probGraph n = M.fromList $ do
  let enumAll = [minBound..maxBound]
  seq1 <- replicateM n enumAll
  return (seq1, M.fromList $ do
    seq2 <- replicateM n enumAll
    w <- maybeToList (prob seq2 seq1)
    return (seq2, w))

winningStrats :: (Ord a, Enum a, Bounded a) => Int -> WGraph [a]
winningStrats = mapClear (M.filter (> 1 % 2)) . probGraph

type Edge a = (a, a, Rational)
type Path a = [Edge a]

src, tgt :: Edge a -> a
weight :: Edge a -> Rational
src (a, _, _) = a
tgt (_, b, _) = b
weight (_, _, w) = w

paths, paths1 :: Ord a => WGraph a -> a -> a -> [Path a]
paths gr a b | a == b = return []
             | otherwise = paths1 gr' a b
  -- should use mapClear below instead of <$>, to keep a well-formed graph,
  -- but this only gets used for recursive calls so it's ok i guess
  where gr' = M.delete a <$> gr
paths1 gr a b = do
  neigh <- maybeToList (M.lookup a gr)
  (a', w) <- M.toList neigh
  p <- paths gr a' b
  return ((a, a', w):p)

data Sign = Pos | Neg deriving (Show, Eq)

invert :: Sign -> Sign
invert Pos = Neg
invert Neg = Pos

scale :: Num a => Sign -> a -> a
scale Pos a =  a
scale Neg a = -a

altPos, altNeg :: [Sign]
altPos = Pos:altNeg
altNeg = Neg:altPos

altSum :: Num a => [a] -> a
altSum = sum . zipWith scale altPos