%export othello othello :: [char] othello = "\nWelcome to OTHELLO by Suresh Mahtani\nDo you require" ++ " instructions? (Reply Y or N) - " ++ showInstructions ( read "/dev/tty" ) ++ showbd start ++ "White : " ++ process ( read "/dev/tty" ) W start startMoveList colour ::= B | W | X showcolour :: colour -> [char] showcolour B = "B" showcolour W = "W" showcolour X = error "colour X is unprintable" direction ::= N | NE | E | SE | S | SW | Wt | NW || One possible representation for the board as a list of lists of || locations. Other representations are possible, e.g. tuple of || tuples of locations, but these are considered later. board == [[ colour ]] location == ( num, num ) || The only two access procedures needed for the board data type are: || 1) bd: takes a coordinate tuple and the board and returns the || contents of the location at the supplied coordinates. || 2) put: takes a coordinate tuple and the board and a counter-value || (i.e. B or W) and sets the location specified by the || coordinates to the supplied value. bd (x, y) b = ( b ! ( x - 1 ) ) ! ( y - 1 ) put col (x, y) b = take (x-1) b ++ [ take (y-1) row ++ [col] ++ drop y row ] ++ drop x b where row = b ! (x-1) || The showbd function is the only 'pretty picture' function required || and is a general purpose display routine for the board data type. showbd :: board -> [char] showbd b = "\n8 " ++ f ( b!7 ) ++ "\n7 " ++ f ( b!6 ) ++ "\n6 " ++ f ( b!5 ) ++ "\n5 " ++ f ( b!4 ) ++ "\tBlacks " ++ show blk ++ "\n4 " ++ f ( b!3 ) ++ "\n3 " ++ f ( b!2 ) ++ "\tWhites " ++ show wht ++ "\n2 " ++ f ( b!1 ) ++ "\n1 " ++ f ( b!0 ) ++ "\n\n a b c d e f g h \n\n" where ( blk, wht ) = count ( concat b ) ( 0, 0 ) f [] = [] f (a:l) = ". " ++ f l , a = X = showcolour a ++ " " ++ f l , otherwise showmoves [] = "\n" showmoves [(x, y)] = [decode ( y + 96 )] ++ [decode ( x + 48 )] ++ "\n" showmoves ((x, y):p:l) = [decode ( y + 96 )] ++ [decode ( x + 48 )] ++ ", " ++ showmoves (p:l) || A collection of general purpose routines for reversing a counter, || and producing offsets for traversing the board in a given compass || direction, etc. have been written for clarity's sake. staticWeight move = 9, member [(1,1),(1,8),(8,1),(8,8)] move = 8, member [(1,3),(1,6),(3,1),(3,8),(6,1),(6,8),(8,3),(8,6)] move = 7, member [(3,3),(6,6),(3,6),(6,3)] move = 6, member [(3,4),(3,5),(4,3),(4,6),(5,3),(5,6),(6,4),(6,5)] move = 5, member [(2,3),(2,6),(3,2),(3,7),(6,2),(6,7),(7,3),(7,6)] move = 4, member [(2,4),(2,5),(4,2),(4,7),(5,2),(5,7),(7,4),(7,5)] move = 3, member [(1,4),(1,5),(4,1),(4,8),(5,1),(5,8),(8,4),(8,5)] move = 2, member [(1,2),(1,7),(2,1),(2,8),(7,1),(7,8),(8,2),(8,7)] move = 1, member [(2,2),(7,7),(2,7),(7,2)] move = 1, member [(5,4),(4,4),(5,5),(4,5)] move minWeight a [] = a minWeight a (b:l) = minWeight ( min a b ) l where min (x, y, wt) (x', y', wt') = (x, y, wt) , wt <= wt' = (x', y', wt') , otherwise getCR ('\n':l) = "Good Luck!!\n\n" disjoint [] set = True disjoint (a:set1) set2 = False , member set2 a = disjoint set1 set2 , otherwise count [] x = x count (a:b) ( u, v ) = count b ( 1 + u, v ) , a = B = count b ( u, 1 + v ) , a = W = count b ( u, v ) , otherwise revcol B = W revcol W = B revcol X = X offsets N = (-1, 0) offsets NE = (-1, 1) offsets E = (0, 1) offsets SE = (1, 1) offsets S = (1, 0) offsets SW = (1, -1) offsets Wt = (0, -1) offsets NW = (-1, -1) startMoveList = [(3,3),(6,6),(3,6),(6,3),(3,4),(3,5), (4,3),(4,6),(5,3),(5,6),(6,4),(6,5)] prompt B = "Black : " prompt W = "White : " withinBoard ( x, y ) = 0 < x < 9 & 0 < y < 9 nextLocation (x, y) dir = (x+dx, y+dy) where (dx, dy) = offsets dir directionList = [ N, NE, E, SE, S, SW, Wt, NW ] || coords --- Takes: a (marker) location on the board and a compass || direction. || Returns: a list of all the board coordinates that lie in || a given direction (supplied) starting from a || specified location (supplied). || Notes: uses ZF (comprehension) notation to produce a || rather elegant soluton using unification. coords loc dir = newloc : coords newloc dir , withinBoard newloc = [], otherwise where newloc = nextLocation loc dir || determine - Takes: a list of coordinate-sets (supplied by 'coords'), || a colour, and the current board. || Returns: a list of all the board coordinates that lie in || a given direction (supplied) starting from a || specified location (supplied). || Notes: uses ZF (comprehension) notation to produce a || rather elegant soluton using unification. determine l col b = foldr (++) [] (map (test []) l) where test l' [] = [] test l' (p:l) = test (p:l') l , col' = revcol col = l' , col' = col = [] , otherwise where col' = bd p b capture loc col b = determine [ coords loc dir | dir <- directions loc ] col b where directions (x, y) = [ N, NE, E ] , 6 colour -> board -> board playmove move col b = flip (capture move col b) (put col move b) where flip [] b = b flip (move:l) b = flip l (put col move b) legalMoves col b f = [ move | move <- f ; # capture move col b ~= 0 ] legalMoves2 col b f = [ (x, y, wt) | (x, y) <- f ; wt <- [ staticWeight (x, y) ] ; # capture (x, y) col b ~= 0 ] update :: [location] -> location -> board -> [location] update f move b = mkset ( f ++ [ loc | dir <- directionList ; loc <- [ nextLocation move dir ] ; withinBoard loc ; bd loc b = X ] ) -- [move] showInstructions (a:'\n':l) = "\n\n" ++ "Othello: instructions are not available in this account.\n" ++ "Sorry!\n" ++ "Press RETURN to start the game.\n" ++ getCR l , a = 'Y' \/ a = 'y' = "\n" , otherwise evaluate col b = sum [ staticWeight (u, v) | u <- [1..8] ; v <- [1..8] ; bd (u, v) b = col ] - sum [ staticWeight (u, v) | u <- [1..8] ; v <- [1..8] ; bd (u, v) b = revcol col ] bestmove col b f = move where ( value, move : rest ) = alpha_beta 0 1000 (- 1000 ) ( b, col ) f alpha_beta :: num -> num -> num -> ( board, colour ) -> [ location ] -> ( num, [location]) alpha_beta depth alpha beta ( b, col ) f = (evaluate col b , []), isdeepenough (b, col ) depth = (evaluate col b, [] ), moves = [] = analysemoves depth alpha beta (b, col) moves [ hd moves ] f, otherwise where moves = legalMoves col b f analysemoves :: num -> num -> num -> ( board, colour ) -> [location] -> [location] -> [location] -> (num, [location]) analysemoves depth alpha beta (b, col) (first:rest) bestsofar f = (beta', bestsofar') , beta' >= alpha = analysemoves depth alpha beta' (b, col) rest bestsofar' f, otherwise where ( value, moves ) = alpha_beta (depth + 1) (-beta) (-alpha) ((playmove first col b ), revcol col ) (update f first b ) ( beta', bestsofar') = ( -value, ( first : moves ) ) , -value > beta = ( beta, bestsofar ), otherwise analysemoves depth alpha beta (b, col) [] bestsofar f = ( beta, bestsofar ) isdeepenough (b, col) depth = depth >= standardply process l col b f = "\rBLACK HAS WON THE GAME !!!!!!\n\n\n" , f = [] & blk > wht = "\rWHITE HAS WON THE GAME !!!!!!\n\n\n" , f = [] & wht > blk = "\rIT'S A DRAW !!!!!!\n\n\n" , f = [] & wht = blk = "CAN'T PLAY, SO PASSES ...\n" ++ prompt ( revcol col ) ++ process l ( revcol col ) b f , # f < 16 & legalMoves col b f = [] = " Thinking, please wait...\rWhite : " ++ [decode ( y + 96 )] ++ [decode ( x + 48 )] ++ " \n" ++ showbd b' ++ prompt B ++ process l B b' ( update f (x, y) b ) , col = W where (x, y) = bestmove W b f b' = playmove (x, y) W b ( blk, wht ) = count ( concat b ) ( 0, 0 ) process (a:'\n':l) col b f = "\nMOVES AVAILABLE = " ++ showmoves ( legalMoves col b f ) ++ "\n" ++ prompt col ++ process l col b f , a = 'm' \/ a = 'M' = "\n\nTHANK YOU FOR PLAYING OTHELLO.\n\n\n" , a = 'q' \/ a = 'Q' process (a:c:d:l) B b f = "NOT A BOARD LOCATION! TRY AGAIN ...\n" ++ prompt B ++ process l B b f , ~ ( '0'