History of my edits to speed up a Score4 AI originally ttsiodra

Score4.fs

// Learn more about F# at http://fsharp.net

open System.Collections.Generic

let width = 7
let height = 6
let maxDepth = 7
let orangeWins = 1000000
let yellowWins = -orangeWins
let debug = ref true

type Cell =
    | Orange = 1
    | Yellow = -1
    | Barren = 0

let inline rateCell (x : Cell) : int = int x

let rec any l =
    match l with
    | []        -> false
    | true::xs  -> true
    | false::xs -> any xs

let inline otherColor (color : Cell) : Cell = enum -(int color)

type PersistentScoreData =
    { rows : int[][]
      cols : int[][]
      neg_diags : int[][]
      pos_diags : int[][] }

let psdFromBoard (board : Cell[][]) =
    let sumFour (sx, ex) (sy, ey) f =
        [|
            for y in sy .. ey ->
                [|
                    for x in sx .. ex ->
                        [0 .. 3]
                        |> Seq.sumBy(fun i -> rateCell <| f x y i)
                |]
        |]

    { rows = sumFour (0, width - 4) (0, height - 1) (fun x y i -> board.[y].[x + i])
      cols = sumFour (0, width - 1) (0, height - 4) (fun x y i -> board.[y + i].[x])
      neg_diags = sumFour (0, width - 4) (0, height - 4) (fun x y i -> board.[y + i].[x + i])
      pos_diags = sumFour (0, width - 4) (3, height - 1) (fun x y i -> board.[y - i].[x + i]) }
            
type DiskColor =
    | OrangeDisk = 1
    | YellowDisk = -1

type Move = Move of int * int * DiskColor

let updatePsd (psd : PersistentScoreData) (Move (x, y, color)) =
    let inline myMapi2 incr x y f (arr : int[][]) =
        let res : int[][] = Array.zeroCreate arr.Length
        for cy in 0 .. arr.Length - 1 do
            let arr2 = arr.[cy]
            let res2 : int[] = Array.zeroCreate arr2.Length
            for cx in 0 .. arr2.Length - 1 do
                res2.[cx] <- f incr x y cx cy arr2.[cx]
            res.[cy] <- res2
        res

    let inline updatePsdRows incr x y cx cy value =
        let start_y = cy
        let start_x = cx
        let dx = start_x - x
        if start_y = y && -3 <= dx && dx <= 0 then
            value + incr
        else
            value

    let inline updatePsdCols incr x y cx cy value =
        let start_y = cy
        let start_x = cx
        let dy = start_y - y
        if start_x = x && -3 <= dy && dy <= 0 then
            value + incr
        else
            value

    let inline updatePsdNegDiags incr x y cx cy value =
        let start_y = cy
        let start_x = cx
        let dx = start_x - x
        let dy = start_y - y
        if dx = dy && -3 <= dx && dx <= 0 then
            value + incr
        else
            value

    let inline updatePsdPosDiags incr x y cx cy value =
        let start_y = cy + 3
        let start_x = cx
        let dx = start_x - x
        let dy = start_y - y
        if dx = -dy && -3 <= dx && dx <= 0 then
            value + incr
        else
            value

    let incr = int color
        
    { psd with
        rows = myMapi2 incr x y updatePsdRows psd.rows
        cols = myMapi2 incr x y updatePsdCols psd.cols
        neg_diags = myMapi2 incr x y updatePsdNegDiags psd.neg_diags
        pos_diags = myMapi2 incr x y updatePsdPosDiags psd.pos_diags
    }

let scoreBoard (psd : PersistentScoreData) =
    let counts = Array.zeroCreate 9

    let inline updateCounts (arr : int[][]) =
        for vs in arr do
            for v in vs do
                counts.[v + 4] <- counts.[v + 4] + 1

    updateCounts (psd.cols)
    updateCounts (psd.rows)
    updateCounts (psd.pos_diags)
    updateCounts (psd.neg_diags)

    let score =
        if counts.[0] <> 0 then
            yellowWins
        else if counts.[8] <> 0 then
            orangeWins
        else
            counts.[5] + 2*counts.[6] + 5*counts.[7] + 10*counts.[8] -
                counts.[3] - 2*counts.[2] - 5*counts.[1] - 10*counts.[0]

    score


