ghc/tests/programs/andy_cherry/DataTypes.lhs

   1 > module DataTypes where
   2
   3 > import GenUtils
   4 > import Array -- 1.3
   5 > import Ix
   6 > import Char
   7 > infix 1 =: -- 1.3
   8 > (=:) a b = (a,b)
   9
  10 %------------------------------------------------------------------------------
  11
  12 The `presentable' class, my own co-class for Text
  13
  14 > class Presentable a where
  15 >       userFormat :: a -> String       -- in prefered display format
  16
  17 Defaults, in terms of each other
  18
  19 And the default for lists.
  20
  21 > instance (Presentable a) => Presentable [a] where
  22 >     userFormat xs = unlines (map userFormat xs)
  23
  24 %------------------------------------------------------------------------------
  25  Here are all the pieces allowed in chess.
  26
  27 > data Piece
  28 >       = King
  29 >       | Queen
  30 >       | Rook
  31 >       | Knight
  32 >       | Bishop
  33 >       | Pawn deriving(Eq)
  34
  35 > instance Presentable Piece where
  36 >   userFormat King   = "K"
  37 >   userFormat Queen  = "Q"
  38 >   userFormat Rook   = "R"
  39 >   userFormat Knight = "N"
  40 >   userFormat Bishop = "B"
  41 >   userFormat Pawn   = "P"
  42
  43
  44 %------------------------------------------------------------------------------
  45
  46 > castleK = "O-O"
  47 > castleQ = "O-O-O"
  48
  49 %------------------------------------------------------------------------------
  50
  51 Here are the two sides.
  52
  53 > data Colour = Black | White deriving (Eq)
  54
  55 > instance Presentable Colour where
  56 >       userFormat White = "White"
  57 >       userFormat Black = "Black"
  58
  59 > changeColour :: Colour -> Colour
  60 > changeColour White = Black
  61 > changeColour Black = White
  62
  63 %------------------------------------------------------------------------------
  64
  65 Now the ranks and files.
  66
  67 > type ChessRank = Int  -- 1-8
  68 > type ChessFile = Int  -- 1-8
  69
  70 > type BoardPos = (ChessFile,ChessRank) -- ChessFile (0-7) and ChessRank (0-7)
  71 > type ExBoardPos = (Maybe ChessFile,Maybe ChessRank)
  72
  73 > extendBP :: BoardPos -> ExBoardPos
  74 > extendBP (a,b) = (Just a,Just b)
  75
  76 > compExBPandBP :: ExBoardPos -> BoardPos -> Bool
  77 > compExBPandBP (a,b) (c,d) = a `cmp` c && b `cmp` d
  78 >    where
  79 >       cmp Nothing  _ = True
  80 >       cmp (Just x) y = x == y
  81
  82 > userFormatBoardPos :: BoardPos -> String
  83 > userFormatBoardPos (f,r) = userFormatFile f ++ userFormatRank r
  84 > userFormatExBoardPos :: ExBoardPos -> String
  85 > userFormatExBoardPos (Just f,Just r)  = userFormatFile f ++ userFormatRank r
  86 > userFormatExBoardPos (Just f,Nothing) = userFormatFile f
  87 > userFormatExBoardPos (Nothing,Just r) = userFormatRank r
  88 > userFormatExBoardPos _ = ""
  89 > userFormatRank r = [toEnum (r + 48)]
  90 > userFormatFile f = [toEnum (f + 96)]
  91
  92 %------------------------------------------------------------------------------
  93
  94 These are the components of a move.
  95
  96 > data MoveTok
  97 >       = PieceTok Piece        -- Q,K,R,B,N
  98 >       | RankTok ChessRank     -- 1 .. 8
  99 >       | FileTok ChessFile     -- a .. h
 100 >       | PartCastleTok         -- 0 | O | o
 101 >       | CaptureTok            -- x
 102 >       | MoveToTok             -- -
 103 >       | QueensWith            -- =
 104 >       | CheckTok              -- +
 105 >       | MateTok               -- #
 106
 107 > charToMoveTok 'Q' = Just (PieceTok Queen)
 108 > charToMoveTok 'K' = Just (PieceTok King)
 109 > charToMoveTok 'R' = Just (PieceTok Rook)
 110 > charToMoveTok 'B' = Just (PieceTok Bishop)
 111 > charToMoveTok 'N' = Just (PieceTok Knight)
 112 > charToMoveTok '1' = Just (RankTok 1)
 113 > charToMoveTok '2' = Just (RankTok 2)
 114 > charToMoveTok '3' = Just (RankTok 3)
 115 > charToMoveTok '4' = Just (RankTok 4)
 116 > charToMoveTok '5' = Just (RankTok 5)
 117 > charToMoveTok '6' = Just (RankTok 6)
 118 > charToMoveTok '7' = Just (RankTok 7)
 119 > charToMoveTok '8' = Just (RankTok 8)
 120 > charToMoveTok 'a' = Just (FileTok 1)
 121 > charToMoveTok 'b' = Just (FileTok 2)
 122 > charToMoveTok 'c' = Just (FileTok 3)
 123 > charToMoveTok 'd' = Just (FileTok 4)
 124 > charToMoveTok 'e' = Just (FileTok 5)
 125 > charToMoveTok 'f' = Just (FileTok 6)
 126 > charToMoveTok 'g' = Just (FileTok 7)
 127 > charToMoveTok 'h' = Just (FileTok 8)
 128 > charToMoveTok '0' = Just (PartCastleTok)
 129 > charToMoveTok 'O' = Just (PartCastleTok)
 130 > charToMoveTok 'o' = Just (PartCastleTok)
 131 > charToMoveTok 'x' = Just (CaptureTok)
 132 > charToMoveTok '-' = Just (MoveToTok)
 133 > charToMoveTok '=' = Just (QueensWith)
 134 > charToMoveTok '+' = Just (CheckTok)
 135 > charToMoveTok '#' = Just (MateTok)
 136 > charToMoveTok _   = Nothing
 137
 138 %------------------------------------------------------------------------------
 139
 140 > data Quantum
 141 >       = QuantumMove   String          -- Short Description of move
 142 >                       String          -- Check or Mate (+ or #)
 143 >                       String          -- !,??,?!, etc
 144 >                       Board           -- Snap Shot of Board
 145 >       | QuantumNAG Int                -- !,??,?! stuff
 146 >       | QuantumComment [String]       -- { comment }
 147 >       | QuantumResult String          -- 1-0, etc (marks end of game)
 148 >       | QuantumAnalysis [Quantum]     -- ( analysis )
 149 >       | QuantumPrintBoard             -- {^D}
 150
 151 > instance Presentable Quantum where
 152 >       userFormat (QuantumMove mv ch ann _)
 153 >               = mv ++ ch ++ ann
 154 >       userFormat (QuantumNAG nag) = "$" ++ show nag
 155 >       userFormat (QuantumComment comment)
 156 >               = "[" ++ unwords comment ++ "]"
 157 >       --userFormat (QuantumNumber num)  = userFormat num
 158 >       userFormat (QuantumResult str) = str
 159 >       userFormat (QuantumAnalysis anal) =
 160 >               "( " ++ unwords (map userFormat anal) ++ " )"
 161
 162 %------------------------------------------------------------------------------
 163
 164 > data Result = Win | Draw | Loss | Unknown
 165
 166 > instance Presentable Result where
 167 >       userFormat Win     = "1-0"
 168 >       userFormat Draw    = "1/2-1/2"
 169 >       userFormat Loss    = "0-1"
 170 >       userFormat Unknown = "*"
 171
 172 > mkResult :: String -> Result
 173 > mkResult "1-0"     = Win
 174 > mkResult "1/2-1/2" = Draw
 175 > mkResult "0-1"     = Loss
 176 > mkResult _         = Unknown
 177
 178 %------------------------------------------------------------------------------
 179
 180 > data TagStr = TagStr String String
 181
 182 > instance Presentable TagStr where
 183 >       userFormat (TagStr tag str) = "[" ++ tag ++ " \"" ++ str ++ "\"]"
 184
 185 > getTagStr :: String -> String -> [TagStr] -> String
 186 > getTagStr str def [] = def
 187 > getTagStr str def (TagStr st ans:rest)
 188 >               | str == st = ans
 189 >               | otherwise = getTagStr str def rest
 190
 191 > getHeaderInfo
 192 >       :: [TagStr]
 193 >       -> (
 194 >               String,         -- Date
 195 >               String,         -- Site
 196 >               Maybe Int,      -- Game Number
 197 >               Result,         -- W/D/L
 198 >               String,         -- White
 199 >               String,         -- Black
 200 >               String          -- Opening
 201 >       )
 202 > getHeaderInfo tags = (
 203 >               date,
 204 >               site,
 205 >               gameno,
 206 >               result,
 207 >               white `par` whiteElo,
 208 >               black `par` blackElo,
 209 >               opening)
 210 >   where
 211 >       date   = case getTagStr "Date" "?" tags of
 212 >                  [a,b,c,d,'.','?','?','.','?','?'] -> [a,b,c,d]
 213 >                  [a,b,c,d,'.',x,y,'.','?','?'] -> getMonth [x,y] ++ " " ++ [a,b,c,d]
 214 >                  def -> "?"
 215 >       site     = getTagStr "Site" "?" tags
 216 >       gameno   = case getTagStr "GameNumber" "" tags of
 217 >                       xs | all isDigit xs && not (null xs) -> Just (read xs)
 218 >                       _ -> Nothing
 219 >       result   = mkResult (getTagStr "Result" "*" tags)
 220 >       white    = cannon (getTagStr "White" "?" tags)
 221 >       whiteElo = getTagStr "WhiteElo" "" tags
 222 >       black    = cannon (getTagStr "Black" "?" tags)
 223 >       blackElo = getTagStr "BlackElo" "" tags
 224 >       opening  = getOpening (getTagStr "ECO" "" tags)
 225
 226 >       par xs "" = xs
 227 >       par xs ys = xs ++ " (" ++ ys ++ ")"
 228
 229 >       getMonth "01" = "Jan"
 230 >       getMonth "02" = "Feb"
 231 >       getMonth "03" = "Mar"
 232 >       getMonth "04" = "Apr"
 233 >       getMonth "05" = "May"
 234 >       getMonth "06" = "Jun"
 235 >       getMonth "07" = "Jul"
 236 >       getMonth "08" = "Aug"
 237 >       getMonth "09" = "Sep"
 238 >       getMonth "10" = "Oct"
 239 >       getMonth "11" = "Nov"
 240 >       getMonth "12" = "Dec"
 241
 242 >       cannon name = case span (/= ',') name of
 243 >                       (a,[',',' ',b]) -> b : ". " ++ a
 244 >                       (a,[',',b]) -> b : ". " ++ a
 245 >                       (a,',':' ':b) -> b ++ " " ++ a
 246 >                       (a,',':b) -> b ++ " " ++ a
 247 >                       _ -> name
 248
 249
 250 > getOpening eco@[a,b,c] |  a >= 'A' && a <= 'E' && isDigit b && isDigit c
 251 >    = getOpenName ((fromEnum a - fromEnum 'A') * 100
 252 >               + (fromEnum b - fromEnum '0') * 10
 253 >               + (fromEnum c - fromEnum '0')) ++ " " ++ eco
 254 > getOpening other = other
 255
 256 > getOpenName :: Int -> String
 257 > getOpenName eco
 258 >       | otherwise = "Foo"
 259 > {-
 260 >       | eco == 000 = "Irregular Openings"
 261 >       | eco == 001 = "Larsen Opening"
 262 >       | eco == 002 = "From's Gambit and Bird's Open"
 263 >       | eco == 003 = "Bird's Opening"
 264 >       | eco == 004 = "Dutch System"
 265 >       | eco == 005 = "Transposition to various Open"
 266 >       | eco == 006 = "Zukertort Opening"
 267 >       | eco >= 007 && eco <= 008
 268 >                    = "Barcza System"
 269 >       | eco == 009 = "Reti Opening"
 270 >       | eco == 010 = "Variations of Dutch, QI, KI"
 271 >       | eco >= 011 && eco <= 014
 272 >                    = "Reti Opening"
 273 >       | eco == 015 = "English counter King's Fianch"
 274 >       | eco >= 016 && eco <= 039
 275 >                    = "English Opening"
 276 >       | eco == 040 = "Unusual replies to 1.d4"
 277 >       | eco == 041 = "Modern Defence counter 1.d4"
 278 >       | eco == 042 = "Modern Defence with c2-c4"
 279 >       | eco >= 043 && eco <= 044
 280 >                    = "Old Benoni"
 281 >       | eco == 045 = "Queen's Pawn-Trompowski Var"
 282 >       | eco == 046 = "Queen's Pawn Opening"
 283 >       | eco == 047 = "Queen's Indian"
 284 >       | eco >= 048 && eco <= 049
 285 >                    = "King's Indian"
 286 >       | eco == 050 = "Queen's Indian"
 287 >       | eco >= 051 && eco <= 052
 288 >                    = "Budapest Defence"
 289 >       | eco >= 053 && eco <= 056
 290 >                    = "Old Indian Defence"
 291 >       | eco >= 057 && eco <= 059
 292 >                    = "Volga-Benko Gambit"
 293 >       | eco >= 060 && eco <= 079
 294 >                    = "Benoni"
 295 >       | eco >= 080 && eco <= 099
 296 >                    = "Dutch Defence"
 297 >       | eco == 100 = "Owen Def, Nimzowitsch Def"
 298 >       | eco == 101 = "Center Counter"
 299 >       | eco >= 102 && eco <= 105
 300 >                    = "Alekhine's Defence"
 301 >       | eco == 106 = "Modern Defence"
 302 >       | eco >= 107 && eco <= 109
 303 >                    = "Pirc Defence"
 304 >       | eco >= 110 && eco <= 119
 305 >                    = "Caro-Kann Defence"
 306 >       | eco >= 120 && eco <= 199
 307 >                    = "Sicilian Defence"
 308 >       | eco >= 200 && eco <= 219
 309 >                    = "French Defence"
 310 >       | eco == 220 = "Rare moves"
 311 >       | eco == 221 = "Nordic Gambit"
 312 >       | eco == 222 = "Central Gambit"
 313 >       | eco >= 223 && eco <= 224
 314 >                    = "Bishop's Opening"
 315 >       | eco >= 225 && eco <= 229
 316 >                    = "Vienna Game"
 317 >       | eco == 230 = "King's Gambit Declined"
 318 >       | eco >= 231 && eco <= 232
 319 >                    = "Falkbeer Counter Gambit"
 320 >       | eco >= 233 && eco <= 239
 321 >                    = "King's Gambit"
 322 >       | eco == 240 = "Latvian Gambit"
 323 >       | eco == 241 = "Philidor Defence"
 324 >       | eco >= 242 && eco <= 243
 325 >                    = "Russian Defence-Petrov"
 326 >       | eco >= 244 && eco <= 245
 327 >                    = "Scotch Opening"
 328 >       | eco >= 246 && eco <= 249
 329 >                    = "Four Knight's"
 330 >       | eco == 250 = "Italian Opening"
 331 >       | eco >= 251 && eco <= 252
 332 >                    = "Evans Gambit"
 333 >       | eco >= 253 && eco <= 254
 334 >                    = "Italian Opening"
 335 >       | eco >= 255 && eco <= 259
 336 >                    = "Two Knight's Play"
 337 >       | eco >= 260 && eco <= 299
 338 >                    = "Ruy Lopez"
 339 >       | eco >= 300 && eco <= 305
 340 >                    = "Queen Pawn's Opening"
 341 >       | eco >= 306 && eco <= 307
 342 >                    = "Queen's Gambit"
 343 >       | eco >= 308 && eco <= 309
 344 >                    = "Albins Counter Gambit"
 345 >       | eco >= 310 && eco <= 319
 346 >                    = "Slav Defence"
 347 >       | eco >= 320 && eco <= 329
 348 >                    = "Queen's Gambit Accepted"
 349 >       | eco >= 330 && eco <= 369
 350 >                    = "Queen's Gambit"
 351 >       | eco >= 370 && eco <= 399
 352 >                    = "Gruenfeld Defence"
 353 >       | eco >= 400 && eco <= 409
 354 >                    = "Catalan"
 355 >       | eco == 410 = "Blumenfeld Gambit"
 356 >       | eco >= 411 && eco <= 419
 357 >                    = "Queen's Indian"
 358 >       | eco >= 420 && eco <= 459
 359 >                    = "Nimzo Indian"
 360 >       | eco >= 460 && eco <= 499
 361 >                    = "King's Indian"
 362 > -}
 363
 364 %------------------------------------------------------------------------------
 365
 366 > data MoveNumber = MoveNumber Int Colour
 367 > instance Presentable MoveNumber where
 368 >       userFormat (MoveNumber n White)  = show n ++ "."
 369 >       userFormat (MoveNumber n Black)  = show n ++ "..."
 370
 371 > initMoveNumber = MoveNumber 1 White
 372 > incMove (MoveNumber i White) = MoveNumber i Black
 373 > incMove (MoveNumber i Black) = MoveNumber (i+1) White
 374 > decMove (MoveNumber i White) = MoveNumber (i-1) Black
 375 > decMove (MoveNumber i Black) = MoveNumber i White
 376 > getMoveColour :: MoveNumber -> Colour
 377 > getMoveColour (MoveNumber _ c) = c
 378
 379 %------------------------------------------------------------------------------
 380
 381 > data Token
 382
 383 Both first and second level.
 384
 385 >       = StringToken   String
 386 >       | AsterixToken
 387 >       | LeftABToken           -- ??
 388 >       | RightABToken          -- ??
 389 >       | NAGToken      Int     -- `normal' NAGS
 390 >       | NAGAnnToken   Int String
 391 >                               -- `special' move annotating NAGS (1-6)
 392 >       | SymbolToken   String
 393 >       | CommentToken  [String] -- list of words
 394 >       | LeftSBToken
 395 >       | RightSBToken
 396 >       | LeftRBToken
 397 >       | RightRBToken
 398 >       | IntToken      Int
 399 >       | PeriodToken
 400
 401 Second level Token, as produced by the parser.
 402
 403 >       | AnalToken     [Token]
 404
 405 > instance Presentable Token where
 406 >       userFormat (StringToken str) = show str
 407 >       userFormat (IntToken n)      = show n
 408 >       userFormat (PeriodToken)     = "."
 409 >       userFormat (AsterixToken)    = "*"
 410 >       userFormat (LeftSBToken)     = "["
 411 >       userFormat (RightSBToken)    = "]"
 412 >       userFormat (LeftRBToken)     = "("
 413 >       userFormat (RightRBToken)    = ")"
 414 >       userFormat (LeftABToken)     = "<"
 415 >       userFormat (RightABToken)    = ">"
 416 >       userFormat (NAGToken i)      = "$" ++ show i
 417 >       userFormat (NAGAnnToken i s) = "$" ++ show i
 418 >       userFormat (SymbolToken str) = str
 419 >       userFormat (CommentToken str) = "{" ++ unwords str ++ "}"
 420 >       userFormat (AnalToken toks) = "( " ++ unwords (map userFormat toks)
 421 >                                       ++ " )"
 422
 423 %------------------------------------------------------------------------------
 424
 425 The Parser Emits a list of these.
 426
 427 > data Game a = Game [TagStr] [a]
 428
 429 > type AbsGame = Game Token
 430 > type RealGame = Game Quantum
 431
 432 > instance (Presentable a) => Presentable (Game a) where
 433 >       userFormat (Game tags toks) =
 434 >               unlines (map userFormat tags
 435 >                  ++ formatText 78 (map userFormat toks))
 436
 437 %------------------------------------------------------------------------------
 438
 439 Here are the moves that actually can be played,
 440 all in the context of a particular board.
 441
 442 > data PlayMove
 443 >       = PlayMove
 444 >               Piece           -- with this
 445 >               BoardPos        -- from here
 446 >               BoardPos        -- to here (possibly capturing)
 447 >               SpecialMove
 448
 449 > mkPlayMove p f t = PlayMove p f t NothingSpecial
 450
 451 > data SpecialMove
 452 >       = NothingSpecial
 453 >       | BigPawnMove           -- allows e.p. next move
 454 >       | Queening Piece        -- queen with this
 455 >       | EnPassant             -- capture e.p.
 456 >    deriving (Eq)
 457
 458 > instance Presentable PlayMove where
 459 >       userFormat (PlayMove piece pos pos' sp) =
 460 >               userFormat piece ++
 461 >               userFormatBoardPos pos ++ "-" ++
 462 >               userFormatBoardPos pos' ++
 463 >               userFormat sp
 464
 465 > instance Presentable SpecialMove where
 466 >       userFormat (NothingSpecial) = ""
 467 >       userFormat (BigPawnMove) = "{b.p.m.}"
 468 >       userFormat (Queening p) = "=" ++ userFormat p
 469 >       userFormat (EnPassant) = "e.p."
 470
 471 > extractSrcFromPlayMove :: PlayMove -> BoardPos
 472 > extractSrcFromPlayMove (PlayMove _ src _ _) = src
 473
 474 > extractDestFromPlayMove :: PlayMove -> BoardPos
 475 > extractDestFromPlayMove (PlayMove _ _ dest _)       = dest
 476
 477 > extractSpecialFromPlayMove :: PlayMove -> SpecialMove
 478 > extractSpecialFromPlayMove (PlayMove _ _ _ sp)       = sp
 479
 480
 481 %------------------------------------------------------------------------------
 482
 483 Now the representation of the board itself.
 484
 485 > data BoardSquare
 486 >       = VacantSq
 487 >       | WhitesSq Piece
 488 >       | BlacksSq Piece
 489
 490 > data SquareContent
 491 >       = Vacant
 492 >       | Friendly
 493 >       | Baddy
 494 >       | OffBoard deriving (Eq)
 495
 496 > instance Presentable SquareContent where
 497 >       userFormat Vacant   = "."
 498 >       userFormat Friendly = "*"
 499 >       userFormat Baddy    = "#"
 500 >       userFormat OffBoard = "?"
 501
 502
 503 %------------------------------------------------------------------------------
 504
 505 A Static representation of what the current placement of pieces is.
 506
 507 > data Board
 508 >       = Board (Array BoardPos BoardSquare)
 509 >               MoveNumber              -- current player & and move
 510 >               (Maybe ChessFile)       -- e.p. possibilties.
 511
 512 This is Christmas for foldr/build !
 513
 514 > displayBoard :: Colour -> Board -> [String]
 515 > displayBoard col (Board arr _ ep) =
 516 >       ([cjustify 33 (userFormat (changeColour col)),""] ++
 517 >       [
 518 >   concat [ (case (even x,even y) of
 519 >       (True,True)   -> showSq (x `div` 2) (y `div` 2)
 520 >       (False,False) -> "+"
 521 >       (True,False)  -> "---"
 522 >       (False,True)  -> (if x == 17 then "| " ++ show (y `div` 2) else "|"))
 523 >               | x <- [1..17::Int]]
 524 >               | y <- reverse [1..17::Int]] ++
 525 >       [concat [ "  " ++ [x] ++ " " | x <- "abcdefgh" ]] ++
 526 >       ["",cjustify 33 (userFormat col),"",
 527 >               case ep of
 528 >                Nothing -> ""
 529 >                Just p -> "EnPassant:" ++ userFormatFile p ])
 530 >    where
 531 >       make n str = take n (str ++ repeat ' ')
 532 >       lookupPlace :: Int -> Int -> BoardSquare
 533 >       lookupPlace x' y' = arr ! (x',y')
 534
 535 >       bold :: String -> String
 536 >       bold str = map toLower str
 537
 538 >       showSq x y = case lookupPlace x y of
 539 >               VacantSq     -> [if_dot,if_dot,if_dot]
 540 >               (WhitesSq p) -> (if_dot : userFormat p) ++ [if_dot]
 541 >               (BlacksSq p)  -> (if_dot : bold (userFormat p)) ++ [if_dot]
 542 >          where
 543 >               if_dot = if (x - y) `rem` 2 == 0 then '.' else ' '
 544
 545 > instance Presentable Board where
 546 >   userFormat = unlines . displayBoard White
 547
 548 > boardSize :: (BoardPos,BoardPos)
 549 > boardSize = ((1,1),(8,8))
 550
 551
 552 This uses forsyth notation.
 553
 554 > buildBoard :: String -> Board
 555 > buildBoard str = Board brd initMoveNumber Nothing
 556 >    where
 557 >       brd = array boardSize (zipWith (=:) allSq (mkPieces str))
 558 >       allSq = [ (x,y) | y <- reverse [1..8::Int],x <- [1..8::Int]]
 559 >       mkPieces :: String -> [BoardSquare]
 560 >       mkPieces (hd:rest) | hd `elem` "KQRNBPkqrnbp" = pc : mkPieces rest
 561 >          where
 562 >               pc = case hd of
 563 >                       'K' -> WhitesSq King
 564 >                       'Q' -> WhitesSq Queen
 565 >                       'R' -> WhitesSq Rook
 566 >                       'N' -> WhitesSq Knight
 567 >                       'B' -> WhitesSq Bishop
 568 >                       'P' -> WhitesSq Pawn
 569 >                       'k' -> BlacksSq King
 570 >                       'q' -> BlacksSq Queen
 571 >                       'r' -> BlacksSq Rook
 572 >                       'n' -> BlacksSq Knight
 573 >                       'b' -> BlacksSq Bishop
 574 >                       'p' -> BlacksSq Pawn
 575 >       mkPieces ('/':rest) = mkPieces rest
 576 >       mkPieces (c:rest) | isDigit c =
 577 >               case span isDigit rest of
 578 >                 (cs,rest') -> take (read (c:cs)) (repeat VacantSq)
 579 >                                       ++ mkPieces rest'
 580 >       mkPieces [] = []
 581
 582 > startBoard :: Board   -- the uni before the big bang.
 583 > startBoard = buildBoard "rnbqkbnr/pppppppp/32/PPPPPPPP/RNBQKBNR"
 584
 585 > lookupSquare :: Colour -> BoardSquare -> SquareContent
 586 > lookupSquare _      VacantSq    = Vacant
 587 > lookupSquare White (WhitesSq p) = Friendly
 588 > lookupSquare Black (WhitesSq p) = Baddy
 589 > lookupSquare White (BlacksSq p) = Baddy
 590 > lookupSquare Black (BlacksSq p) = Friendly
 591
 592 > lookupBoard :: Board -> BoardPos -> SquareContent
 593 > lookupBoard (Board arr col _) pos =
 594 >       if inRange boardSize pos
 595 >       then lookupSquare (getMoveColour col) (arr ! pos)
 596 >       else OffBoard
 597
 598 > lookupBoardSquare :: Board -> BoardPos -> BoardSquare
 599 > lookupBoardSquare (Board arr _ _) pos = arr ! pos
 600
 601 > getSquarePiece :: BoardSquare -> Maybe Piece
 602 > getSquarePiece VacantSq    = Nothing
 603 > getSquarePiece (WhitesSq p) = Just p
 604 > getSquarePiece (BlacksSq p) = Just p
 605
 606 > lookupBoardPiece :: Board -> BoardPos -> Maybe Piece
 607 > lookupBoardPiece (Board arr _ _) pos =
 608 >     case arr ! pos of
 609 >       VacantSq -> Nothing
 610 >       WhitesSq piece -> Just piece
 611 >       BlacksSq piece -> Just piece
 612
 613 This will improve sharing, by
 614
 615 > {-# INLINE mkColBoardSq #-}
 616 > mkColBoardSq :: Colour -> Piece -> BoardSquare
 617 > mkColBoardSq White p = WhitesSq p
 618 > mkColBoardSq Black p = BlacksSq p
 619
 620 > getBoardColour (Board _ mv _) = getMoveColour mv
 621