%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<x<9 & 0<y<3
		= [ N, NE, E, SE, S ]		  , 2<x<7 & 0<y<3
		= [ E, SE, S ]			  , 0<x<3 & 0<y<3
		= [ E, SE, S, SW, Wt ]		  , 0<x<3 & 2<y<7
		= [ S, SW, Wt ]			  , 0<x<3 & 6<y<9
		= [ N, S, SW, Wt, NW ]		  , 2<x<7 & 6<y<9
		= [ N, Wt, NW ]			  , 6<x<9 & 6<y<9
		= [ N, NE, E, Wt, NW ]		  , 6<x<9 & 2<y<7
		= [ N, NE, E, SE, S, SW, Wt, NW ] , otherwise

playmove :: location -> 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'<c<'9' & '`'<a<'i' )
	= "ALREADY OCCUPIED!  TRY AGAIN ...\n" ++ prompt B 
	  ++ process l B b f , bd move b ~= X 
	= "DOESN'T CAPTURE ANYTHING!  TRY AGAIN ...\n" ++ prompt B 
	  ++ process l B b f , capture move B b = []
 	= showbd b' ++ prompt W
	  ++ process l W b' ( update f move b ) , otherwise
 	  where 
	  move = ( code c - 48, code a - 96 ) 
	  b' = playmove move B b 

start =   [[X, X, X, X, X, X, X, X],
 	   [X, X, X, X, X, X, X, X],
	   [X, X, X, X, X, X, X, X],
	   [X, X, X, B, W, X, X, X],
	   [X, X, X, W, B, X, X, X],
	   [X, X, X, X, X, X, X, X],
	   [X, X, X, X, X, X, X, X],
	   [X, X, X, X, X, X, X, X]]

standardply = 2
