Commit d8ee8009 authored by Simon Marlow's avatar Simon Marlow

changes for 2009 Haskell Symposium paper on ThreadScope

parent ae86c360
-- Time-stamp: <2008-10-21 13:26:36 simonmar>
-----------------------------------------------------------------------------
{-# LANGUAGE BangPatterns #-}
module Board where
import Wins
import Data.List
import Control.Parallel
import Control.Parallel.Strategies
boardDim = 4
type Board = [Row]
type Row = [Piece]
data Piece = X | O | Empty deriving Eq
showBoard :: Board -> String
showBoard [r1,r2,r3] = showRow r1 ++ "\n------\n" ++
showRow r2 ++ "\n------\n" ++
showRow r3 ++ "\n\n"
data Piece = X | O | Empty deriving (Eq,Show)
showRow [p1,p2,p3] = showPiece p1 ++ "|" ++ showPiece p2 ++ "|" ++ showPiece p3
isEmpty Empty = True
isEmpty _ = False
showBoard :: Board -> String
showBoard board = intercalate "\n--------\n" (map showRow board) ++ "\n"
where showRow r = intercalate "|" (map showPiece r)
showPiece :: Piece -> String
showPiece X = "X"
showPiece O = "O"
showPiece Empty = " "
placePiece :: Piece -> Board -> (Int,Int) -> [Board]
placePiece p board pos | not (empty pos board) = []
placePiece p [r1,r2,r3] (1,x) = [[insert p r1 x,r2,r3]]
placePiece p [r1,r2,r3] (2,x) = [[r1,insert p r2 x,r3]]
placePiece p [r1,r2,r3] (3,x) = [[r1,r2,insert p r3 x]]
insert :: Piece -> Row -> Int -> Row
insert p [p1,p2,p3] 1 = [p,p2,p3]
insert p [p1,p2,p3] 2 = [p1,p,p3]
insert p [p1,p2,p3] 3 = [p1,p2,p]
placePiece :: Piece -> Board -> (Int,Int) -> Board
placePiece new board pos
= [[ if (x,y) == pos then new else old
| (x,old) <- zip [1..] row ]
| (y,row) <- zip [1..] board ]
empty :: (Int,Int) -> Board -> Bool
empty (1,x) [r1,r2,r3] = empty' x r1
empty (2,x) [r1,r2,r3] = empty' x r2
empty (3,x) [r1,r2,r3] = empty' x r3
empty (x,y) board = isEmpty ((board !! (y-1)) !! (x-1))
empty' :: Int -> Row -> Bool
empty' 1 [Empty,_,_] = True
empty' 2 [_,Empty,_] = True
empty' 3 [_,_,Empty] = True
empty' _ _ = False
fullBoard b = all (not.isEmpty) (concat b)
fullBoard b = and (parMap rnf notEmpty (concat b))
where
notEmpty x = not (x==Empty)
newPositions :: Piece -> Board -> [Board]
newPositions piece board =
-- [ placePiece piece board (x,y) | (x,y) <- empties board ]
goRows piece id board
--newPositions :: Piece -> Board -> [Board]
newPositions piece board = concat (parMap rwhnf (placePiece piece board)
[(x,y) | x<-[1..3],y <-[1..3]])
goRows p rowsL [] = []
goRows p rowsL (row:rowsR)
= goRow p rowsL id row rowsR ++ goRows p (rowsL . (row:)) rowsR
initialBoard :: Board
initialBoard = [[Empty,Empty,Empty],
[Empty,Empty,Empty],
[Empty,Empty,Empty]]
data Evaluation = XWin | OWin | Score Int deriving (Show,Eq)
{- OLD: partain
instance Eq Evaluation where
XWin == XWin = True
OWin == OWin = True
(Score i1) == (Score i2) = i1 == i2
_ == _ = False
a /= b = not (a == b)
instance Text Evaluation where
showsPrec d XWin = showString "XWin"
showsPrec d OWin = showString "OWin"
showsPrec d (Score i) = showParen (d >= 10) showStr
where
showStr = showString "Score" . showChar ' ' . showsPrec 10 i
readsPrec p = error "no readsPrec for Evaluations"
readList = error "no readList for Evaluations"
showList [] = showString "[]"
showList (x:xs)
= showChar '[' . shows x . showl xs
where showl [] = showChar ']'
showl (x:xs) = showChar ',' . shows x . showl xs
-}
goRow p rowsL psL [] rowsR = []
goRow p rowsL psL (Empty:psR) rowsR
= (rowsL $ (psL $ (p:psR)) : rowsR) : goRow p rowsL (psL . (Empty:)) psR rowsR
goRow p rowsL psL (p':psR) rowsR = goRow p rowsL (psL . (p':)) psR rowsR
empties board = [ (x,y) | (y,row) <- zip [1..] board,
(x,Empty) <- zip [1..] row ]
eval 3 = XWin
eval (-3) = OWin
eval x = Score x
initialBoard :: Board
initialBoard = replicate boardDim (replicate boardDim Empty)
data Evaluation = OWin | Score {-# UNPACK #-}!Int | XWin
-- higher scores denote a board in X's favour
deriving (Show,Eq)
maxE :: Evaluation -> Evaluation -> Evaluation
maxE XWin _ = XWin
maxE _ XWin = XWin
maxE b OWin = b
maxE OWin b = b
maxE a@(Score x) b@(Score y) | x>y = a
| otherwise = b
minE :: Evaluation -> Evaluation -> Evaluation
minE OWin _ = OWin
minE _ OWin = OWin
minE b XWin = b
minE XWin b = b
minE a@(Score x) b@(Score y) | x<y = a
| otherwise = b
eval n | n == boardDim = XWin
| -n == boardDim = OWin
| otherwise = Score n
static :: Board -> Evaluation
static board = interpret 0 (parMap rwhnf (score board) wins)
static board = interpret 0 (score board)
interpret :: Int -> [Evaluation] -> Evaluation
interpret x [] = (Score x)
......@@ -98,13 +90,21 @@ interpret x (Score y:l) = interpret (x+y) l
interpret x (XWin:l) = XWin
interpret x (OWin:l) = OWin
score :: Board -> Win -> Evaluation
score board win = eval (sum (parMap rnf sum (zipWith (zipWith scorePiece) board win)))
scorePiece :: Piece -> Int -> Int
scorePiece X score = score
scorePiece Empty _ = 0
scorePiece O score = -score
scorePiece X = 1
scorePiece O = -1
scorePiece Empty = 0
scoreString !n [] = n
scoreString !n (X:ps) = scoreString (n+1) ps
scoreString !n (O:ps) = scoreString (n-1) ps
scoreString !n (Empty:ps) = scoreString n ps
score :: Board -> [Evaluation]
score board =
[ eval (scoreString 0 row) | row <- board ] ++
[ eval (scoreString 0 col) | col <- transpose board ] ++
[ eval (scoreString 0 (zipWith (!!) board [0..])),
eval (scoreString 0 (zipWith (!!) board [boardDim-1,boardDim-2 ..])) ]
{-
#if 0
......
-- Time-stamp: <2008-10-21 13:23:29 simonmar>
-- Time-stamp: <2009-05-07 14:07:23 simonmar>
-----------------------------------------------------------------------------
module Game where
import Board
import Wins
import Tree
import Control.Parallel
import Control.Parallel.Strategies
import Debug.Trace
type Player = Evaluation -> Evaluation -> Evaluation
type Move = (Board,Evaluation)
alternate :: Int -> Piece -> Player -> Player -> Board -> [Move]
alternate _ _ _ _ b | fullBoard b = []
alternate _ _ _ _ b | static b == XWin = []
alternate _ _ _ _ b | static b == OWin = []
alternate decaf player f g board = move:alternate decaf opposition g f board'
alternate depth player f g board = move : alternate depth opponent g f board'
where
move@(board',eval) = best f possibles scores
scores = par_map decaf (bestMove opposition g f) possibles
scores = map (bestMove depth opponent g f) possibles `using` myParList
possibles = newPositions player board
opposition = opposite player
opponent = opposite player
opposite :: Piece -> Piece
opposite X = O
......@@ -36,40 +34,32 @@ best f (b:bs) (s:ss) = best' b s bs ss
where
best' b s [] [] = (b,s)
best' b s (b':bs) (s':ss) | s==(f s s') = best' b s bs ss
| otherwise = best' b' s' bs ss
| otherwise = best' b' s' bs ss
showMove :: Move -> String
showMove (b,e) = show e ++ "\n" ++ showBoard b
bestMove :: Piece -> Player -> Player -> Board -> Evaluation
bestMove p f g = (mise f g).cropTree.mapTree static.searchTree p
bestMove :: Int -> Piece -> Player -> Player -> Board -> Evaluation
bestMove depth p f g
= parMise 2 f g
. cropTree
. mapTree static
. prune depth
. searchTree p
cropTree :: (Tree Evaluation) -> (Tree Evaluation)
cropTree (Branch a []) = (Branch a [])
cropTree (Branch (Score x) l) = Branch (Score x) (par_map 4 cropTree l)
cropTree (Branch (Score x) l) = Branch (Score x) (map cropTree l)
cropTree (Branch x l) = Branch x []
searchTree :: Piece -> Board -> (Tree Board)
searchTree p board = prune 5 (repTree (newPositions p) (newPositions (opposite p)) board)
searchTree p board = repTree (newPositions p) (newPositions (opposite p)) board
mise :: Player -> Player -> (Tree Evaluation) -> Evaluation
mise f g (Branch a []) = a
mise f g (Branch _ l) = foldr f (g OWin XWin) (par_map 11 (mise g f) l)
max' :: Evaluation -> Evaluation -> Evaluation
max' XWin _ = XWin
max' _ XWin = XWin
max' b OWin = b
max' OWin b = b
max' a@(Score x) b@(Score y) | x>y = a
| otherwise = b
min' :: Evaluation -> Evaluation -> Evaluation
min' OWin _ = OWin
min' _ OWin = OWin
min' b XWin = b
min' XWin b = b
min' a@(Score x) b@(Score y) | x<y = a
| otherwise = b
mise f g (Branch _ l) = foldr f (g OWin XWin) (map (mise g f) l)
parMise :: Int -> Player -> Player -> (Tree Evaluation) -> Evaluation
parMise 0 f g t = mise f g t
parMise n f g (Branch a []) = a
parMise n f g (Branch _ l) = foldr f (g OWin XWin) (map (parMise (n-1) g f) l `using` myParList)
-- Time-stamp: <2008-10-21 13:21:24 simonmar>
-- Time-stamp: <2009-05-06 13:54:34 simonmar>
-----------------------------------------------------------------------------
module Main where
import System.Environment
import Prog
import Board
import System.Random
main = do
[n] <- fmap (map read) getArgs
putStrLn (prog n)
[n, depth] <- fmap (map read) getArgs
setStdGen (mkStdGen 99999)
b <- randomBoard n
putStrLn $ showBoard b
putStrLn $ solve depth b
-- Time-stamp: <2008-10-21 13:20:50 simonmar>
-- Time-stamp: <2009-05-06 13:55:20 simonmar>
-----------------------------------------------------------------------------
module Prog(prog) where
module Prog(prog,randomBoard,solve) where
import Board
import Wins
import Game
import Tree
import System.Random
import Data.List
-- First arg decaffinates game
prog :: Int -> String
......@@ -16,8 +18,30 @@ prog decaf = showMove (head game)
where
game = if decaf == 0
then error "Decaffination error\n"
else alternate decaf X max' min' testBoard
else alternate decaf X maxE minE testBoard
-- X to play: find the best move
solve :: Int -> Board -> String
solve depth board
= unlines
. map showMove
. take 1
. alternate depth X maxE minE $ board
testBoard = [[Empty,O,Empty],[Empty,X,Empty],[Empty,Empty,Empty]]
testBoard = [[Empty,O,Empty,Empty],[Empty,X,Empty,Empty],[Empty,Empty,Empty,Empty],[Empty,Empty,Empty,Empty]]
randomBoard :: Int -> IO Board
randomBoard moves = do
g <- newStdGen
let (g1,g2) = split g
xs = randomRs (1,boardDim) g1
ys = randomRs (1,boardDim) g2
let
play 0 _ _ board = board
play n (pos:poss) (p:ps) board
| not (empty pos board) = play n poss (p:ps) board
| otherwise = play (n-1) poss ps (placePiece p board pos)
return $ play moves (zip xs ys) (cycle [X,O]) initialBoard
{-# LANGUAGE CPP #-}
module Tree where
data Tree a = Branch a [Tree a] deriving Text
import Control.Parallel
import Control.Parallel.Strategies
data Tree a = Branch a [Tree a] deriving Show
repTree :: (a->[a]) -> (a->[a])-> a -> (Tree a)
repTree f g a = Branch a (par_map 12 (repTree g f) (f a))
repTree f g a = Branch a (map (repTree g f) (f a))
#define SEQ
#ifndef SEQ
mapTree :: (a -> b) -> (Tree a) -> (Tree b)
mapTree f (Branch a l) = parGlobal 14 14 1 0
fa
(Branch fa (par_map 13 (mapTree f) l))
where fa = f a
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f (Branch a l)
= fa `par` Branch fa (map (mapTree f) l `using` myParList)
where fa = f a
#else {- SEQ -}
......@@ -20,6 +25,16 @@ mapTree f (Branch a l) = Branch (f a) (map (mapTree f) l)
#endif
myParList [] = ()
myParList (x:xs) = x `par` myParList xs
mySeqList [] = ()
mySeqList (x:xs) = x `seq` mySeqList xs
parTree :: Int -> Tree a -> ()
parTree 0 (Branch a xs) = ()
parTree n (Branch a xs) = a `par` mySeqList (map (parTree (n-1)) xs)
prune :: Int -> (Tree a) -> (Tree a)
prune 0 (Branch a l) = Branch a []
prune (n+1) (Branch a l) = Branch a (map (prune n) l)
......
......@@ -16,8 +16,7 @@ Message-ID: <swordfish.740931041@minster.york.ac.uk>
-- Version 5 -- search parallel lines in parallel
------------------------------------------------------------------
import {-fool mkdependHS; ToDo: rm-}
Parallel
import Control.Parallel
import List(transpose)--1.3
main = par (unigrid d) (par (unigrid dr) (par (unigrid ur) (
......
------------------------------------------------------------------
-- Time-stamp: <Tue Apr 03 2001 20:46:15 Stardate: [-30]6429.11 hwloidl>
-- Time-stamp: <2009-05-07 13:48:09 simonmar>
--
-- Searching in a grid of words for hidden words oriented in any of
-- the 8 possible directions.
......@@ -25,11 +25,13 @@ module Main(main) where
-- @node Imports, Datatypes
-- @section Imports
import Strategies
import List(transpose)
import System(getArgs)
import Char
import Random
import Control.Parallel
import Control.Parallel.Strategies
import Data.List ( transpose )
import System.Environment ( getArgs )
import Data.Char
import System.Random
import Control.Exception
-- @node Datatypes, Main fct, Imports
-- @section Datatypes
......@@ -44,13 +46,10 @@ instance NFData DIRS
-- @section Main fct
main = do
args <- getArgs
--g <- getStdGen
--input <- readFile "random-list"
let
n = read (args!!0) :: Int -- grid size
[n] <- fmap (fmap read) getArgs
grid <- mk_grid n -- build a grid of the given size
let
evaluate (rnf grid)
let
r = grid
d = transpose grid
dl = diagonals grid
......@@ -70,7 +69,7 @@ main = do
-- res = map find hidden -- all matches as (word, [dirs])
res = map (length . snd . find ) hidden -- only count no. of matches
`using` parList rnf
`using` myParList
{-
`using` \ r ->(rnf d >||
rnf dl >||
......@@ -89,6 +88,8 @@ main = do
putStrLn res_str -- "done"
myParList [] = ()
myParList (x:xs) = x `par` myParList xs
-- @node Aux fcts, , Main fct
-- @section Aux fcts
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment