F# StackOverflow in mono with continuations (tail call eliminations enabled) - f#

I was running a example of an interpreter made with Continuations, and it fails in Mono JIT compiler version 4.3.0 with a stackoverflow error despite the Tail Call optimization enabled. The same code works fine in Windows (.NET 4.6).
This is the code:
open System
open System.Runtime
let print x = printfn "%A" x
type 'data env = (string * 'data) list
let rec lookup env x =
match env with
| [] -> failwith (x + " not found")
| (y, v)::yr -> if x=y then v else lookup yr x
(* Abstract syntax of functional language with exceptions *)
type exn =
| Exn of string
type expr =
| CstI of int
| CstB of bool
| Var of string
| Let of string * expr * expr
| Prim of string * expr * expr
| If of expr * expr * expr
| Letfun of string * string * expr * expr (* (f, x, fbody, ebody) *)
| Call of string * expr
| Raise of exn
| TryWith of expr * exn * expr (* try e1 with exn -> e2 *)
type value =
| Int of int
| Closure of string * string * expr * value env (* (f, x, fBody, fDeclEnv) *)
type answer =
| Result of int
| Abort of string
let rec coEval2 (e : expr) (env : value env) (cont : int -> answer)
(econt : exn -> answer) : answer =
match e with
| CstI i -> cont i
| CstB b -> cont (if b then 1 else 0)
| Var x ->
match lookup env x with
| Int i -> cont i
| _ -> Abort "coEval2 Var"
| Prim(ope, e1, e2) ->
coEval2 e1 env
(fun i1 ->
coEval2 e2 env
(fun i2 ->
match ope with
| "*" -> cont(i1 * i2)
| "+" -> cont(i1 + i2)
| "-" -> cont(i1 - i2)
| "=" -> cont(if i1 = i2 then 1 else 0)
| "<" -> cont(if i1 < i2 then 1 else 0)
| _ -> Abort "unknown primitive") econt) econt
| Let(x, eRhs, letBody) ->
coEval2 eRhs env (fun xVal ->
let bodyEnv = (x, Int xVal) :: env
coEval2 letBody bodyEnv cont econt)
econt
| If(e1, e2, e3) ->
coEval2 e1 env (fun b ->
if b<>0 then coEval2 e2 env cont econt
else coEval2 e3 env cont econt) econt
| Letfun(f, x, fBody, letBody) ->
let bodyEnv = (f, Closure(f, x, fBody, env)) :: env
coEval2 letBody bodyEnv cont econt
| Call(f, eArg) ->
let fClosure = lookup env f
match fClosure with
| Closure (f, x, fBody, fDeclEnv) ->
coEval2 eArg env
(fun xVal ->
let fBodyEnv = (x, Int xVal) :: (f, fClosure) :: fDeclEnv
coEval2 fBody fBodyEnv cont econt)
econt
| _ -> raise (Failure "eval Call: not a function")
| Raise exn -> econt exn
| TryWith (e1, exn, e2) ->
let econt1 thrown =
if thrown = exn then coEval2 e2 env cont econt
else econt thrown
coEval2 e1 env cont econt1
(* The top-level error continuation returns the continuation,
adding the text Uncaught exception *)
let eval2 e env =
coEval2 e env
(fun v -> Result v)
(fun (Exn s) -> Abort ("Uncaught exception: " + s))
let run2 e = eval2 e []
(* Example: deep recursion to check for constant-space tail recursion *)
let exdeep = Letfun("deep", "x",
If(Prim("=", Var "x", CstI 0),
CstI 1,
Call("deep", Prim("-", Var "x", CstI 1))),
Call("deep", Var "n"));
let rundeep n = eval2 exdeep [("n", Int n)];
[<EntryPoint>]
let main argv =
rundeep 10000 |> ignore
"All fine!" |> print
0
I found that this is a problem with MONO but I wonder if there exists a way to work around this (I wish to do CSP to implement several features for the interpreter)
It is also notable that disabling the tail call optimization triggers the stackoverflow error way faster on windows than on mono/osx.

