This is a follow-up on this previous question, but with a different twist.
I would like to write a function which, given an object oMap, returns its count if oMap happens to be of type Map<'k,'v>, and -1 otherwise. My constraint : oMap type can only be 'discovered' at runtime.
As apparently "there is no built-in way to pattern match on a generic Map." (see link to previous question), I am using reflection for this.
namespace genericDco
module Test1 =
let gencount (oMap : obj) : int =
let otype = oMap.GetType()
let otypenm = otype.Name
if otypenm = "FSharpMap`2" then
// should work, as oMap of type Map<'a,'b>, but does not. *How to fix this?*
Map.count (unbox<Map<_,_>> oMap)
else
// fails, as oMap is not of any type Map<'a,'b>.
-1
let testfailObj : int = gencount ("foo")
// FAILS
let testsuccessObj : int =
let oMap = [| ("k1", "v1"); ("k1", "v1") |] |> Map.ofArray
gencount (box oMap)
The error being :
System.InvalidCastException: Unable to cast object of type 'Microsoft.FSharp.Collections.FSharpMap`2[System.String,System.String]' to type 'Microsoft.FSharp.Collections.FSharpMap`2[System.IComparable,System.Object]'. at Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicFunctions.UnboxGeneric[T](Object source)
My question: How should I rewrite the above to get this to work?
PS : I am not looking for solutions where we know at compile time that oMap is of type Map<'k,'v>, e.g. :
module Test2 =
let gencount2<'k,'v when 'k : comparison> (gMap : Map<'k,'v>) : int =
Map.count gMap
let testsuccessStr : int =
let gMap = [| ("k1", "v1"); ("k2", "v2") |] |> Map.ofArray
gencount2<string,string> gMap
let testsuccessDbl : int =
let gMap = [| ("k1", 1.0); ("k2", 2.0); ("k3", 3.0) |] |> Map.ofArray
gencount2<string,double> gMap
== EDIT ==
Thanks to Asti's suggestion, that's the solution that worked for me :
let gencount (oMap : obj) : int =
let otype = oMap.GetType()
let propt = otype.GetProperty("Count")
try
propt.GetValue(oMap) :?> int
with
| _ -> -1
Since Map.count is just defined as let count m = m.Count, we can just go for the Count property.
let gencount<'k,'v when 'k : comparison> map =
let mtype = typeof<Map<'k, 'v>>
let propt = mtype.GetProperty("Count")
if map.GetType() = mtype then
propt.GetValue(map) :?> int
else
-1
Test:
[<EntryPoint>]
let main argv =
let m = Map.ofSeq [ ("a", 1); ("b", 2)]
printfn "%d" (gencount<string, int> m)
printfn "%d" (gencount<string, string> m)
Console.ReadKey() |> ignore
0 // return exit code 0
Using _ in place of a type will simply end up as object if no additional constraint information is available. You use unbox when you strongly know what type your value is, except that the value is boxed in.
Related
I need to run a process that runs something from a list - it doesn't really matter what order it runs in - but I want it to update a global "counter" when it has completed each task so that I can see the progress somewhere else ( maybe using something like signal R )
I used to do this stuff in an object-oriented way - but trying to be a little more "functional".
let doSomethingElse(value: int) = async{
// Update a global counter incrementing it by 1
return true
}
let doSomething() = async{
let values = [2; 4; 6; 8]
let! newList = values |> List.map(fun value -> doSomethingElse(value)) |> Async.Parallel
return true
}
Following what #JL0PD mentioned you could do something like the following.
[<RequireQualifiedAccess>]
module Async =
let tee (f: _ -> unit) a =
async {
let! r = a
f r
return r
}
module Counter =
let create () =
let mutable counter = 0
let increment =
fun _ ->
counter <- counter + 1
()
(increment, fun () -> counter)
let doSomethingElse(value: int) = async {
return value % 2
}
let doSomething() = async {
let values = [1; 2; 4; 6; 8; 9]
let increment, getCount = Counter.create()
let doSomethingElseWithProgress =
doSomethingElse
>> (Async.tee increment)
let! _ =
values
|> List.map doSomethingElseWithProgress
|> Async.Parallel
return getCount() = (List.length values)
}
doSomething ()
|> Async.RunSynchronously
I do recommend doing something better than a mutable counter, specially since you are dealing with parallel tasks.
In this case I'm composing doSomethingElse and increment using tee, this way doSomethingElse don't have to know (and call) an external function.
I'm trying to build an initial Trie structure in OCaml where the edges are the char. So the string "ESK" would be mapped as:
[('E', [('S', [('K', [])])])]
My definition for this is:
type trie = Trie of (char * trie) list
However, on implementing an add function with:
let rec add_string str =
let key = String.get str 0 in
if String.length str = 1 then
(key, empty_trie) :: []
else
(key, add_string (tail str)) :: []
for add (tail str) the compiler gives me:
Error: This expression has type (char * trie) list
but an expression was expected of type trie
I'm a bit puzzled by this as I have not defined a trie as (char * trie) list?
tail is simply let tail str = String.slice str 1 (String.length str) and empty_trie is let empty_trie = Trie([])
Note that a more idiomatic way of writing the function would be
let rec add_string str =
let key = str.[0] in
if String.length str = 1 then
Trie [key, empty_trie]
else
Trie [key, add_string (tail str)]
Then there are two problems left with add_string: first it reallocates a new string at each iteration. It is simpler and more efficient to keep track of the current position:
let add_string str =
let rec add_string_aux pos str =
if pos = String.length str then empty_trie
else
let key = str.[pos] in
Trie [key, add_string_aux (pos+1) str] in
add_string_aux 0 str
The second problem is that the function is ill-named since it does not add a string to an existing trie but build a trie from a string: from_string or of_string might be better names.
Resolved. Trie should be explicitly used:
let rec add_string str =
let key = String.get str 0 in
if String.length str = 1 then
(key, empty_trie) :: []
else
(key, Trie (add_string (tail str))) :: []
This will result in add_string "ESK" producing:
(char * trie) list = [('E', Trie [('S', Trie [('K', Trie [])])])]
I'm trying to define a propositional logic valuation using SML structure. A valuation in propositional logic maps named variables (i.e., strings) to Boolean values.
Here is my signature:
signature VALUATION =
sig
type T
val empty: T
val set: T -> string -> bool -> T
val value_of: T -> string -> bool
val variables: T -> string list
val print: T -> unit
end;
Then I defined a matching structure:
structure Valuation :> VALUATION =
struct
type T = (string * bool) list
val empty = []
fun set C a b = (a, b) :: C
fun value_of [] x = false
| value_of ((a,b)::d) x = if x = a then b else value_of d x
fun variables [] = []
| variables ((a,b)::d) = a::(variables d )
fun print valuation =
(
List.app
(fn name => TextIO.print (name ^ " = " ^ Bool.toString (value_of valuation name) ^ "\n"))
(variables valuation);
TextIO.print "\n"
)
end;
So the valuations should look like [("s",true), ("c", false), ("a", false)]
But I can't declare like a structure valuation or make an instruction like: [("s",true)]: Valuation.T; When I tried to use the valuation in a function, I get errors like:
Can't unify (string * bool) list (*In Basis*) with
Valuation.T
Could someone help me? Thanks.
The type Valuation.T is opaque (hidden).
All you know about it is that it's called "T".
You can't do anything with it except through the VALUATION signature, and that signature makes no mention of lists.
You can only build Valuations using the constructors empty and set, and you must start with empty.
- val e = Valuation.empty;
val e = - : Valuation.T
- val v = Valuation.set e "x" true;
val v = - : Valuation.T
- val v2 = Valuation.set v "y" false;
val v2 = - : Valuation.T
- Valuation.value_of v2 "x";
val it = true : bool
- Valuation.variables v2;
val it = ["y","x"] : string list
- Valuation.print v2;
y = false
x = true
val it = () : unit
Note that every Valuation.T value is printed as "-" since the internal representation isn't exposed.
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 have two files: myUnionFind.ml and myUnionFind_test.ml. Both files are in the same directory.
myUnionFind.ml
open Batteries
module type MyUnionFindSig =
sig
type union_find
val print_array : 'a array -> unit
val create_union : int -> union_find
val union_weighted : union_find -> int -> int -> unit
val is_connected_weighted : union_find -> int -> int -> bool
end;;
module MyUnionFind : MyUnionFindSig =
struct
let print_array ary = print_endline (BatPervasives.dump ary);;
type union_find = {id_ary : int array; sz_ary : int array};;
let create_union n = {id_ary = Array.init n (fun i -> i);
sz_ary = Array.make n 1};;
(* weighted quick union find *)
let find_root ary i =
let rec find j =
if ary.(j) = j then j
else find ary.(j)
in
find i;;
let union_weighted {id_ary;sz_ary} p q =
let root_p = find_root id_ary p in
let root_q = find_root id_ary q in
if sz_ary.(root_p) < sz_ary.(root_q) then begin
id_ary.(root_p) <- id_ary.(root_q);
sz_ary.(root_q) <- sz_ary.(root_q) + sz_ary.(root_p)
end
else begin
id_ary.(root_q) <- id_ary.(root_p);
sz_ary.(root_p) <- sz_ary.(root_p) + sz_ary.(root_q)
end;;
let is_connected_weighted {id_ary;_} p q = (find_root id_ary p) = (find_root id_ary q);;
end
myUnionFind_test.ml
open Batteries
let uf2 = MyUnionFind.create_union 10;;
MyUnionFind.union_weighted uf2 0 3;;
MyUnionFind.union_weighted uf2 1 4;;
MyUnionFind.union_weighted uf2 4 3;;
MyUnionFind.union_weighted uf2 2 8;;
MyUnionFind.print_array uf2.MyUnionFind.id_ary;;
BatPervasives.print_bool (MyUnionFind.is_connected_weighted uf2 0 3);;
I tried
ocamlfind ocamlc -package batteries -c myUnionFind.ml. It worked, I can see myUnionFind.cmi and myUnionFind.cmo.
Then I tried to compile myUnionFind_test.ml via
ocamlfind ocamlc -package batteries -c myUnionFind_test.ml.
It gives this error:
File "myUnionFind_test.ml", line 3, characters 10-34: Error: Unbound
value MyUnionFind.create_union
I can't figure out why. I have defined create_union in module MyUnionFind, but why it can't be found?
You define a module in a module (your myUnionFind.ml is a module).
So in your test file, you have to open your module like this:
open Batteries
open MyUnionFind (* Here !*)
let uf2 = MyUnionFind.create_union 10;;
MyUnionFind.union_weighted uf2 0 3;;
MyUnionFind.union_weighted uf2 1 4;;
MyUnionFind.union_weighted uf2 4 3;;
MyUnionFind.union_weighted uf2 2 8;;
MyUnionFind.print_array uf2.MyUnionFind.id_ary;;
BatPervasives.print_bool (MyUnionFind.is_connected_weighted uf2 0 3);;
or prefix each call like:
let uf2 = MyUnionFind.MyUnionFind.create_union 10;;
If you just define a module in myUnionFind.ml and you don't want to have two modules like previously, you can just create a .ml and .mli file like this:
(* myUnionFind.mli *)
type union_find = {id_ary : int array; sz_ary : int array}
val print_array : 'a array -> unit
val create_union : int -> union_find
val union_weighted : union_find -> int -> int -> unit
val is_connected_weighted : union_find -> int -> int -> bool
(* myUnionFind.ml *)
type union_find = {id_ary : int array; sz_ary : int array};;
let print_array ary = (* ... *)
let create_union n = (* ... *)
let union_weighted r p q = (* ... *)
let find_root ary i = (* ... *)
Be careful, if you have a reference to id_ary field, you have to put it in the module signature
OCaml gives you one level of module for free with each file. So your myUnionFind.ml has a module within this free module. To avoid this, declare everything at the top level of the file. Then you have just one module, with the same name as the file.