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 [] []