I reimplemented coEval2 using a trampoline. This function I cleverly called coEval3. coEval2 crashes for me in Debug and works in Release as expected. coEval3 seemed to work for me in both Debug and Release.
// After "jumping" the trampoline we either have a result (Done)
// or we need to "jump" again (Next)
type result<'T> =
| Done of 'T
| Next of (unit -> result<'T>)
let coEval3 (e : expr) (env : value env) (cont : int -> answer) (econt : exn -> answer) : answer =
// "Jumps" once producing either a result or a new "jump"
let rec jump (e : expr) (env : value env) (cont : int -> result<answer>) (econt : exn -> result<answer>) () : result<answer> =
match e with
| CstI i -> cont i
| CstB b -> cont (if b then 1 else 0)
| Var x ->
match lookup env x with
| Int i -> cont i
| _ -> Abort "coEval2 Var" |> Done
| Prim(ope, e1, e2) ->
jump e1 env
(fun i1 ->
jump e2 env
(fun i2 ->
match ope with
| "*" -> cont(i1 * i2)
| "+" -> cont(i1 + i2)
| "-" -> cont(i1 - i2)
| "=" -> cont(if i1 = i2 then 1 else 0)
| "<" -> cont(if i1 < i2 then 1 else 0)
| _ -> Abort "unknown primitive" |> Done) econt |> Next) econt |> Next
| Let(x, eRhs, letBody) ->
jump eRhs env (fun xVal ->
let bodyEnv = (x, Int xVal) :: env
jump letBody bodyEnv cont econt |> Next)
econt |> Next
| If(e1, e2, e3) ->
jump e1 env (fun b ->
if b<>0 then jump e2 env cont econt |> Next
else jump e3 env cont econt |> Next) econt |> Next
| Letfun(f, x, fBody, letBody) ->
let bodyEnv = (f, Closure(f, x, fBody, env)) :: env
jump letBody bodyEnv cont econt |> Next
| Call(f, eArg) ->
let fClosure = lookup env f
match fClosure with
| Closure (f, x, fBody, fDeclEnv) ->
jump eArg env
(fun xVal ->
let fBodyEnv = (x, Int xVal) :: (f, fClosure) :: fDeclEnv
jump fBody fBodyEnv cont econt |> Next)
econt |> Next
| _ -> raise (Failure "eval Call: not a function")
| Raise exn -> econt exn
| TryWith (e1, exn, e2) ->
let econt1 thrown =
if thrown = exn then jump e2 env cont econt |> Next
else econt thrown
jump e1 env cont econt1 |> Next
(* The top-level error continuation returns the continuation,
adding the text Uncaught exception *)
// If trampoline is tail-recursive F# will implement this as a loop,
// this is important for us as this means that the recursion is essentially
// turned into a loop
let rec trampoline j =
match j () with
| Done v -> v
| Next jj -> trampoline jj
let inline lift f v = f v |> Done
trampoline (jump e env (lift cont) (lift econt))
Hope this is somewhat useful

Related

Extend the W algorithm to containers

I would like to extend the W algorithm to the inference of tuples and lists in F#, a priori, there are only two rules to add, which I did, however, the result is partially bad.
Indeed, if I test a code like these:
test = (8, "Hello", 0.3) -- test :: (TInt, TString, TFloat)
id :: a -> a
id x = x -- id :: a -> a
foo = id 8 -- foo :: TInt
it works, on the other hand, as detailed in the examples below, a code like this one will not work:
makePair = (\x -> (x, x)) -- makePair :: a -> (a, a)
pair = makePair 7
and pair will be inferred as (a, a) instead of (TInt, TInt).
Same for the lists.
I used this paper to write my type checker.
I really don't understand what's jamming.
Here is the minimum functional program used for these examples:
Inference.fs
module Typechecker
type Identifier = string
and Expr =
| Var of Identifier
| Lambda of Identifier * Expr
| Apply of Expr * Expr
| Let of Identifier * Expr * Expr
| Literal of Literal
| Tuple of Expr list
| List of Expr list
and Literal =
| Int of int
| Float of float
| String of string
and Statement =
| Signature of Identifier * Type
| Declaration of Identifier * Expr
and Type =
| TVar of Identifier
| TInt
| TFloat
| TString
| TArrow of Type * Type
| TTuple of Type list
| TList of Type
type Program = Program of Statement list
type Scheme = Scheme of string list * Type
and TypeEnv = Map<Identifier, Scheme>
and Subst = Map<string, Type>
type Env =
{ mutable _functions: Function list }
with
member this.containsFunction name =
this._functions |> List.exists (fun f -> f._name = name)
member this.getFunction name =
this._functions
|> List.find (fun (f: Function) -> f._name = name)
member this.getFunctionType name =
(this.getFunction name)._type
member this.hasFunctionImplementation name =
if this.containsFunction name
then (this.getFunction name)._value.IsSome
else false
member this.getFunctionValue name =
(this.getFunction name)._value.Value
/// Updates the value of a function in the environment
member this.updateFunction_value name value =
(this.getFunction name)._value <- Some value
this
/// Updates the type of a function in the environment
member this.updateFunction_type name ty =
(this.getFunction name)._type <- ty
this
member this.addFunction name ty value =
{ _functions =
List.append
this._functions
[{ _name = name;
_type = ty;
_value = value }] }
and Function =
{ _name: Identifier;
mutable _type: Type;
mutable _value: Expr option }
and DataType =
{ _name: Identifier;
_isAlias: bool;
_constructors: Ctor list option
_alias: Type option }
and Ctor = Term of Identifier | Product of Type list
let newEnv = { _functions = [] }
module Type =
let rec ftv = function
| TInt -> Set.empty
| TFloat -> Set.empty
| TString -> Set.empty
| TVar name -> Set.singleton name
| TArrow(t1, t2) -> Set.union (ftv t1) (ftv t2)
| TTuple ts -> List.fold (fun acc t -> Set.union acc (ftv t)) Set.empty ts
| TList t -> Set.singleton (toString t)
and apply s t =
match t with
| TVar name ->
match Map.tryFind name s with
| Some t -> t
| None -> TVar name
| TArrow (t1, t2) ->
TArrow(apply s t1, apply s t2)
| TInt | TFloat | TString -> t
| _ -> t
and parens s =
sprintf "(%s)" s
and braces s =
sprintf "{ %s }" s
and toString t =
let rec parenType t' =
match t' with
| TArrow(_, _) -> parens (toString t')
| _ -> toString t'
match t with
| TVar name -> name
| TInt -> "Integer"
| TFloat -> "Float"
| TString -> "String"
| TArrow(t1, t2) ->
(parenType t1) + " -> " + (toString t2)
| TTuple ts -> sprintf "(%s)" (System.String.Join(", ", List.map toString ts))
| TList t -> sprintf "[%s]" (toString t)
module Scheme =
let rec ftv (scheme: Scheme) =
match scheme with
| Scheme(variables, t) ->
Set.difference(Type.ftv t) (Set.ofList variables)
and apply (s: Subst) (scheme: Scheme) =
match scheme with
| Scheme(variables, t) ->
let newSubst = List.foldBack (fun key currentSubst -> Map.remove key currentSubst) variables s
let newType = Type.apply newSubst t
Scheme(variables, newType)
module TypeEnv =
let rec remove (env: TypeEnv) (var: Identifier) =
Map.remove var env
and ftv (typeEnv: TypeEnv) =
Seq.foldBack (fun (KeyValue(_, v)) state ->
Set.union state (Scheme.ftv v)) typeEnv Set.empty
and apply (s: Subst) (env: TypeEnv) =
Map.map (fun _ value -> Scheme.apply s value) env
module Subst =
let compose s1 s2 =
Map.union (Map.map (fun _ (v: Type) -> Type.apply s1 v) s2) s1
let rec generalize (env: TypeEnv) (t: Type) =
let variables =
Set.difference (Type.ftv t) (TypeEnv.ftv env)
|> Seq.toList
Scheme(variables, t)
and private currentId = ref 'a'
and nextId () =
let id = !currentId
currentId := (char ((int !currentId) + 1))
id
and resetId () = currentId := 'a'
and newTyVar () =
TVar(sprintf "%c" (nextId ()))
and instantiate (ts: Scheme) =
match ts with
| Scheme(variables, t) ->
let nvars = variables |> List.map (fun name -> newTyVar ())
let s = List.zip variables nvars |> Map.ofList
Type.apply s t
and varBind a t =
match t with
| TVar name when name = a -> Map.empty
| _ when Set.contains a (Type.ftv t) ->
failwithf "Occur check fails: `%s` vs `%s`" a (Type.toString t)
| _ -> Map.singleton a t
and unify (t1: Type) (t2: Type) : Subst =
match t1, t2 with
| TVar a, t | t, TVar a -> varBind a t
| TInt, TInt -> Map.empty
| TFloat, TFloat -> Map.empty
| TString, TString -> Map.empty
| TArrow(l, r), TArrow(l', r') ->
let s1 = unify l l'
let s2 = unify (Type.apply s1 r) (Type.apply s1 r')
Subst.compose s2 s1
| TTuple ts, TTuple ts' ->
if ts.Length <> ts'.Length
then failwithf "Types do not unify: `%s` vs `%s`" (Type.toString t1) (Type.toString t2)
else List.fold Subst.compose Map.empty (List.map2 unify ts ts')
| TList t, TList t' ->
unify t t'
| _ -> failwithf "Types do not unify: `%s` vs `%s`" (Type.toString t1) (Type.toString t2)
and tiLit = function
| Literal.Int _ -> Type.TInt
| Literal.Float _ -> Type.TFloat
| Literal.String _ -> Type.TString
and tiExpr (env: TypeEnv) (exp: Expr) : Subst * Type =
match exp with
| Var name ->
match Map.tryFind name env with
| Some sigma ->
let t = instantiate sigma
(Map.empty, t)
| None -> failwithf "Unbound variable: `%s`" name
| Literal lit -> (Map.empty, tiLit lit)
| Let(id, expr, in') ->
let s1, t1 = tiExpr env expr
let env1 = TypeEnv.remove env id
let scheme = generalize (TypeEnv.apply s1 env) t1
let env2 = Map.add id scheme env1
let s2, t2 = tiExpr (TypeEnv.apply s1 env2) in'
(Subst.compose s2 s1, t2)
| Lambda(id, value) ->
let tv = newTyVar ()
let env1 = TypeEnv.remove env id
let env2 = Map.union env1 (Map.singleton id (Scheme([], tv)))
let s1, t1 = tiExpr env2 value
(s1, TArrow(Type.apply s1 tv, t1))
| Tuple values ->
(Map.empty, TTuple(List.map (fun v -> snd (tiExpr env v)) values))
| List ts ->
let tv = newTyVar ()
if ts.IsEmpty
then (Map.empty, TList tv)
else
let _, t1 = tiExpr env ts.[0]
if List.forall (fun t -> snd (tiExpr env t) = t1) ts
then (Map.empty, TList t1)
else failwith "Not all items in the list are of the same type"
| Apply(e1, e2) ->
let s1, t1 = tiExpr env e1
let s2, t2 = tiExpr (TypeEnv.apply s1 env) e2
let tv = newTyVar ()
let s3 = unify (Type.apply s2 t1) (TArrow(t2, tv))
(Subst.compose (Subst.compose s3 s2) s1, Type.apply s3 tv)
and expression_typeInference env exp =
let s, t = tiExpr env exp
Type.apply s t
and updateExprEnv (env: Env) =
let mutable env' = Map.empty
List.iter
(fun (f: Function) ->
env' <- env'.Add(f._name, Scheme([f._name], f._type))
) env._functions
env'
let rec public statement_typecheck (env: Env) stmt =
let exprEnv = updateExprEnv env
match stmt with
| Signature(id, dastType) ->
typecheck_signature env id dastType
| Declaration(id, value) ->
typecheck_decl env id value exprEnv
and private typecheck_signature (env: Env) id ty =
if env.hasFunctionImplementation id
then failwithf "The type of a function cannot be defined after its implementation (`%s`)" id
else env.addFunction id ty None
and private typecheck_decl (env: Env) id value exprEnv =
let _, t_exp = tiExpr exprEnv value
if env.containsFunction id
then if env.hasFunctionImplementation id
then failwithf "Already declared function: `%s`" id
else
let t_sgn = (env.getFunction id)._type
let unapp = try (Type.apply ((unify t_sgn t_exp)) t_exp)
|> Ok with exn -> failwithf "%s" exn.Message
if match unapp with Result.Ok _ -> true
then env.updateFunction_value id value
else failwithf "The signature of `%s` is different than the type of its value\n (`%s` vs `%s`)"
id (Type.toString t_sgn) (Type.toString t_exp)
else env.addFunction id t_exp (Some value)
let typecheck_document (document: Program) =
let mutable docenv = newEnv
match document with Program stmts ->
List.iter (fun stmt -> docenv <- statement_typecheck docenv stmt) stmts
docenv
Main.fs
module Main
open Inference
[<EntryPoint>]
let main _ =
let test1 =
[Declaration("makePair", Lambda("x", Tuple([Var "x"; Var "x"]))); // makePair = (\x -> (x, x))
Declaration("pair", Apply(Var "makePair", Literal (Int 7)))] // pair = makePair 7
let infer1 = typecheck_document (Program test1)
printfn "Env1: %A" infer1
let test2 =
[Signature("id", TArrow(TVar "a", TVar "a")); // id :: a -> a
Declaration("id", Lambda("x", Var "x")) // id x = x
Declaration("foo", Apply(Var "id", Literal (Int 7)))] // foo = id 7
let infer2 = typecheck_document (Program test2)
printfn "Env2: %A" infer2
0
Here is the output:
Env1: {_functions =
[{_name = "makePair";
_type = TArrow (TVar "a",TTuple [TVar "a"; TVar "a"]);
_value = Some (Lambda ("x",Tuple [Var "x"; Var "x"]));};
{_name = "pair";
_type = TTuple [TVar "a"; TVar "a"];
_value = Some (Apply (Var "makePair",Literal (Int 7)));}];}
Env2: {_functions =
[{_name = "id";
_type = TArrow (TVar "a",TVar "a");
_value = Some (Lambda ("x",Var "x"));};
{_name = "test";
_type = TInt;
_value = Some (Apply (Var "id",Literal (Int 7)));}];}
So we can see that the inference works correctly for the first test, but not for the second (as shown above).
I would like to solve and understand this bug, and I thank you in advance for your help.
As far as I read in your code, it seems like you're missing a branch in apply.
Indeed, when t is a Tuple [], you're basically only returning it...which well will of course not work. :)
I suggest adding one branch to the match, with t as a Tuple types, with a map (\t -> apply s t) types (sorry, I don't know much F# syntax).
Hope it helps. :)

Railway Oriented Programming and partial application

I like using ROP when I have to deal with IO/Parsing strings/...
However let's say that I have a function taking 2 parameters. How can you do clean/readable partial application when your 2 parameters are already a Result<'a,'b> (not necessary same 'a, 'b)?
For now, what I do is that I use tuple to pass parameters and use the function below to get a Result of a tuple so I can then bind my function with this "tuple-parameter".
/// Transform a tuple of Result in a Result of tuple
let tupleAllResult x =
match (fst x, snd x) with
| Result.Ok a, Result.Ok b -> (a,b) |> Result.Ok
| Result.Ok a, Result.Error b -> b |> Result.Error
| Result.Error a, _ -> a |> Result.Error
let f (a: 'T, b: 'U) = // something
(A, B) |> tupleAllResult
|> (Result.bind f)
Any good idea?
Here what I wrote, which works but might not be the most elegant
let resultFunc (f: Result<('a -> Result<'b, 'c>), 'd>) a =
match f with
| Result.Ok g -> (g a) |> Result.Ok |> Result.flatten
| Result.Error e -> e |> Result.Error |> Result.flatten
I am not seeing partial application in your example, a concept related to currying and argument passing -- that's why I am assuming that you are after the monadic apply, in that you want to transform a function wrapped as a Result value into a function that takes a Result and returns another Result.
let (.>>.) aR bR = // This is "tupleAllResult" under a different name
match aR, bR with
| Ok a, Ok b -> Ok(a, b)
| Error e, _ | _, Error e -> Error e
// val ( .>>. ) : aR:Result<'a,'b> -> bR:Result<'c,'b> -> Result<('a * 'c),'b>
let (<*>) fR xR = // This is another name for "apply"
(fR .>>. xR) |> Result.map (fun (f, x) -> f x)
// val ( <*> ) : fR:Result<('a -> 'b),'c> -> xR:Result<'a,'c> -> Result<'b,'c>
The difference to what you have in your question is map instead of bind in the last line.
Now you can start to lift functions into the Result world:
let lift2 f xR yR =
Ok f <*> xR <*> yR
// val lift2 :
// f:('a -> 'b -> 'c) -> xR:Result<'a,'d> -> yR:Result<'b,'d> -> Result<'c,'d>
let res : Result<_,unit> = lift2 (+) (Ok 1) (Ok 2)
// val res : Result<int,unit> = Ok 3

F#: how to convert expression to string

Hello I have a been given the problem:
Write an F# function toString: aexpr -> string to format expressions
as strings, with the binary operators written in infix format. For
instance, it may format Sub(Var "x", CstI 34) as the string "x -
34". For simplicity, put parentheses around any subexpressions, even
when they are superfluous according to the standard precedence rules
for arithmetic operators. Use the predefined function string to convert
an integer value to its string representation.
Hint: toString has very much the same structure as an eval function,
although it needs no environment argument because it uses variables
names, not variable values.
yes this is a HW problem. Any help would greatly be appreciated with explanations. Below I included an eval function
These are data types we have been using:
type oper1 = Neg | Not
type oper2 = Add | Mul | Sub | Less | Eq | And
type aexpr =
| C of int
| V of string
| Op1 of oper1 * aexpr
| Op2 of oper2 * aexpr * aexpr
let rec eval e (env : (string * int) list) : int =
match e with
| CstI i -> i
| Var x -> lookup env x
| Prim("+", e1, e2) -> (eval e1 env) + (eval e2 env)
| Prim("*", e1, e2) -> (eval e1 env) * (eval e2 env)
| Prim("-", e1, e2) -> (eval e1 env) - (eval e2 env)
| Prim _ -> failwith "unknown primitive"
| Let(x, e1, e2) -> eval e2 ((x, eval e1 env) :: env)
So for the given problem I have written:
let rec toString e (env : (string * int) list) : string
match e with
| Prim("+", e1, e2) -> "e1 + e2"
| Prim("*", e1, e2) -> "e1 - e2"
| Prim("-", e1, e2) -> "e1 * e2"
this may look foolish, or am I on the right track? Fairly new to F#
The problem states:
[...] although it needs no environment argument [...]
so your function toString should look something like this:
let rec toString e =
match e with
| CstI i -> sprintf "%i" i // format number as string
| Var x -> x // already a string
| Prim("+", e1, e2) -> sprintf "(%s + %s)" (toString e1) (toString e2)
| Prim("*", e1, e2) -> sprintf "(%s * %s)" (toString e1) (toString e2)
| Prim("-", e1, e2) -> sprintf "(%s - %s)" (toString e1) (toString e2)
For nested expressions toString is called on the subexpressions first. The resulting strings are then plugged into %s in sprintf.

On heterogenous lists, is it possible to make the zip and then unzip equal to the original?

I am talking about the zip operations in the context of heterogeneous lists. I am working on a lightly dependently typed language that uses them as tuples.
type T =
| S of string
| R of T list
let rec zip l =
let is_all_r_empty x = List.forall (function R [] -> true | _ -> false) x
let rec loop acc_total acc_head acc_tail x =
match x with
| S _ :: _ -> R l
| R [] :: ys ->
if List.isEmpty acc_head && is_all_r_empty ys then List.rev acc_total |> R
else R l
| R (x :: xs) :: ys -> loop acc_total (x :: acc_head) (R xs :: acc_tail) ys
| [] ->
match acc_tail with
| _ :: _ -> loop ((List.rev acc_head |> zip) :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total |> R
loop [] [] [] l
let rec unzip l =
let transpose l =
let is_all_empty x = List.forall (function _ :: _ -> false | _ -> true) x
let rec loop acc_total acc_head acc_tail = function
| (x :: xs) :: ys -> loop acc_total (x :: acc_head) (xs :: acc_tail) ys
| [] :: ys ->
if List.isEmpty acc_head && is_all_empty ys then loop acc_total acc_head acc_tail ys
else l
| [] ->
match acc_tail with
| _ :: _ -> loop (List.rev acc_head :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total
loop [] [] [] l
let is_all_r x = List.forall (function R _ -> true | _ -> false) x
match l with
| R x when is_all_r x -> List.map unzip x |> transpose |> List.map R
| R x -> x
| S _ -> failwith "Unzip called on S."
//let a = R [R [S "a"; S "t"]; R [S "b"; S "w"]; R [S "c"; S "e"]]
//let b = R [R [S "1"; S "4"]; R [S "5"; S "r"]; R [S "3"; S "6"]]
//let c = R [R [S "z"; S "v"]; R [S "x"; S "b"]; R [S "c"; S "2"]]
//
//let t3 = zip [a;b]
//let t4 = zip [t3;c]
//let u1 = unzip t4
//let r1 = u1 = [t3;c]
//let u2 = unzip t3
//let r2 = u2 = [a;b] // The above works fine on tuples with regular dimensions.
let a = R [R [S "q"; S "w"; S "e"]]
let b = R [R [S "a"; S "s"]; R [S "z"]; S "wqe"]
let ab = [a;b]
let t = zip ab
let t' = unzip t
ab = t' // This is false, but I would like the ziping and then unziping to be reversible if possible.
Zipping and unzipping in general can be expressed as a dimensional shift or a series of transposes. That is all these two functions are doing.
They behave well on regular tuples, but I would like zip+unzip to be isomorphic on irregular ones as well. My intuition is telling me that this would be asking too much of them though.
I need a second opinion here.
#r "../../packages/FsCheck.2.8.0/lib/net452/FsCheck.dll"
type T =
| S of string
| VV of T list
let transpose l on_fail on_succ =
let is_all_vv_empty x = List.forall (function VV [] -> true | _ -> false) x
let rec loop acc_total acc_head acc_tail = function
| VV [] :: ys ->
if List.isEmpty acc_head && is_all_vv_empty ys then
if List.isEmpty acc_total then failwith "Empty inputs in the inner dimension to transpose are invalid."
else List.rev acc_total |> on_succ
else on_fail ()
| VV (x :: xs) :: ys -> loop acc_total (x :: acc_head) (VV xs :: acc_tail) ys
| _ :: _ -> on_fail ()
| [] ->
match acc_tail with
| _ :: _ -> loop (VV (List.rev acc_head) :: acc_total) [] [] (List.rev acc_tail)
| _ -> List.rev acc_total |> on_succ
loop [] [] [] l
let rec zip l =
match l with
| _ :: _ -> transpose l (fun _ -> l) (List.map (function VV x -> zip x | x -> x)) |> VV
| _ -> failwith "Empty input to zip is invalid."
let rec unzip l =
let is_all_vv x = List.forall (function VV _ -> true | _ -> false) x
match l with
| VV x ->
match x with
| _ :: _ when is_all_vv x -> let t = List.map (unzip >> VV) x in transpose t (fun _ -> x) id
| _ :: _ -> x
| _ -> failwith "Empty inputs to unzip are invalid."
| S _ -> failwith "Unzip called on S."
open FsCheck
open System
let gen_t =
let mutable gen_t = None
let gen_s () = Gen.map S Arb.generate<string>
let gen_vv size = Gen.nonEmptyListOf (gen_t.Value size) |> Gen.map VV
gen_t <-
fun size ->
match size with
| 0 -> gen_s()
| _ when size > 0 -> Gen.oneof [gen_s (); gen_vv (size-1)]
| _ -> failwith "impossible"
|> Some
gen_t.Value
|> Gen.sized
let gen_t_list_irregular = Gen.nonEmptyListOf gen_t
let gen_t_list_regular = Gen.map2 List.replicate (Gen.choose(1,10)) gen_t
type MyGenerators =
static member Tuple() = Arb.fromGen gen_t
static member TupleList() = Arb.fromGen gen_t_list_regular
Arb.register<MyGenerators>()
let zip_and_unzip orig = zip orig |> unzip
let zip_and_unzip_eq_orig orig = zip_and_unzip orig = orig
// For regular tuples it passes with flying colors.
Check.One ({Config.Quick with EndSize = 10}, zip_and_unzip_eq_orig)
// I can't get it to be isomorphic for irregularly sized arrays as expected.
//let f x =
// let x' = zip x
// printfn "x'=%A" x'
// printfn "unzip x'=%A" (unzip x')
// printfn "zip_and_unzip_eq_orig x=%A" (zip_and_unzip_eq_orig x)
//
//f [VV [VV [S "12"; S "qwe"]; VV [S "d"]]; VV [VV [S ""; S "ug"]; VV [S ""]]]
No matter what, I try I cannot figure out how to make the pair isomorphic for irregularly sized tuples and I feel it is unlikely that anyone will tell me differently so I'll put the above attempt as an answer for now.
On the upside, based on the tests above, I am decently sure that it should be isomorphic for all regularly sizes tuples. I guess this should suffice. I've tightened the code up a little compared to the example I had in the question.
This irregular zipping and unzipping problem would make an interesting math puzzle.

F# Map Trouble

I am having trouble groking F#'s Map class. I created a simple, naive lambda calculus evaluation function,
type Name = string
type Term =
| Var of Name
| Lit of int
| App of Term * Term
| Lam of Name * Term
let rec lookup(v, e) =
match e with
| (v1, t)::tl -> if v1 = v then t else lookup(v, tl)
| [] -> failwith "unknown variable %s" v
let rec eval(x, e) =
match x with
| Var x -> lookup(x, e)
| Lit x -> Lit x
| App (Lam(v, f), t2) -> eval(f, ((v, t2)::e))
| _ -> failwith "Invalid"
The obvious optimization to this is to change the list to a Map so I came up with,
let rec eval2(x, e: Map<Name,Term>) =
match x with
| Var v -> e.[v]
| Lit l -> x
| App (Lam (v, f), t) -> eval2(f, e.Add(v, t))
| _ -> failwith "Invalid term"
Given the values,
let ident = Lam ("x", Var "x")
let prog = App (ident, Lit 3)
why does,
let x = eval(prog, [])
succeed but,
let x2 = eval2(prog, Map [])
throw a key not found exception?
I don't repro this behavior (using F# 1.9.6.2, it works for me):
#light
type Name = string
type Term =
| Var of Name
| Lit of int
| App of Term * Term
| Lam of Name * Term
let rec eval2(x, e: Map<Name,Term>) =
match x with
| Var v -> e.[v]
| Lit l -> x
| App (Lam (v, f), t) -> eval2(f, e.Add(v, t))
| _ -> failwith "Invalid term"
let ident = Lam ("x", Var "x")
let prog = App (ident, Lit 3)
let x2 = eval2(prog, Map [])
printfn "%A" x2 // Lit 3

Resources