1 module Board(
    2   Kind(King,Queen,Rook,Bishop,Knight,Pawn),
    3   Colour(Black,White), Piece, Square, Board, 
    4   showBoard, showPiece, showSquare,
    5   emptyBoard, pieceAt, rmPieceAt, putPieceAt,
    6   emptyAtAll, kingSquare, forcesColoured,
    7   colourOf, kindOf, opponent, onboard)  where
    8 
    9 import Char(toLower)
   10 
   11 data Kind = King | Queen | Rook | Bishop | Knight | Pawn deriving (Eq,Ord)
   12 
   13 data Colour = Black | White deriving (Eq,Ord,Read,Show)
   14 
   15 type Piece = (Colour,Kind)
   16 type Square = (Int,Int)
   17 
   18 data Board = Board
   19                [(Kind,Square)] -- white
   20                [(Kind,Square)] -- black
   21 
   22 showBoard bd =
   23         unlines (map showRank (reverse [1..8]))
   24         where
   25         showRank r = foldr consFile [] [1..8]
   26                 where
   27                 consFile f s =
   28                         case pieceAt bd (f,r) of
   29                         Nothing -> " -" ++ s
   30                         Just p  -> ' ': pieceToChar p : s
   31 
   32 pieceToChar :: Piece -> Char
   33 pieceToChar (Black,k) = kindToChar k
   34 pieceToChar (White,k) = toLower (kindToChar k)
   35 
   36 kindToChar :: Kind -> Char
   37 kindToChar k =
   38         case k of
   39         King   -> 'K'
   40         Queen  -> 'Q'
   41         Rook   -> 'R'
   42         Bishop -> 'B'
   43         Knight -> 'N'
   44         Pawn   -> 'P'
   45 
   46 showPiece :: Piece -> String
   47 showPiece (c,k) = [kindToChar k]
   48 
   49 showSquare :: Colour -> Square -> String
   50 showSquare c (x,y) =
   51         ["QR","QN","QB","Q","K","KB","KN","KR"] !! (x-1) ++
   52         show (  case c of
   53                 Black -> 9-y
   54                 White -> y )
   55 
   56 pieceAt :: Board -> Square -> Maybe Piece
   57 pieceAt (Board wkss bkss) sq =
   58         pieceAtWith White (pieceAtWith Black Nothing bkss) wkss
   59         where
   60         pieceAtWith c n [] = n
   61         pieceAtWith c n ((k,s):xs) = if s==sq then Just (c,k) else pieceAtWith c n xs
   62 
   63 emptyAtAll :: Board -> (Square->Bool) -> Bool
   64 emptyAtAll (Board wkss bkss) e =
   65         emptyAtAllAnd (emptyAtAllAnd True bkss) wkss
   66         where
   67         emptyAtAllAnd b []         = b
   68         emptyAtAllAnd b ((_,s):xs) = not (e s) && emptyAtAllAnd b xs
   69 
   70 rmPieceAt White sq (Board wkss bkss) = Board (rPa sq wkss) bkss
   71 rmPieceAt Black sq (Board wkss bkss) = Board wkss (rPa sq bkss)
   72 
   73 rPa sq (ks@(k,s):kss) = if s==sq then kss else ks : rPa sq kss
   74 
   75 putPieceAt sq (White,k) (Board wkss bkss) = Board ((k,sq):wkss) bkss
   76 putPieceAt sq (Black,k) (Board wkss bkss) = Board wkss ((k,sq):bkss)
   77 
   78 kingSquare :: Colour -> Board -> Square
   79 kingSquare White (Board kss _) = kSq kss
   80 kingSquare Black (Board _ kss) = kSq kss
   81 
   82 kSq ((King,s):_)   = s
   83 kSq (       _:kss) = kSq kss 
   84 
   85 opponent Black = White
   86 opponent White = Black
   87 
   88 colourOf :: Piece -> Colour
   89 colourOf (c,_) = c
   90 
   91 kindOf :: Piece -> Kind
   92 kindOf (_,k) = k
   93 
   94 onboard :: Square -> Bool
   95 onboard (p,q) = 1<=p && p<=8 && 1<=q && q<=8
   96 
   97 forcesColoured White (Board kss _) = kss
   98 forcesColoured Black (Board _ kss) = kss
   99 
  100 emptyBoard = Board [] []