let dropDisk (board:Cell array array) column color =
    let newBoard = Array.zeroCreate height
    let mutable found_y = None
    for y=height-1 downto 0 do
        newBoard.[y] <- Array.copy board.[y]
        if found_y.IsNone && newBoard.[y].[column] = Cell.Barren then
            found_y <- Some y
            newBoard.[y].[column] <- color
    newBoard, found_y

let rec abMinimax maximizeOrMinimize color depth (board : Cell[][]) psd =
    match depth with
    | 0 -> (None,scoreBoard psd)
    | _ ->
        let validMovesAndBoards =
            [0 .. (width-1)]
            |> List.filter (fun column -> board.[0].[column] = Cell.Barren)
            |> List.map (fun column ->
                let board, row = dropDisk board column color
                (match color with
                 | Cell.Orange -> Move(column, row.Value, DiskColor.OrangeDisk)
                 | Cell.Yellow -> Move(column, row.Value, DiskColor.YellowDisk)
                 | _ -> failwith "Invalid value"),
                board)

        match validMovesAndBoards with
        | [] -> (None,scoreBoard psd)
        | _  ->
            let ratedMoves =
                let targetScore = if maximizeOrMinimize then orangeWins else yellowWins
                validMovesAndBoards
                |> List.map (fun (move, board) ->
                    let psd = updatePsd psd move
                    let score = scoreBoard psd
                    (move, board, psd, score))

            let killerMoves =
                let targetScore = if maximizeOrMinimize then orangeWins else yellowWins
                ratedMoves
                |> List.filter (fun (_, _, _, score) -> score = targetScore)

            match killerMoves with
            | (killerMove,_,_,killerScore)::rest -> (Some(killerMove), killerScore)
            | [] ->
                let validBoards = validMovesAndBoards |> List.map snd
                let bestScores = 
                    ratedMoves
                    |> Array.ofList
                    |> (if depth >= 7 then Array.Parallel.map else Array.map) (fun (_, board, psd, _) -> abMinimax (not maximizeOrMinimize) (otherColor color) (depth-1) board psd)
                    |> List.ofArray
                    |> List.map (fun (_,score) -> score)
                    
                let allData = List.zip (List.map fst validMovesAndBoards) bestScores
                if !debug && depth = maxDepth then
                    List.iter (fun (move,score) ->
                        Printf.printf "Depth %d, placing on %A, Score:%d\n" depth move score) allData

                let best  (_,s as l) (_,s' as r) = if s > s' then l else r
                let worst (_,s as l) (_,s' as r) = if s < s' then l else r

                let bestMove,bestScore =
                    List.fold (if maximizeOrMinimize then best else worst) (List.head allData) (List.tail allData)
                (Some(bestMove),bestScore)

let inArgs str args =
    any(List.ofSeq(Array.map (fun x -> (x = str)) args))

let loadBoard args =
    let board = Array.zeroCreate height
    for y=0 to height-1 do
        board.[y] <- Array.zeroCreate width
        for x=0 to width-1 do
            let orange = Printf.sprintf "o%d%d" y x
            let yellow = Printf.sprintf "y%d%d" y x
            if inArgs orange args then
                board.[y].[x] <- Cell.Orange
            else if inArgs yellow args then
                board.[y].[x] <- Cell.Yellow
            else
                board.[y].[x] <- Cell.Barren
        done
    done ;
    board

[<EntryPoint>]
let main (args:string[]) =
    let board = loadBoard args
    let psd = psdFromBoard board
    let scoreOrig = scoreBoard psd
    let debug = inArgs "-debug" args
    if scoreOrig = orangeWins then
        printf "I win"
        -1
    elif scoreOrig = yellowWins then
        printf "You win"
        -1
    else
        let mv,score = abMinimax true Cell.Orange maxDepth board psd
        let msgWithColumnToPlaceOrange = 
            match mv with
            | Some column -> printfn "%A" column
            | _ -> printfn "No move possible"
        msgWithColumnToPlaceOrange
        0

// Runs in 1.216s

On my computer (an intel quad core i7 950)

• The initial version runs in 21.966s
• After removing the use of an exception for flow control: 4.602s
• After parallelizing: 2.913
• Without parallelization but nicer initialization of scores: 4.310s
• Redesign of the score computation function, produces same results, but tries to avoid random array accesses: 3.130s
• Added parallelization again: 1.216s

For reference, the OCaml version without exceptions and compiled with -unsafe runs in 1.494s.