An Arimaa Library for Haskell.

{-# LANGUAGE TypeSynonymInstances, OverlappingInstances #-}

import Data.Array
import Data.Char
import qualified Data.Map as Map
import qualified Data.String.Utils as DSU
import Control.Monad.State

data Animal = R | C | D | H | M | E 
     deriving (Ord, Eq, Show)
data Color = Gold | Silver deriving (Show, Eq)
type Colored a = (Color, a)
type Piece = Colored Animal

showPiece (Gold, a)   = show a
showPiece (Silver, a) = map toLower $ show a


gold   a = (Gold, a)
silver a = (Silver, a)

g = gold
s = silver

data Direction = North | South | East | West
  deriving (Eq)
North @: (x, y) = (x, y + 1)
South @: (x, y) = (x, y - 1)
East  @: (x, y) = (eastOf x, y)
West  @: (x, y) = (westOf x, y)

instance (Show) Direction where
    show North = "n"
    show South = "s"
    show East  = "e"
    show West  = "w"

(>>:) :: Square -> Square -> Direction
(x1, y1) >>: (x2, y2) = diff (ord x1 - ord x2, y1-y2)
   where diff ( 1,  0) = West
         diff (-1,  0) = East
         diff ( 0,  1) = North
         diff ( 0, -1) = South
         diff _        = error ">>: only works for 2 numbers" 

cardinals :: [Direction]
cardinals = [North, East, South, West]

neighborSquares :: Square -> [(Direction, Square)]
neighborSquares sq = [(dir, dir @: sq) | dir <- cardinals ]

rev :: Direction -> Direction
rev North = South
rev East  = West
rev South = North
rev West  = East

data Step
   = Put Piece Square
   | Kill Piece Square
   | Move Piece Square Direction
   | Resign
   | Takeback
   deriving (Eq)

instance (Show) Step where
    show step = case step of
        Put  p s   -> sh p s
        Kill p s   -> sh p s ++ "x"
        Move p s d -> sh p s ++ show d
        Resign     -> "resign"
        Takeback   -> "takeback"
        where sh p s = showPiece p ++ showSquare s

parseStep :: String -> Step
parseStep s@(p:x:y:end)
  | s == "takeback" = Takeback
  | s == "resign"   = Resign 
  | end == ""       = Put  pp (x, py)
  | end == "x"      = Kill pp (x, py)
  | otherwise       = Move pp (x, py) pd
  where pp = parsePiece p
        py = parseRank y
        pd = parseDirection $ head end


parsePiece :: Char -> Piece
parsePiece ch = case ch of 
  -- gold pieces --
  'E' -> g E
  'M' -> g M
  'H' -> g H
  'D' -> g D
  'C' -> g C
  'R' -> g R
  -- silver pieces --
  'e' -> s E
  'm' -> s M
  'h' -> s H
  'd' -> s D
  'c' -> s C
  'r' -> s R

parseRank :: Char -> Int
parseRank ch = case ch of
  '1' -> 1
  '2' -> 2
  '3' -> 3
  '4' -> 4
  '5' -> 5
  '6' -> 6
  '7' -> 7
  '8' -> 8

parseDirection :: Char -> Direction
parseDirection ch = case ch of
  'n' -> North
  's' -> South
  'e' -> East
  'w' -> West

apply :: (Board -> Square -> Content) -> Board -> Board
apply f br = Board $ array fullBounds $ contents
             where contents = [(sq, f br sq) | sq <- range fullBounds]

steps :: String -> [Step]
steps s = map parseStep $ DSU.split " " s

open99of9 = steps "Ra1 Rb1 Rc1 Cd1 Ce1 Rf1 Rg1 Rh1 Ra2 Hb2 Dc2 Md2 Ee2 Df2 Hg2 Rh2"

(//=) :: Board -> [(Square, Content)] -> Board
(Board br) //= changes = Board $ br // changes

step :: Step -> Board -> Board
step st br = case st of
    Put  p sq     -> br //= [(sq, A p)]    
    Kill p sq     -> todo
    Move p sq d   -> todo
    Resign        -> todo
    Takeback      -> todo
  where
    todo = br

doSteps :: [Step] -> Board -> Board
doSteps []      br = br
doSteps (s :ss) br = doSteps ss $ step s br

mirror :: Step -> Step
mirror (Put (Gold, p) (x, y)) = Put (Silver, p) (x, 9-y)
mirror other = other

board99of9 = doSteps (gold ++ silver) emptyBoard
     where gold   = open99of9
           silver = map mirror gold

type PieceAt = (Piece, Square)

content sq (Board br) = br ! sq

neighbors :: Square -> Board -> [(Direction, PieceAt)]
neighbors square br = [(dir, (pieceAt sq br, sq))
                         | (dir, sq)  <- neighborSquares square
                         , isPiece $ content sq br]

enemitos :: PieceAt -> Board -> [(Direction, PieceAt)]
enemitos ((c, a), sq) br = [n | n@(dir, ((c2, a2), _)) <- neighbors sq br 
                              , a2 < a  && c2 == opp c]

isPiece :: Content -> Bool
isPiece (A _) = True
isPiece _     = False

toPiece :: Content -> Piece
toPiece (A p) = p
toPiece _     = error "not a piece!"

pieceAt :: Square -> Board -> Piece
pieceAt sq br  = toPiece $ content sq br

pieceSquares br = [sq | sq <- range coreBounds,  isPiece $ content sq br]

isEmpty sq br = case content sq br of
                   Empty -> True
                   Trap  -> True
                   _     -> False

army :: Color -> Board -> [PieceAt]
army c br =  [(pieceAt sq br, sq) | sq <- pieceSquares br
                                  , colorOf (pieceAt sq br) == c]

colorOf :: (Color, a) -> Color
colorOf = fst


isColor :: Color -> (Color, a) -> Bool
isColor c = \x -> colorOf x == c

type Move = (Color, [Step])
data PlayState = PlayState {
  board     :: Board,
  moveNum   :: Int,
  toMove    :: Color,
  stepsLeft :: Int,
  history   :: [Move],
  future    :: [Move]
} deriving Show

initState = PlayState {
  board     = emptyBoard,
  moveNum   = 1,
  toMove    = Gold,
  stepsLeft = 4,
  history   = [],
  future    = []
}