Related
This question already has answers here:
Merge sort for f sharp
(2 answers)
Closed 5 years ago.
The code underneath is the code for mergesort in f# and I have to rewrite it, so it uses pattern matching.
let rec msort xs =
let sz = List.length xs
if sz < 2 then xs
else let n = sz / 2
let ys = xs.[0..n-1]
let zs = xs.[n..sz-1]
in merge (msort ys) (msort zs)
So far I've gotten is to here:
let rec msort (vs: int list) =
let sz = List.length xs
match xs with
| List.length < 2 -> vs
| _ ->
let n = sz / 2
let ys = xs.[0..n-1]
let zs = xs.[n..sz-1]
in merge (msort ys) (msort zs)
I can't seem to figure out a better way. Is there anyone who can help me on my way?
I would probably do it like this:
let rec msort (values: int list) =
let n = values.Length / 2
if n = 0
then values
else let rec merge (xs: int list) (ys: int list) =
match (xs, ys) with
| ([], ys) -> ys
| (xs, []) -> xs
| (x :: xs1, y :: ys1) ->
if x < y
then x :: merge xs1 ys
else y :: merge xs ys1
let (first, second) = values |> List.splitAt n
merge (msort first) (msort second)
Pattern matching isn't too useful on the initial logic (length of the list, early exits for length 0 and 1), but I think it makes it more readable when matching the cases for the sub-lists after the split. Even so, there's only one if/then in the msort portion and it could be replaced with a pattern match if you really wanted to:
let rec msort (values: int list) =
match values.Length / 2 with
| 0 -> values
| n ->
let rec merge (xs: int list) (ys: int list) =
match (xs, ys) with
| ([], ys) -> ys
| (xs, []) -> xs
| (x :: xs1, y :: ys1) ->
if x < y
then x :: merge xs1 ys
else y :: merge xs ys1
let (first, second) = values |> List.splitAt n
merge (msort first) (msort second)
This leaves only the if/then for x<y in the merge implementation, and I wouldn't change that.
Almost the same, but I propose a custom split:
let split2 (li: int list) =
let n = (List.length li) / 2
let rec looprec (len: int) (l1: int list) (l2: int list) =
if len > 0 then
match l1 with
| x::tail -> looprec (len-1) tail (x::l2)
| _ -> (List.rev l2, l1)
else
(List.rev l2, l1)
in looprec n li []
let rec merge (l1: int list) (l2: int list) =
match (l1,l2) with
| (x,[]) -> x
| ([],y) -> y
| (x::tx,y::ty) ->
if x <= y
then x::merge tx l2
else y::merge l1 ty
let rec msort (li: int list) =
match li with
| [] -> []
| [x] -> [x]
| _ -> let (l1,l2) = split2 li
in merge (msort l1) (msort l2)
let d= msort [3;20;12]
printfn "%A" d
How can I generate a value so that it's reflected as an element of another generated value?
For example take the following code:
type Space =
| Occupied of Piece
| Available of Coordinate
// Setup
let pieceGen = Arb.generate<Piece>
let destinationGen = Arb.generate<Space>
let positionsGen = Arb.generate<Space list>
I want the positionsGen to include the values produced by the pieceGen and spaceGen.
However, I am clueless on how to do this.
To add context to my question, my positions list (aka checker board) should contain both the generated piece and the generated destination within its list.
Here's my test:
[<Property(QuietOnSuccess = true, MaxTest=10000)>]
let ``moving checker retains set count`` () =
// Setup
let pieceGen = Arb.generate<Piece>
let destinationGen = Arb.generate<Space>
let positionsGen = Arb.generate<Space list>
let statusGen = Arb.generate<Status>
// Test
Gen.map4 (fun a b c d -> a,b,c,d) pieceGen destinationGen positionsGen statusGen
|> Arb.fromGen
|> Prop.forAll
<| fun (piece , destination , positions , status) -> (positions, status)
|> move piece destination
|> getPositions
|> List.length = positions.Length
Appendix:
(* Types *)
type Black = BlackKing | BlackSoldier
type Red = RedKing | RedSoldier
type Coordinate = int * int
type Piece =
| Black of Black * Coordinate
| Red of Red * Coordinate
type Space =
| Occupied of Piece
| Available of Coordinate
type Status =
| BlacksTurn | RedsTurn
| BlackWins | RedWins
(* Private *)
let private black coordinate = Occupied (Black (BlackSoldier , coordinate))
let private red coordinate = Occupied (Red (RedSoldier , coordinate))
let private getPositions (positions:Space list, status:Status) = positions
let private yDirection = function
| Black _ -> -1
| Red _ -> 1
let private toAvailable = function
| Available pos -> true
| _ -> false
let private available positions = positions |> List.filter toAvailable
let private availableSelection = function
| Available pos -> Some pos
| Occupied _ -> None
let private availablePositions positions =
positions |> List.filter toAvailable
|> List.choose availableSelection
let private getCoordinate = function
| Available xy -> Some xy
| _ -> None
let private coordinateOf = function
| Black (checker , pos) -> pos
| Red (checker , pos) -> pos
let private optionsForSoldier piece =
let (sourceX , sourceY) = coordinateOf piece
(fun pos -> pos = ((sourceX - 1) , (sourceY + (piece |> yDirection) )) ||
pos = ((sourceX + 1) , (sourceY + (piece |> yDirection) )))
let private optionsForKing piece =
let (sourceX , sourceY) = coordinateOf piece
(fun pos -> pos = ((sourceX - 1) , (sourceY + 1 )) ||
pos = ((sourceX + 1) , (sourceY + 1 )) ||
pos = ((sourceX - 1) , (sourceY - 1 )) ||
pos = ((sourceX + 1) , (sourceY - 1 )))
let private jumpOptions (sourceX , sourceY) space =
match space with
| Occupied p -> match p with
| Red (ch,xy) -> xy = (sourceX + 1, sourceY - 1) ||
xy = (sourceX - 1, sourceY - 1)
| Black (ch,xy) -> xy = (sourceX + 1, sourceY + 1) ||
xy = (sourceX - 1, sourceY + 1)
| _ -> false
let private jumpsForSoldier piece positions =
match piece with
| Black (ch,pos) -> positions |> List.filter (jumpOptions (coordinateOf piece))
| Red (ch,pos) -> positions |> List.filter (jumpOptions (coordinateOf piece))
let private isKing piece =
match piece with
| Black (checker , _) -> match checker with
| BlackSoldier -> false
| BlackKing -> true
| Red (checker , _) -> match checker with
| RedSoldier -> false
| RedKing -> true
let private filterOut a b positions =
positions |> List.filter(fun x -> x <> a && x <> b)
let private movePiece destination positions piece =
let destinationXY =
match destination with
| Available xy -> xy
| Occupied p -> coordinateOf p
let yValueMin , yValueMax = 0 , 7
let canCrown =
let yValue = snd destinationXY
(yValue = yValueMin ||
yValue = yValueMax) &&
not (isKing piece)
match positions |> List.find (fun space -> space = Occupied piece) with
| Occupied (Black (ch, xy)) ->
let checkerType = if canCrown then BlackKing else BlackSoldier
Available(xy) :: (Occupied(Black(checkerType, destinationXY)))
:: (positions |> filterOut (Occupied (Black(ch, xy))) destination)
| Occupied (Red (ch, xy)) ->
let checkerType = if canCrown then RedKing else RedSoldier
Available(xy) :: (Occupied(Red(checkerType, destinationXY)))
:: (positions |> filterOut (Occupied (Red(ch, xy))) destination)
| _ -> positions
(* Public *)
let startGame () =
[ red (0,0); red (2,0); red (4,0); red (6,0)
red (1,1); red (3,1); red (5,1); red (7,1)
red (0,2); red (2,2); red (4,2); red (6,2)
Available (1,3); Available (3,3); Available (5,3); Available (7,3)
Available (0,4); Available (2,4); Available (4,4); Available (6,4)
black (1,5); black (3,5); black (5,5); black (7,5)
black (0,6); black (2,6); black (4,6); black (6,6)
black (1,7); black (3,7); black (5,7); black (7,7) ] , BlacksTurn
let optionsFor piece positions =
let sourceX , sourceY = coordinateOf piece
match piece |> isKing with
| false -> positions |> availablePositions
|> List.filter (optionsForSoldier piece)
| true -> positions |> availablePositions
|> List.filter (optionsForKing piece)
let move piece destination (positions,status) =
let currentStatus = match status with
| BlacksTurn -> RedsTurn
| RedsTurn -> BlacksTurn
| BlackWins -> BlackWins
| RedWins -> RedWins
let canProceed = match piece with
| Red _ -> currentStatus = RedsTurn
| Black _ -> currentStatus = BlacksTurn
if not canProceed then (positions , currentStatus)
else let options = optionsFor piece positions
let canMoveTo = (fun target -> options |> List.exists (fun xy -> xy = target))
match getCoordinate destination with
| Some target -> if canMoveTo target then
let updatedBoard = ((positions , piece) ||> movePiece destination)
(updatedBoard , currentStatus)
else (positions , currentStatus)
| None -> (positions , currentStatus)
let jump target positions source =
let canJump =
positions |> jumpsForSoldier source
|> List.exists (fun s -> match s with
| Occupied target -> true
| _ -> false)
let (|NorthEast|NorthWest|SouthEast|SouthWest|Origin|) (origin , barrier) =
let (sourceX , sourceY) = origin
let (barrierX , barrierY) = barrier
if barrierY = sourceY + 1 &&
barrierX = sourceX - 1
then SouthWest
elif barrierY = sourceY + 1 &&
barrierX = sourceX + 1
then SouthEast
elif barrierY = sourceY - 1 &&
barrierX = sourceX - 1
then NorthWest
elif barrierY = sourceY - 1 &&
barrierX = sourceX + 1
then NorthEast
else Origin
let jumpToPostion origin barrier =
let (sourceX , sourceY) = origin
let (barrierX , barrierY) = barrier
match (origin , barrier) with
| SouthWest -> (barrierX + 1, barrierY - 1)
| SouthEast -> (barrierX + 1, barrierY + 1)
| NorthWest -> (barrierX - 1, barrierY - 1)
| NorthEast -> (barrierX - 1, barrierY + 1)
| Origin -> origin
if canJump then
let destination = Available (jumpToPostion (coordinateOf source) (coordinateOf target))
let result = (positions, source) ||> movePiece destination
|> List.filter (fun s -> s <> Occupied target)
Available (coordinateOf target)::result
else positions
As explained in a previous answer, you can use the gen computation expression to express more complex generators.
In this particular example, you state that you need positionsGen to include the values produced by the pieceGen and spaceGen. You can do that like this:
[<Property(QuietOnSuccess = true, MaxTest=10000)>]
let ``moving checker retains set count`` () =
gen {
let! piece = Arb.generate<Piece>
let! destination = Arb.generate<Space>
let! otherPositions = Arb.generate<Space list>
let! positions =
Occupied piece :: destination :: otherPositions |> Gen.shuffle
let! status = Arb.generate<Status>
return piece, destination, positions |> Array.toList, status }
|> Arb.fromGen
|> Prop.forAll
// ... the rest of the test goes here...
The computation expression starts by generating a piece and a destination. Due to the use of let! within the computation expression, within that context, they are normal Piece and Space values, and can be treated as such.
Next, the expression uses let! to 'generate' a Space list value, which will contain other values (if any; the generated list could be empty).
This gives you all the building blocks required to generate a list that contains at least the two desired values, as well as other values. To create such a list, you can cons (::) the two 'known' values onto the list, and then shuffle the result for good measure.
The final expression in the gen computation expression then returns a four-element tuple. The type of that expression is Gen<Piece * Space * Space list * Status>. It can be turned into an Arbitrary<Piece * Space * Space list * Status> by Arb.fromGen, and further piped into Prop.forAll.
This addresses the problem that the moving checker retains set count property throws exceptions internally.
This, incidentally, demonstrates that the property is falsifiable:
Test 'Ploeh.StackOverflow.Q38857462.Properties.moving checker retains set count' failed: FsCheck.Xunit.PropertyFailedException :
Falsifiable, after 70 tests (0 shrinks) (StdGen (1318556550,296190265)):
Original:
<null>
(Black (BlackKing,(-1, 1)), Available (0, 0),
[Occupied (Red (RedSoldier,(-1, 0))); Available (0, 0);
Occupied (Black (BlackKing,(-1, 1))); Available (0, 0)], RedsTurn)
Whether this is a problem with the test or with the implementation is a different question...
How do I include multiple arguments for List.filter?
I need to add some parameters to a function that serves as a predicate for filtering a list.
In F#, the List.filter accepts just one argument. However, I need to add multiple arguments for my predicate to work.
In my case, I need to add sourceX and sourceY as parameters:
let jumpOptions space =
match space with
| Allocated p -> match p with
| Red (ch,xy) -> xy = (sourceX + 1, sourceY - 1) ||
xy = (sourceX - 1, sourceY - 1)
| Black (ch,xy) -> xy = (sourceX + 1, sourceY + 1) ||
xy = (sourceX - 1, sourceY + 1)
| _ -> false
let jumpsForSoldier piece positions =
match piece with
| Black (ch,pos) -> positions |> List.filter jumpOptions
| Red (ch,pos) -> positions |> List.filter jumpOptions
In conclusion, I want to keep the elements within my list pure. Hence, I do not want to bundle each element within my list with other values just to satisfy a filter function.
Any guidance?
Appendix:
open NUnit.Framework
open FsUnit
(* Types *)
type Black = BlackKing | BlackSoldier
type Red = RedKing | RedSoldier
type Coordinate = int * int
type Piece =
| Black of Black * Coordinate
| Red of Red * Coordinate
type Space =
| Allocated of Piece
| Available of Coordinate
type Status =
| BlacksTurn | RedsTurn
| BlackWins | RedWins
(* Private *)
let private black coordinate = Allocated (Black (BlackSoldier , coordinate))
let private red coordinate = Allocated (Red (RedSoldier , coordinate))
let private yDirection = function
| Black _ -> -1
| Red _ -> 1
let private toAvailable = function
| Available pos -> true
| _ -> false
let available positions = positions |> List.filter toAvailable
let private availableSelection = function
| Available pos -> Some pos
| Allocated _ -> None
let private availablePositions positions =
positions |> List.filter toAvailable
|> List.choose availableSelection
let private allocatedSelection = function
| Allocated p -> match p with
| Red (ch,xy) -> Some xy
| Black (ch,xy) -> Some xy
| _ -> None
let private allocatedPositions positions =
positions |> List.filter toAvailable
|> List.choose allocatedSelection
let private getCoordinate = function
| Available xy -> Some xy
| _ -> None
let coordinateOf = function
| Black (checker , pos) -> pos
| Red (checker , pos) -> pos
let jumpOptions space =
match space with
| Allocated p -> match p with
| Red (ch,xy) -> let sourceX, sourceY = coordinateOf source
xy = (sourceX + 1, sourceY - 1) ||
xy = (sourceX - 1, sourceY - 1)
| Black (ch,xy) -> let sourceX, sourceY = coordinateOf p
xy = (sourceX + 1, sourceY + 1) ||
xy = (sourceX - 1, sourceY + 1)
| _ -> false
let jumpsForSoldier piece positions =
match piece with
| Black (ch,pos) -> positions |> List.filter jumpOptions
| Red (ch,pos) -> positions |> List.filter jumpOptions
let private isKing piece =
match piece with
| Black (checker , _) -> match checker with
| BlackSoldier -> false
| BlackKing -> true
| Red (checker , _) -> match checker with
| RedSoldier -> false
| RedKing -> true
(* Public *)
let startGame () =
[ red (0,0); red (2,0); red (4,0); red (6,0)
red (1,1); red (3,1); red (5,1); red (7,1)
red (0,2); red (2,2); red (4,2); red (6,2)
Available (1,3); Available (3,3); Available (5,3); Available (7,3)
Available (0,4); Available (2,4); Available (4,4); Available (6,4)
black (1,5); black (3,5); black (5,5); black (7,5)
black (0,6); black (2,6); black (4,6); black (6,6)
black (1,7); black (3,7); black (5,7); black (7,7) ] , BlacksTurn
let optionsFor piece positions =
let sourceX , sourceY = coordinateOf piece
let optionsForSoldier =
(fun pos -> pos = ((sourceX - 1) , (sourceY + (piece |> yDirection) )) ||
pos = ((sourceX + 1) , (sourceY + (piece |> yDirection) )))
let optionsForKing =
(fun pos -> pos = ((sourceX - 1) , (sourceY + 1 )) ||
pos = ((sourceX + 1) , (sourceY + 1 )) ||
pos = ((sourceX - 1) , (sourceY - 1 )) ||
pos = ((sourceX + 1) , (sourceY - 1 )))
match piece |> isKing with
| false -> positions |> availablePositions
|> List.filter optionsForSoldier
| true -> positions |> availablePositions
|> List.filter optionsForKing
let move piece destination positions =
let rec movePiece positions destinationXY =
let foundPiece = positions |> List.filter (fun space -> space = Allocated piece)
|> List.head
match foundPiece with
| Allocated (Black (ch, xy)) -> (positions |> List.filter (fun space -> space <> Allocated (Black (ch, xy)))
|> List.filter (fun space -> space <> destination))
# [Available (xy) ; (Allocated (Black (ch, destinationXY)))]
| Allocated (Red (ch, xy)) -> (positions |> List.filter (fun space -> space <> Allocated (Red (ch, xy)))
|> List.filter (fun space -> space <> destination))
# [Available (xy) ; (Allocated (Red (ch, destinationXY)))]
| _ -> positions
let options = optionsFor piece positions
let canMoveTo = (fun target -> options |> List.exists (fun xy -> xy = target))
match getCoordinate destination with
| Some target -> match canMoveTo target with
| true -> movePiece positions target
| false -> positions
| None -> positions
(* Tests *)
[<Test>]
let ``get jump options for red soldier`` () =
// Setup
let redPiece = Red ( RedSoldier , (0,2) )
let blackPiece = Black ( BlackSoldier , (1,3) )
let positions = [Allocated redPiece; Available (2,2); Available (4,2); Available (6,2)
Allocated blackPiece; Available (3,3); Available (5,3); Available (7,3)
Available (0,4); Available (2,4); Available (4,4); Available (6,4)]
// Test
positions |> jumpsForSoldier redPiece
|> should equal [Allocated blackPiece]
You can have as many parameters as you want, then partially apply the function to all of them but one, and pass the result to List.filter.
let jumpOptions sourceX sourceY space = ...
...
positions |> List.filter (jumpOptions 5 42)
Read more on partial application here.
You could extract the required info using pattern matching and use partial application (code edited after TQBF comments)
let jumpOptions (sourceX, sourceY) = function
Allocated (Red (_, (x, y)) as p)
| Allocated (Black (_, (x, y)) as p) when abs (sourceX - x) = 1
-> y = sourceY - yDirection p
| _ -> false
let jumpsForSoldier = function
Red (_, pos)
| Black (_, pos) -> List.filter (jumpOptions pos)
This weekends programming fun of mine was to write a 300 lines reversi program in F#. It will probably take a few more weekends to find out how to get alphabeta search parallelized and this is actually out of scope for this question.
What I found, though was that I could not come up with some "pure functional" way to implement alphabeta function. I.e. without any mutable state.
Any good ideas for that?
The only idea which came to my mind would be to write something like Seq.foldUntil() function, where the accumulator state is used to store the changes in state. And which can be canceled by the lambda function passed in.
Maybe looking like this:
let transformWhile<'t,'s,'r> (transformer : 's -> 't -> 's * 'r * bool ) (state : 's) (sequence : 't seq) : 'r seq
Here the impure alphabeta function...
let rec alphabeta depth alpha beta fork (position : ReversiPosition) (maximize : bool) : (SquareName option * int) =
match depth with
| 0 -> (None, snd (eval position))
| _ ->
let allMoves =
allSquares
|> Seq.map (fun sq -> (sq,tryMove (position.ToMove) sq position))
|> Seq.filter (fun pos -> match snd pos with | Some(_) -> true | None -> false )
|> Seq.map (fun opos -> match opos with | (sq,Some(p)) -> (sq,p) | _ -> failwith("only Some(position) expected here."))
|> Array.ofSeq
let len = allMoves.Length
match len with
| 0 -> (None, snd (eval position))
| _ ->
if maximize then
let mutable v = System.Int32.MinValue
let mutable v1 = 0
let mutable a = alpha
let b = beta
let mutable i = 0
let mutable bm : SquareName option = None
let mutable bm1 : SquareName option = None
while (i<len) && (b > a) do
let x,y = alphabeta (depth-1) a b false (snd allMoves.[i]) false
bm1 <- Some(fst allMoves.[i])
v1 <- y
if v1 > v then
bm <- bm1
v <- v1
a <- max a v
if b > a then
i <- (i + 1)
(bm,v)
else
let mutable v = System.Int32.MaxValue
let mutable v1 = 0
let a = alpha
let mutable b = beta
let mutable i = 0
let mutable bm : SquareName option = None
let mutable bm1 : SquareName option = None
while (i<len) && (b > a) do
let x,y = alphabeta (depth-1) a b false (snd allMoves.[i]) true
bm1 <- Some(fst allMoves.[i])
v1 <- y
if v1 < v then
bm <- bm1
v <- v1
b <- min b v
if b > a then
i <- (i + 1)
(bm,v)
While waiting for answers, I decided to give my transformWhile idea a try and this is what became of it:
module SeqExt =
let rec foldWhile<'T,'S,'R> (transformer : 'S -> 'T -> 'S * 'R * bool ) (state : 'S) (sequence : seq<'T>) : 'R option =
if (Seq.length sequence) > 0 then
let rest = (Seq.skip 1 sequence)
let newState, resultValue, goOn = transformer state (Seq.head sequence)
if goOn && not (Seq.isEmpty rest) then
foldWhile transformer newState rest
else
Some(resultValue)
else
None
Some interactive testing showed that it works for some trivial stuff, so I decided to write a new version of alphabeta, which now looks like this:
let rec alphabeta depth alpha beta fork (position : ReversiPosition) (maximize : bool) : (SquareName option * int) =
match depth with
| 0 -> (None, snd (eval position))
| _ ->
let allMoves =
allSquares
|> Seq.map (fun sq -> (sq,tryMove (position.ToMove) sq position))
|> Seq.filter (fun pos -> match snd pos with | Some(_) -> true | None -> false )
|> Seq.map (fun opos -> match opos with | (sq,Some(p)) -> (sq,p) | _ -> failwith("only Some(position) expected here."))
let len = Seq.length allMoves
match len with
| 0 -> (None, snd (eval position))
| _ ->
if maximize then
let result = SeqExt.foldWhile
( fun (state : int * int * SquareName option * int ) move ->
let curAlpha,curBeta,curMove,curValue = state
let x,y = alphabeta (depth-1) curAlpha curBeta false (snd move) false
let newBm,newScore =
if y > curValue then
(Some(fst move), y)
else
(curMove,curValue)
let newAlpha = max curAlpha newScore
let goOn = curBeta > newAlpha
((newAlpha,curBeta,newBm,newScore),(newBm,newScore),goOn)
) (alpha,beta,None,System.Int32.MinValue) allMoves
match result with
| Some(r) -> r
| None -> failwith("This is not possible! Input sequence was not empty!")
else
let result = SeqExt.foldWhile
( fun (state : int * int * SquareName option * int ) move ->
let curAlpha,curBeta,curMove,curValue = state
let x,y = alphabeta (depth-1) curAlpha curBeta false (snd move) true
let newBm,newScore =
if y < curValue then
(Some(fst move), y)
else
(curMove,curValue)
let newBeta = min curBeta newScore
let goOn = newBeta > curAlpha
((curAlpha,newBeta,newBm,newScore),(newBm,newScore),goOn)
) (alpha,beta,None,System.Int32.MaxValue) allMoves
match result with
| Some(r) -> r
| None -> failwith("This is not possible! Input sequence was not empty!")
Is that looking like something you functional programming pros would do? Or what would you do?
While the brute force search I had before was tail recursive (no call stack building up), this pure functional version is no longer tail recursive. Can anyone find a way to make it tail recursive again?
I am familiar neither with the algorithm, nor with with F#, so I translated the pseudocode from Wikipedia to a purely functional variant:
function alphabeta(node, depth, α, β, maximizingPlayer)
if depth == 0 or node is a terminal node
return the heuristic value of node
if maximizingPlayer
return take_max(children(node), depth, α, β)
else
return take_min(children(node), depth, α, β)
function take_max(children, depth, α, β)
v = max(v, alphabeta(head(children), depth - 1, α, β, FALSE))
new_α = max(α, v)
if β ≤ new_α or tail(children) == Nil
return v
else
return take_max(tail(children), depth, α, β))
function take_min(children, depth, α, β)
v = min(v, alphabeta(head(children), depth - 1, α, β, TRUE))
new_β = min(β, v)
if new_β ≤ α or tail(children) == Nil
return v
else
return take_min(tail(children), depth, α, β))
The trick is to turn the foreach with break into a recursion with appropriate base case. I assumed that children(node) returns a cons list of nodes, which can be deconstructed using head/tail and tested for Nil.
Obviously, I can't test this, but I think it contains the right ideas (and it is almost Python...).
Also, maybe this is a case for memoization -- but that depends on the domain (which I am not familiar with). Parallelization is probably more difficult with this kind of recursion; for that, you maybe could build up a list of vs and alphas/betas in parallel (since the calls to alphabeta are probably the most expensive part), replacing the recursions with takeWhiles on those lists.
A deeply functional approach is described in John Hughes, Why functional programming matters.
Moreover, you could have a look at the implementations to Russell & Norvig, Artificial Intelligence - A modern approach
in Lisp (by Norvig himself!),
in Haskell (by #chris-taylor),
in CoffeeScript (by myself).
How would you convert type Node into an immutable tree?
This class implements a range tree that does not allow overlapping or adjacent ranges and instead joins them. For example if the root node is {min = 10; max = 20} then it's right child and all its grandchildren must have a min and max value greater than 21. The max value of a range must be greater than or equal to the min. I included a test function so you can run this as is and it will dump out any cases that fail.
I recommend starting with the Insert method to read this code.
module StackOverflowQuestion
open System
type Range =
{ min : int64; max : int64 }
with
override this.ToString() =
sprintf "(%d, %d)" this.min this.max
[<AllowNullLiteralAttribute>]
type Node(left:Node, right:Node, range:Range) =
let mutable left = left
let mutable right = right
let mutable range = range
// Symmetric to clean right
let rec cleanLeft(node : Node) =
if node.Left = null then
()
elif range.max < node.Left.Range.min - 1L then
cleanLeft(node.Left)
elif range.max <= node.Left.Range.max then
range <- {min = range.min; max = node.Left.Range.max}
node.Left <- node.Left.Right
else
node.Left <- node.Left.Right
cleanLeft(node)
// Clean right deals with merging when the node to merge with is not on the
// left outside of the tree. It travels right inside the tree looking for an
// overlapping node. If it finds one it merges the range and replaces the
// node with its left child thereby deleting it. If it finds a subset node
// it replaces it with its left child, checks it and continues looking right.
let rec cleanRight(node : Node) =
if node.Right = null then
()
elif range.min > node.Right.Range.max + 1L then
cleanRight(node.Right)
elif range.min >= node.Right.Range.min then
range <- {min = node.Right.Range.min; max = range.max}
node.Right <- node.Right.Left
else
node.Right <- node.Right.Left
cleanRight(node)
// Merger left is called whenever the min value of a node decreases.
// It handles the case of left node overlap/subsets and merging/deleting them.
// When no more overlaps are found on the left nodes it calls clean right.
let rec mergeLeft(node : Node) =
if node.Left = null then
()
elif range.min <= node.Left.Range.min - 1L then
node.Left <- node.Left.Left
mergeLeft(node)
elif range.min <= node.Left.Range.max + 1L then
range <- {min = node.Left.Range.min; max = range.max}
node.Left <- node.Left.Left
else
cleanRight(node.Left)
// Symmetric to merge left
let rec mergeRight(node : Node) =
if node.Right = null then
()
elif range.max >= node.Right.Range.max + 1L then
node.Right <- node.Right.Right
mergeRight(node)
elif range.max >= node.Right.Range.min - 1L then
range <- {min = range.min; max = node.Right.Range.max}
node.Right <- node.Right.Right
else
cleanLeft(node.Right)
let (|Before|After|BeforeOverlap|AfterOverlap|Superset|Subset|) r =
if r.min > range.max + 1L then After
elif r.min >= range.min then
if r.max <= range.max then Subset
else AfterOverlap
elif r.max < range.min - 1L then Before
elif r.max <= range.max then
if r.min >= range.min then Subset
else BeforeOverlap
else Superset
member this.Insert r =
match r with
| After ->
if right = null then
right <- Node(null, null, r)
else
right.Insert(r)
| AfterOverlap ->
range <- {min = range.min; max = r.max}
mergeRight(this)
| Before ->
if left = null then
left <- Node(null, null, r)
else
left.Insert(r)
| BeforeOverlap ->
range <- {min = r.min; max = range.max}
mergeLeft(this)
| Superset ->
range <- r
mergeLeft(this)
mergeRight(this)
| Subset -> ()
member this.Left with get() : Node = left and set(x) = left <- x
member this.Right with get() : Node = right and set(x) = right <- x
member this.Range with get() : Range = range and set(x) = range <- x
static member op_Equality (a : Node, b : Node) =
a.Range = b.Range
override this.ToString() =
sprintf "%A" this.Range
type RangeTree() =
let mutable root = null
member this.Add(range) =
if root = null then
root <- Node(null, null, range)
else
root.Insert(range)
static member fromArray(values : Range seq) =
let tree = new RangeTree()
values |> Seq.iter (fun value -> tree.Add(value))
tree
member this.Seq
with get() =
let rec inOrder(node : Node) =
seq {
if node <> null then
yield! inOrder node.Left
yield {min = node.Range.min; max = node.Range.max}
yield! inOrder node.Right
}
inOrder root
let TestRange() =
printf "\n"
let source(n) =
let rnd = new Random(n)
let rand x = rnd.NextDouble() * float x |> int64
let rangeRnd() =
let a = rand 1500
{min = a; max = a + rand 15}
[|for n in 1 .. 50 do yield rangeRnd()|]
let shuffle n (array:_[]) =
let rnd = new Random(n)
for i in 0 .. array.Length - 1 do
let n = rnd.Next(i)
let temp = array.[i]
array.[i] <- array.[n]
array.[n] <- temp
array
let testRangeAdd n i =
let dataSet1 = source (n+0)
let dataSet2 = source (n+1)
let dataSet3 = source (n+2)
let result1 = Array.concat [dataSet1; dataSet2; dataSet3] |> shuffle (i+3) |> RangeTree.fromArray
let result2 = Array.concat [dataSet2; dataSet3; dataSet1] |> shuffle (i+4) |> RangeTree.fromArray
let result3 = Array.concat [dataSet3; dataSet1; dataSet2] |> shuffle (i+5) |> RangeTree.fromArray
let test1 = (result1.Seq, result2.Seq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test2 = (result2.Seq, result3.Seq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test3 = (result3.Seq, result1.Seq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let print dataSet =
dataSet |> Seq.iter (fun r -> printf "%s " <| string r)
if not (test1 && test2 && test3) then
printf "\n\nTest# %A: " n
printf "\nSource 1: %A: " (n+0)
dataSet1 |> print
printf "\nSource 2: %A: " (n+1)
dataSet2 |> print
printf "\nSource 3: %A: " (n+2)
dataSet3 |> print
printf "\nResult 1: %A: " (n+0)
result1.Seq |> print
printf "\nResult 2: %A: " (n+1)
result2.Seq |> print
printf "\nResult 3: %A: " (n+2)
result3.Seq |> print
()
for i in 1 .. 10 do
for n in 1 .. 1000 do
testRangeAdd n i
printf "\n%d" (i * 1000)
printf "\nDone"
TestRange()
System.Console.ReadLine() |> ignore
Test cases for Range
After (11, 14) | | <-->
AfterOverlap (10, 14) | |<--->
AfterOverlap ( 9, 14) | +---->
AfterOverlap ( 6, 14) |<--+---->
"Test Case" ( 5, 9) +---+
BeforeOverlap ( 0, 8) <----+-->|
BeforeOverlap ( 0, 5) <----+ |
BeforeOverlap ( 0, 4) <--->| |
Before ( 0, 3) <--> | |
Superset ( 4, 10) <+---+>
Subset ( 5, 9) +---+
Subset ( 6, 8) |<->|
This is not an answer.
I adapted my test case to run against Juliet's code. It fails on a number of cases however I do see it passing some test.
type Range =
{ min : int64; max : int64 }
with
override this.ToString() =
sprintf "(%d, %d)" this.min this.max
let rangeSeqToJTree ranges =
ranges |> Seq.fold (fun tree range -> tree |> insert (range.min, range.max)) Nil
let JTreeToRangeSeq node =
let rec inOrder node =
seq {
match node with
| JNode(left, min, max, right) ->
yield! inOrder left
yield {min = min; max = max}
yield! inOrder right
| Nil -> ()
}
inOrder node
let TestJTree() =
printf "\n"
let source(n) =
let rnd = new Random(n)
let rand x = rnd.NextDouble() * float x |> int64
let rangeRnd() =
let a = rand 15
{min = a; max = a + rand 5}
[|for n in 1 .. 5 do yield rangeRnd()|]
let shuffle n (array:_[]) =
let rnd = new Random(n)
for i in 0 .. array.Length - 1 do
let n = rnd.Next(i)
let temp = array.[i]
array.[i] <- array.[n]
array.[n] <- temp
array
let testRangeAdd n i =
let dataSet1 = source (n+0)
let dataSet2 = source (n+1)
let dataSet3 = source (n+2)
let result1 = Array.concat [dataSet1; dataSet2; dataSet3] |> shuffle (i+3) |> rangeSeqToJTree
let result2 = Array.concat [dataSet2; dataSet3; dataSet1] |> shuffle (i+4) |> rangeSeqToJTree
let result3 = Array.concat [dataSet3; dataSet1; dataSet2] |> shuffle (i+5) |> rangeSeqToJTree
let test1 = (result1 |> JTreeToRangeSeq, result2 |> JTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test2 = (result2 |> JTreeToRangeSeq, result3 |> JTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test3 = (result3 |> JTreeToRangeSeq, result1 |> JTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let print dataSet =
dataSet |> Seq.iter (fun r -> printf "%s " <| string r)
if not (test1 && test2 && test3) then
printf "\n\nTest# %A: " n
printf "\nSource 1: %A: " (n+0)
dataSet1 |> print
printf "\nSource 2: %A: " (n+1)
dataSet2 |> print
printf "\nSource 3: %A: " (n+2)
dataSet3 |> print
printf "\n\nResult 1: %A: " (n+0)
result1 |> JTreeToRangeSeq |> print
printf "\nResult 2: %A: " (n+1)
result2 |> JTreeToRangeSeq |> print
printf "\nResult 3: %A: " (n+2)
result3 |> JTreeToRangeSeq |> print
()
for i in 1 .. 1 do
for n in 1 .. 10 do
testRangeAdd n i
printf "\n%d" (i * 10)
printf "\nDone"
TestJTree()
Got it working! I think the hardest part was figuring out how to make recursive calls on children while passing state back up the stack.
Performance is rather interesting. When inserting mainly ranges that collide and get merged together the mutable version is faster while if you insert mainly none overlapping nodes and fill out the tree the immutable version is faster. I've seen performance swing a max of 100% both ways.
Here's the complete code.
module StackOverflowQuestion
open System
type Range =
{ min : int64; max : int64 }
with
override this.ToString() =
sprintf "(%d, %d)" this.min this.max
type RangeTree =
| Node of RangeTree * int64 * int64 * RangeTree
| Nil
// Clean right deals with merging when the node to merge with is not on the
// left outside of the tree. It travels right inside the tree looking for an
// overlapping node. If it finds one it merges the range and replaces the
// node with its left child thereby deleting it. If it finds a subset node
// it replaces it with its left child, checks it and continues looking right.
let rec cleanRight n node =
match node with
| Node(left, min, max, (Node(left', min', max', right') as right)) ->
if n > max' + 1L then
let node, n' = right |> cleanRight n
Node(left, min, max, node), n'
elif n >= min' then
Node(left, min, max, left'), min'
else
Node(left, min, max, left') |> cleanRight n
| _ -> node, n
// Symmetric to clean right
let rec cleanLeft x node =
match node with
| Node(Node(left', min', max', right') as left, min, max, right) ->
if x < min' - 1L then
let node, x' = left |> cleanLeft x
Node(node, min, max, right), x'
elif x <= max' then
Node(right', min, max, right), max'
else
Node(right', min, max, right) |> cleanLeft x
| Nil -> node, x
| _ -> node, x
// Merger left is called whenever the min value of a node decreases.
// It handles the case of left node overlap/subsets and merging/deleting them.
// When no more overlaps are found on the left nodes it calls clean right.
let rec mergeLeft n node =
match node with
| Node(Node(left', min', max', right') as left, min, max, right) ->
if n <= min' - 1L then
Node(left', min, max, right) |> mergeLeft n
elif n <= max' + 1L then
Node(left', min', max, right)
else
let node, min' = left |> cleanRight n
Node(node, min', max, right)
| _ -> node
// Symmetric to merge left
let rec mergeRight x node =
match node with
| Node(left, min, max, (Node(left', min', max', right') as right)) ->
if x >= max' + 1L then
Node(left, min, max, right') |> mergeRight x
elif x >= min' - 1L then
Node(left, min, max', right')
else
let node, max' = right |> cleanLeft x
Node(left, min, max', node)
| node -> node
let (|Before|After|BeforeOverlap|AfterOverlap|Superset|Subset|) (min, max, min', max') =
if min > max' + 1L then After
elif min >= min' then
if max <= max' then Subset
else AfterOverlap
elif max < min' - 1L then Before
elif max <= max' then
if min >= min' then Subset
else BeforeOverlap
else Superset
let rec insert min' max' this =
match this with
| Node(left, min, max, right) ->
match (min', max', min, max) with
| After -> Node(left, min, max, right |> insert min' max')
| AfterOverlap -> Node(left, min, max', right) |> mergeRight max'
| Before -> Node(left |> insert min' max', min, max, right)
| BeforeOverlap -> Node(left, min', max, right) |> mergeLeft min'
| Superset -> Node(left, min', max', right) |> mergeLeft min' |> mergeRight max'
| Subset -> this
| Nil -> Node(Nil, min', max', Nil)
let rangeSeqToRangeTree ranges =
ranges |> Seq.fold (fun tree range -> tree |> insert range.min range.max) Nil
let rangeTreeToRangeSeq node =
let rec inOrder node =
seq {
match node with
| Node(left, min, max, right) ->
yield! inOrder left
yield {min = min; max = max}
yield! inOrder right
| Nil -> ()
}
inOrder node
let TestImmutableRangeTree() =
printf "\n"
let source(n) =
let rnd = new Random(n)
let rand x = rnd.NextDouble() * float x |> int64
let rangeRnd() =
let a = rand 15000
{min = a; max = a + rand 150}
[|for n in 1 .. 200 do yield rangeRnd()|]
let shuffle n (array:_[]) =
let rnd = new Random(n)
for i in 0 .. array.Length - 1 do
let n = rnd.Next(i)
let temp = array.[i]
array.[i] <- array.[n]
array.[n] <- temp
array
let print dataSet =
dataSet |> Seq.iter (fun r -> printf "%s " <| string r)
let testRangeAdd n i =
let dataSet1 = source (n+0)
let dataSet2 = source (n+1)
let dataSet3 = source (n+2)
let result1 = Array.concat [dataSet1; dataSet2; dataSet3] |> shuffle (i+3) |> rangeSeqToRangeTree
let result2 = Array.concat [dataSet2; dataSet3; dataSet1] |> shuffle (i+4) |> rangeSeqToRangeTree
let result3 = Array.concat [dataSet3; dataSet1; dataSet2] |> shuffle (i+5) |> rangeSeqToRangeTree
let test1 = (result1 |> rangeTreeToRangeSeq, result2 |> rangeTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test2 = (result2 |> rangeTreeToRangeSeq, result3 |> rangeTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
let test3 = (result3 |> rangeTreeToRangeSeq, result1 |> rangeTreeToRangeSeq) ||> Seq.forall2 (fun a b -> a.min = b.min && a.max = b.max)
if not (test1 && test2 && test3) then
printf "\n\nTest# %A: " n
printf "\nSource 1: %A: " (n+0)
dataSet1 |> print
printf "\nSource 2: %A: " (n+1)
dataSet2 |> print
printf "\nSource 3: %A: " (n+2)
dataSet3 |> print
printf "\n\nResult 1: %A: " (n+0)
result1 |> rangeTreeToRangeSeq |> print
printf "\nResult 2: %A: " (n+1)
result2 |> rangeTreeToRangeSeq |> print
printf "\nResult 3: %A: " (n+2)
result3 |> rangeTreeToRangeSeq |> print
()
for i in 1 .. 10 do
for n in 1 .. 100 do
testRangeAdd n i
printf "\n%d" (i * 10)
printf "\nDone"
TestImmutableRangeTree()
System.Console.ReadLine() |> ignore
It looks like you're defining a binary tree which is basically a union of a bunch of ranges. So, you have the following scenarios:
(10, 20) left (10, 20)
/ \ --> / \
(0, 5) (25, 30) (7, 8) (7, 8) (25, 30)
/
(0, 5)
(10, 20) right (10, 20)
/ \ --> / \
(0, 5) (25, 30) (21, 22) (0, 5) (21, 22)
\
(25, 30)
(10, 20) subset (10, 20)
/ \ --> / \
(0, 5) (25, 30) (15, 19) (0, 5) (25, 30)
(10, 20) R-superset (10, 30)
/ \ --> /
(0, 5) (25, 30) (11, 30) (0, 5)
(10, 20) L-superset (0, 20)
/ \ --> \
(0, 5) (25, 30) (0, 10) (25, 30)
(10, 20) LR-superset (0, 30)
/ \ -->
(0, 5) (25, 30) (0, 30)
The L- R- and LR-superset cases are interesting because it requires merging/deleting nodes when you insert a node whose range already contains other nodes.
The following is hastily written and not tested very well, but appears to satisfy the simple definition above:
type JTree =
| JNode of JTree * int64 * int64 * JTree
| Nil
let rec merge = function
| JNode(JNode(ll, lmin, lmax, lr), min, max, r) when min <= lmin -> merge <| JNode(ll, min, max, r)
| JNode(l, min, max, JNode(rl, rmin, rmax, rr)) when max >= rmax -> merge <| JNode(l, min, max, rr)
| n -> n
let rec insert (min, max) = function
| JNode(l, min', max', r) ->
let node =
// equal.
// e.g. Given Node(l, 10, 20, r) insert (10, 20)
if min' = min && max' = max then JNode(l, min', max', r)
// before. Insert left
// e.g. Given Node(l, 10, 20, r) insert (5, 7)
elif min' >= max then JNode(insert (min, max) l, min', max', r)
// after. Insert right
// e.g. Given Node(l, 10, 20, r) insert (30, 40)
elif max' <= min then JNode(l, min', max', insert (min, max) r)
// superset
// e.g. Given Node(l, 10, 20, r) insert (0, 40)
elif min' >= min && max' <= max then JNode(l, min, max, r)
// overlaps left
// e.g. Given Node(l, 10, 20, r) insert (5, 15)
elif min' >= min && max' >= max then JNode(l, min, max', r)
// overlaps right
// e.g. Given Node(l, 10, 20, r) insert (15, 40)
elif min' <= min && max' <= max then JNode(l, min', max, r)
// subset.
// e.g. Given Node(l, 10, 20, r) insert (15, 17)
elif min' <= min && max >= max then JNode(l, min', max', r)
// shouldn't happen
else failwith "insert (%i, %i) into Node(l, %i, %i, r)" min max min' max'
// balances left and right sides
merge node
| Nil -> JNode(Nil, min, max, Nil)
JTree = Juliet Tree :) The merge function does all the heavy lifting. It'll merge as far as possible down the left spine, then as far as possible down the right spine.
I'm not wholly convinced that my overlaps left and overlaps right cases are implemented properly, but the other cases should be correct.