I have a structure of nested maps:
[<RequireQualifiedAccess>]
type NestedMap =
| Object of Map<string,NestedMap>
| Value of int
I need to prune the structure.
The purpose of the code is to maintain intact the nested structure of the maps and of the map where the key value pair is found, pruning the branches where the key value pair is not found.
Here is the test NestedMap:
let l2' = NestedMap.Object ( List.zip ["C"; "S"; "D"] [NestedMap.Value(10); NestedMap.Value(20); NestedMap.Value(30)] |> Map.ofList)
let l3 = NestedMap.Object ( List.zip ["E"; "S"; "F"] [NestedMap.Value(100); NestedMap.Value(200); NestedMap.Value(300)] |> Map.ofList)
let l2'' = NestedMap.Object ( List.zip ["G"; "H"; "I"; "S"] [NestedMap.Value(30); l3; NestedMap.Value(40); NestedMap.Value(50)] |> Map.ofList)
let l1 = NestedMap.Object ( List.zip ["Y"; "A"; "B"] [NestedMap.Value(1); l2'; l2''] |> Map.ofList)
This is my code:
let rec pruneWithKeyValue (keyvalue: string * int) (json: NestedMap) =
let condition ck cv =
let tgtKey = (fst keyvalue)
let tgtVal = (snd keyvalue)
match (ck, cv) with
| (tgtKey, NestedMap.Value(tgtVal)) ->
printfn ">>> Found match : "
printfn " ck = %s " ck
printfn " tgtKey and tgtVal == %s, %i" tgtKey tgtVal
true
| _ -> false
match json with
| NestedMap.Object nmap ->
if (nmap |> Map.exists (fun k v -> condition k v)) then
json
else
printfn "Expanding w keyvalue: (%s,%i): " (fst keyvalue) (snd keyvalue)
let expanded = nmap |> Map.map (fun k v -> pruneWithKeyValue keyvalue v)
NestedMap.Object(expanded |> Map.filter (fun k v -> v <> NestedMap.Object (Map.empty)))
| _ -> NestedMap.Object (Map.empty)
let pruned = pruneWithKeyValue ("S",20) l1
let res = (pruned = l1)
The result is not what desired:
>>> Found match :
ck = Y
tgtKey and tgtVal == Y, 1
val pruneWithKeyValue : string * int -> json:NestedMap -> NestedMap
val pruned : NestedMap =
Object
(map
[("A", Object (map [("C", Value 10); ("D", Value 30); ("S", Value 20)]));
("B",
Object
(map
[("G", Value 30);
("H",
Object
(map [("E", Value 100); ("F", Value 300); ("S", Value 200)]));
("I", Value 40); ("S", Value 50)])); ("Y", Value 1)])
val remainsTheSame : bool = true
The code says that the output data structure remains unchanged (val remainsTheSame : bool = true). Even more interestingly, somehow the keyvalue tuple that contains the key-value pair the function is searching got modified:
>>> Found match :
ck = Y
tgtKey and tgtVal == Y, 1
This is the problem. In fact, if I hardcode the keyvalue tuple:
let rec pruneWithKeyValue (keyvalue: string * int) (json: NestedMap) =
let condition ck cv =
let tgtKey = (fst keyvalue)
let tgtVal = (snd keyvalue)
match (ck, cv) with
| ("S", NestedMap.Value(20)) ->
printfn ">>> Found match : "
printfn " ck = %s " ck
printfn " tgtKey and tgtVal == %s, %i" tgtKey tgtVal
true
| _ -> false
match json with
| NestedMap.Object nmap ->
if (nmap |> Map.exists (fun k v -> condition k v)) then
json
else
printfn "Expanding w keyvalue: (%s,%i): " (fst keyvalue) (snd keyvalue)
let expanded = nmap |> Map.map (fun k v -> pruneWithKeyValue keyvalue v)
NestedMap.Object(expanded |> Map.filter (fun k v -> v <> NestedMap.Object (Map.empty)))
| _ -> NestedMap.Object (Map.empty)
let pruned = pruneWithKeyValue ("S",20) l1
let remainsTheSame = (pruned = l1)
results in (yeah) the desired result:
Expanding w keyvalue: (S,20):
>>> Found match :
ck = S
tgtKey and tgtVal == S, 20
Expanding w keyvalue: (S,20):
Expanding w keyvalue: (S,20):
val pruneWithKeyValue : string * int -> json:NestedMap -> NestedMap
val pruned : NestedMap =
Object
(map
[("A", Object (map [("C", Value 10); ("D", Value 30); ("S", Value 20)]))])
val remainsTheSame : bool = false
It may be trivial but I don't understand where and how keyvalue ends up being modified, preventing me from getting the right output with parametric key-value tuple.
You can't pattern match against existing variables, in your original code tgtKey and tgtVal will be new bindings, not related to the existing ones which will be shadowed.
So change your match:
match (ck, cv) with
| (tgtKey, NestedMap.Value(tgtVal)) ->
to:
match (ck, cv) with
| (k, NestedMap.Value v) when (k, v) = (tgtKey, tgtVal) ->
or just:
match (ck, cv) with
| x when x = (tgtKey, NestedMap.Value(tgtVal)) ->
Related
I have a list and would like to return each element from it individually. Basically like popping from a stack. For example:
let rnd = new System.Random()
let rnds = List.init 10 (fun _ -> rnd.Next(100))
List.iter (fun x -> printfn "%A"x ) rnds
However instead of iterating, I would actually like to return each integer one after the other until the list is empty. So basically something along the lines of:
List.head(rnds)
List.head(List.tail(rnds))
List.head(List.tail(List.tail(rnds)))
List.head(List.tail(List.tail(List.tail(List.tail(rnds)))))
Unfortunately my attempts at a recursive solution or even better something using fold or scan were unsuccessful. For example this just returns the list (same as map).
let pop3 (rnds:int list) =
let rec pop3' rnds acc =
match rnds with
| head :: tail -> List.tail(tail)
| [] -> acc
pop3' [] rnds
Would uncons do what you need?
let uncons = function h::t -> Some (h, t) | [] -> None
You can use it to 'pop' the head of a list:
> rnds |> uncons;;
val it : (int * int list) option =
Some (66, [17; 93; 33; 17; 21; 1; 49; 5; 96])
You can repeat this:
> rnds |> uncons |> Option.bind (snd >> uncons);;
val it : (int * int list) option = Some (17, [93; 33; 17; 21; 1; 49; 5; 96])
> rnds |> uncons |> Option.bind (snd >> uncons) |> Option.bind (snd >> uncons);;
val it : (int * int list) option = Some (93, [33; 17; 21; 1; 49; 5; 96])
This seems like a good oppurtunity for a class
type unpacker(l) =
let mutable li = l
member x.get() =
match li with
|h::t -> li<-t;h
|_ -> failwith "nothing left to return"
So I am doing a some batch computation very cpu intensive on books. And I built a tracker to track the computation of tasks. I close on a mailboxprocesser which all runs fine without parallelizaton but when I put a array.parallel.map or and async workflow the mailboxprocesser fails. I want to know why?
type timerMessage =
| Start of int
| Tick of bool
let timer = MailboxProcessor.Start(fun mbox ->
let inputloop() = async {
let progress = ref 0
let amount = ref 0
let start = ref System.DateTime.UtcNow
while true do
let! msg = mbox.Receive()
match msg with
| Start(i) -> amount := i
progress := 0
start := System.DateTime.UtcNow
| Tick(b) -> if !amount = 0 then ()
else
progress := !progress + 1
let el = System.DateTime.UtcNow - !start
let eta = int ((el.TotalSeconds/float !progress)*(float (!amount - !progress)))
let etas = (int (eta / 3600)).ToString() + ":" + (int ((eta % 3600) / 60)).ToString() + ":" + (eta % 60).ToString()
System.Console.Clear()
System.Console.Write((!progress).ToString() + "/" + (!amount).ToString() + " Completed [] Estimated Time Remaining:" + etas)
} inputloop() )
let computeBook (author :string) path =
let rs = ReadToStrings(path)
let bk = StringsToBook rs
let mt = createMatrix bk 100 10 //size 100 //span 10
let res = GetResults mt
//do stuff
timer.Post(Tick(true))
(author,path,res)
let partAopA = //clip head clip foot no word mods
let lss = seq {for x in processtree do
for y in (snd x) do
yield ((fst x),y) }
let ls = Seq.toArray lss //task list
timer.Post(Start(ls.Length)) //start counter
let compls = Array.map (fun l -> computeBook (fst l) (snd l) ) ls //Array.Parallel.map fails here the same as below async if I put async blcoks around the computbook call
//let res = compls |> Async.Parallel |> Async.RunSynchronously
writeResults compls outputfolder |> ignore
compls
I have a question concerning data structures that contain async operations.
It may sound weird.
TestActor contains a MailBoxProcessor and has three functions:
Receive prepares the mailbox processor to receive messages
Post and PostAndAsyncReply are used to send messages to the actor.
type TestActor (init, timeout) =
let mutable counter = init
let rcvFun = fun (msg) -> async {
match msg with
| Add i ->
counter <- counter + i
| GetCounter reply ->
reply.Reply counter}
do printfn "Initializing actors: "
do mailbox.Receive (rcvFun, timeout) ////// RECEIVE IS CALLED AT CONSTRUCTION
let mailbox = OnlyLatestMBP<TestMessage> ()
member x.Receive (timeout) =
mailbox.Receive (rcvFun, timeout)
member x.Post (msg: TestMessage, timeout) =
mailbox.Post(msg, timeout)
member x.PostAndAsyncReply (replyChannel, timeout) =
mailbox.PostAndAsyncReply(replyChannel, timeout)
I'd like to use this example to understand an issue that affected my code.
In the usual example for stacking agents in a data structure, Receive is executed at construction. In my example, the agent could be tested test with the code below:
let actorsWorkforce =
seq { 1 .. 5}
|> Seq.map (fun idx -> TestActor(idx, 60000))
let test =
actorsWorkforce
|> Seq.map ( fun idx -> idx.PostAndAsyncReply ( (fun reply -> GetCounter reply), 10000) )
|> Async.Parallel
|> Async.RunSynchronously
let result =
test
|> Array.iteri (fun idx element ->
match element with
| Some x -> printfn "Actor %i: OK with result %A" idx x
| None -> printfn "Actor %i: Failed" idx )
And this works as planned.
However, let's say I'd like to postpone the call to Receive to a later stage.
type TestActor (init) =
let mutable counter = init
let rcvFun = fun (msg) -> async {
match msg with
| Add i ->
counter <- counter + i
| GetCounter reply ->
reply.Reply counter}
let mailbox = OnlyLatestMBP<TestMessage> ()
member x.Receive (timeout) =
mailbox.Receive (rcvFun, timeout)
member x.Post (msg: TestMessage, timeout) =
mailbox.Post(msg, timeout)
member x.PostAndAsyncReply (replyChannel, timeout) =
mailbox.PostAndAsyncReply(replyChannel, timeout)
let actorsWorkforce =
seq { 1 .. 5}
|> Seq.map (fun idx -> TestActor(idx))
actorsWorkforce |> Seq.iter (fun idx -> idx.Receive (60000))
let test =
actorsWorkforce
|> Seq.map ( fun idx -> idx.PostAndAsyncReply ( (fun reply -> GetCounter reply), 10000) )
|> Async.Parallel
|> Async.RunSynchronously
let result =
test
|> Array.iteri (fun idx element ->
match element with
| Some x -> printfn "Actor %i: OK with result %A" idx x
| None -> printfn "Actor %i: Failed" idx )
This piece of code compiles but does not work.
mailbox.Receive has the type signature member Receive : callback:('a -> Async<unit>) * ?timeout:int -> unit so it would make sense to execute Receive with Seq.iter.
I suspect that the code does not work because actorsWorkforce |> Seq.iter (fun idx -> idx.Receive (60000)) duplicates actorsWorkforce when executed.
Is this correct? How can I fix this?
Thanks!
EDIT
The entire code:
open System
open System.Diagnostics
open Microsoft.FSharp.Control
open System.Threading
open System.Threading.Tasks
open System.Collections.Concurrent
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
// OnlyLatest
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
type Envelope<'a> = Option<DateTime * 'a>
[<Sealed>]
type AsyncReplyChannel<'Reply>(replyf : 'Reply -> unit) =
member x.Reply(reply) = replyf(reply)
[<Sealed>]
type OnlyLatestMBP<'a> () =
let mutable currentEnvelope: Envelope<'a> = Envelope<'a>.None
let mutable timestampLastPrcsd: DateTime = DateTime.Now
let mutable react = Unchecked.defaultof<_>
// Msg Box status
let mutable isActive = false
let mutable defaultTimeout = Timeout.Infinite
// Event Messages
let awaitMsg = new AutoResetEvent(false)
let isActiveMsg = new AutoResetEvent(false)
let rec await timeout = async {
let thr = Thread.CurrentThread.ManagedThreadId
printfn "await on thread %i" thr
match currentEnvelope with
| Some (timestamp, x) ->
if timestamp > timestampLastPrcsd then
do! react x
timestampLastPrcsd <- timestamp
printfn "processed message"
currentEnvelope <- Envelope.None
awaitMsg.Reset() |> ignore
return! await timeout
| None ->
let! recd = Async.AwaitWaitHandle(awaitMsg, timeout)
if recd
then return! await timeout
else
isActive <- false
isActiveMsg.Reset() |> ignore
printfn ".. no message within timeout, shutting down" }
member x.DefaultTimeout
with get() = defaultTimeout
and set(value) = defaultTimeout <- value
member x.Receive (callback, ?timeout) =
if not isActive then
isActive <- true
isActiveMsg.Set() |> ignore
let timeout = defaultArg timeout defaultTimeout
react <- callback
let todo = await timeout
Async.Start todo
member x.Post (msg, ?timeout) = async {
let thr = Thread.CurrentThread.ManagedThreadId
printfn "posting on thread %i" thr
let timeout = defaultArg timeout defaultTimeout
if not isActive then
let! recd = Async.AwaitWaitHandle(isActiveMsg, timeout)
if recd then
currentEnvelope <- Envelope.Some(DateTime.Now, msg)
awaitMsg.Set() |> ignore
return true
else return false
else
currentEnvelope <- Envelope.Some(DateTime.Now, msg)
awaitMsg.Set() |> ignore
return true }
member x.PostAndAsyncReply (replyChannelMsg, ?timeout) = async {
let timeout = defaultArg timeout defaultTimeout
let tcs = new TaskCompletionSource<_>()
let msg = replyChannelMsg ( new AsyncReplyChannel<_> (fun reply -> tcs.SetResult(reply)) )
let! posted = x.Post (msg,timeout)
if posted then
match timeout with
| Timeout.Infinite ->
let! result = Async.FromContinuations ( fun (cont, _, _) ->
let apply = fun (task: Task<_>) -> cont (task.Result)
tcs.Task.ContinueWith(apply) |> ignore )
return Some result
| _ ->
let waithandle = tcs.Task.Wait(timeout)
match waithandle with
| false -> return None
| true -> return Some tcs.Task.Result
else return None }
type TestMessage =
| Add of int
| GetCounter of AsyncReplyChannel<int>
type TestActor (init) =
let mutable counter = init
let rcvFun = fun (msg) -> async {
match msg with
| Add i ->
counter <- counter + i
| GetCounter reply ->
reply.Reply counter}
let mailbox = OnlyLatestMBP<TestMessage> ()
// do printfn "Initializing actors: "
// do mailbox.Receive (rcvFun, timeout)
member x.Receive (timeout) =
mailbox.Receive (rcvFun, timeout)
member x.Post (msg: TestMessage, timeout) =
mailbox.Post(msg, timeout)
member x.PostAndAsyncReply (replyChannel, timeout) =
mailbox.PostAndAsyncReply(replyChannel, timeout)
let actorsWorkforce =
seq { 1 .. 5}
|> Seq.map (fun idx -> TestActor(idx))
actorsWorkforce |> Seq.iter (fun actor -> actor.Receive (60000))
let test =
actorsWorkforce
|> Seq.map ( fun idx -> idx.PostAndAsyncReply ( (fun reply -> GetCounter reply), 10000) )
|> Async.Parallel
|> Async.RunSynchronously
let result =
test
|> Array.iteri (fun idx element ->
match element with
| Some x -> printfn "Actor %i: OK with result %A" idx x
| None -> printfn "Actor %i: Failed" idx )
As initially suspected, the issue was indeed with: actorsWorkforce |> Seq.iter (fun idx -> idx.Receive (60000))
The problem was due to the lazy nature of seq
I have produced a narrowed down minimal code example.
open System
open System.Diagnostics
open Microsoft.FSharp.Control
open System.Threading
open System.Threading.Tasks
open System.Collections.Concurrent
type TestActress (name, timerlength) =
let mutable isActive = false
let rec myTask () = async {
Thread.Sleep (timerlength * 1000)
printfn "%s waited : %i" name timerlength
return! myTask () }
member this.Start () =
isActive <- true
Async.Start (myTask ())
member this.GetStatus () = async {
Thread.Sleep (2000)
return isActive }
// One single element, this is easy
let cameronDiaz = TestActress ("Cameron", 10)
cameronDiaz.Start ()
let status = cameronDiaz.GetStatus () |> Async.RunSynchronously
// Async.Parallel receives a seq<Async<'T>> as an input
// This is why I started off with a seq
// This piece of code does not work
let hollywood =
[ "Cameron"; "Pamela"; "Natalie"; "Diane" ]
|> List.toSeq
|> Seq.mapi ( fun idx el -> TestActress (el, idx + 10) )
hollywood |> Seq.iter ( fun el -> el.Start () )
let areTheyWorking =
hollywood
|> Seq.map (fun el -> el.GetStatus ())
|> Async.Parallel
|> Async.RunSynchronously
// Allright, with a list I get the function executed when I expect them to
let hollywood2 =
[ "Cameron"; "Pamela"; "Natalie"; "Diane" ]
|> List.mapi ( fun idx el -> TestActress (el, idx + 10) )
hollywood2 |> List.iter ( fun el -> el.Start () )
let areTheyWorking2 =
hollywood2
|> List.map (fun el -> el.GetStatus ())
|> Async.Parallel
|> Async.RunSynchronously
I am implementing in-place graph BFS in OCaml.
here is my code:
type graph = {s : int list array;num_v:int;mutable num_e : int};;
let bfs u g p =
let marker = Array.make g.num_v false
in
let q = Queue.create()
in
Queue.push u q;
let rec add_to_queue v = function
| [] -> ()
| hd::tl ->
if not marker.(hd) then begin
marker.(hd) <- true;
Queue.push hd q;
p.(hd) <- v
end;
add_to_queue v tl
in
**let rec bfs_go =**
if Queue.length q > 0 then begin
let v = Queue.pop q
in
print_int v;
add_to_queue v g.s.(v);
bfs_go
end
in
bfs_go;;
I thought the code is fine, but compiler gives me this error:
File "", line 20, characters 4-177: Error: This kind of expression is not allowed as right-hand side of 'let rec'
It seems my implementation of bfs_go has issues ( i have marked with ** **), but why? I can't see any errors.
Edit:
DFS in functional style
let dfs_better u g p =
let marker = Array.make g.num_v false in
let rec dfs_go current next =
match current, next with
| [], _ -> ()
| parent::[], [] -> ()
| parent::next_parent::rest, [] -> dfs_go (next_parent::rest) g.s.(next_parent)
| parent::rest, node::tl ->
if not marker.(node) then begin
print_int node;
marker.(node) <- true;
p.(node) <- parent;
dfs_go next g.s.(node)
end;
dfs_go current tl in
marker.(u) <- true;
dfs_go [u] g.s.(u);;
You probably mean
let rec bfs_go () =
...;
bfs_go ()
instead of
let rec bfs_go =
...;
bfs_go
Edit: I couldn't resist some improvements.
With your imperative style:
let bfs start graph from =
let marker = Array.make graph.num_v false in
let q = Queue.create() in
let add_to_queue parent node =
if not marker.(node) then begin
marker.(node) <- true;
Queue.push node q;
from.(node) <- parent;
end in
Queue.push start q;
while not (Queue.is_empty q) do
let node = Queue.pop q in
print_int node;
List.iter (add_to_queue node) graph.s.(node)
done
If you want something more functional:
let bfs start graph from =
let marker = Array.make graph.num_v false in
let rec bfs current next = match current, next with
| [], [] -> ()
| [], (_::_ as next) -> bfs next []
| node::current, next ->
let add parent node next =
if marker.(node) then next
else begin
marker.(node) <- true;
from.(node) <- parent;
node :: next
end in
print_int node;
bfs current (List.fold_right (add node) graph.s.(node) next)
in bfs [start] []
Edit 2:
Attempts at the DFS problem, completely untested (just compiled):
With a data-structure to handle nodes left to visit:
let dfs u g p =
let marker = Array.make g.num_v false in
let rec dfs_go = function
| [] -> ()
| node::next ->
print_int node;
let children =
List.filter (fun child -> not marker.(child)) g.s.(node) in
List.iter (fun child -> marker.(child) <- true) children;
dfs_go (children # next)
in
marker.(u) <- true;
dfs_go [u];;
Using only (non-tail) recursion:
let dfs u g p =
let marker = Array.make g.num_v false in
let rec dfs_go node =
print_int node;
let go_child child =
if not marker.(child) then begin
marker.(child) <- true;
dfs_go child;
end in
List.iter go_child g.s.(node)
in
marker.(u) <- true;
dfs_go u;;
I have 4 arrays of different data. For the first array of string, I want to delete the duplicate element and get the results of array of unique tuples with 4 elements.
For example, let's say the arrays are:
let dupA1 = [| "A"; "B"; "C"; "D"; "A" |]
let dupA2 = [| 1; 2; 3; 4; 1 |]
let dupA3 = [| 1.0M; 2.0M; 3.0M; 4.0M; 1.0M |]
let dupA4 = [| 1L; 2L; 3L; 4L; 1L |]
I want the result to be:
let uniqueArray = [| ("A", 1, 1.0M, 1L); ("B", 2, 2.0M, 2L); ("C", 3, 3.0M, 3L); ("D",4, 4.0M, 4L) |]
You will first need to write a zip4 function which will zip the arrays:
// the function assumes the 4 arrays are of the same length
let zip4 a (b : _ []) (c : _ []) (d : _ []) =
Array.init (Array.length a) (fun i -> a.[i], b.[i], c.[i], d.[i])
Then a distinct function for arrays, using Seq.distinct:
let distinct s = Seq.distinct s |> Array.ofSeq
And the result would be:
> zip4 dupA1 dupA2 dupA3 dupA4 |> distinct;;
val it : (string * int * decimal * int64) [] =
[|("A", 1, 1.0M, 1L); ("B", 2, 2.0M, 2L); ("C", 3, 3.0M, 3L);
("D", 4, 4.0M, 4L)|]
let zip4 s1 s2 s3 s4 =
Seq.map2 (fun (a,b)(c,d) ->a,b,c,d) (Seq.zip s1 s2)(Seq.zip s3 s4)
let uniqueArray = zip4 dupA1 dupA2 dupA3 dupA4 |> Seq.distinct |> Seq.toArray