OCaml syntax error in recursive function - recursion

I'm writing a function that take a pair of lists, if the length of two lists are equal then create a pair of each element from each list, but my function doesn't work and the compiler say there is a syntax error
Could someone explain why there is a syntax error at the semicolon at the end of my function?
This is my code:
let define_tuple a b =
(a, b);;
let zip (a, b) =
if List.length (fst (a, b)) != List.length (fst (a, b))
then
printf_string "lengths of 2 lists need to be equal"
else
let rec create_tuples (a, b) =
if List.length (List.tl (fst (a, b))) = 0 && List.length (List.tl (snd (a, b))) != 0
then
[]
else
List.append define_tuple (List.hd (fst (a, b))) (List.hd (snd (a, b))) create_tuples (List.tl (fst (a, b)), List.tl (snd (a, b)));;
zip ([1; 2; 3], [2; 3; 4]);;

There are quite a few possible improvements and errors in your code and I list them all in the following:
No. 1
If you write your code in a file and try to compile / run your file, then you don't need ;; in the end for every function.
No. 2
let define_tuple a b = (a, b);;
You don't need to define such a function, instead, you can directly use (a, b).
No. 3
let zip (a, b) =
if List.length (fst (a, b)) != List.length (fst (a, b)) then
printf_string "lengths of 2 lists need to be equal"
else
let rec create_tuples (a, b) =
if List.length (List.tl (fst (a, b))) = 0 && List.length (List.tl (snd (a, b))) != 0
then
[]
else
List.append define_tuple (List.hd (fst (a, b))) (List.hd (snd (a, b))) create_tuples (List.tl (fst (a, b)), List.tl (snd (a, b)));;
3.1
For your first if ... else ..., it is not correct as the if branch returns unit and else branch returns list.
In OCaml, if and else or any branch of pattern matching should returns the same type.
3.2
Because of 3.1, I suggest you write an exception for the non-equal lengths case. In this way, the whole function still returns list and code is more readable and users of your function can also get the chance to "catch" your exception case.
3.3
for function create_tuples,
let rec create_tuples (a, b) =
if List.length (List.tl (fst (a, b))) = 0 && List.length (List.tl (snd (a, b))) != 0
then
[]
else
List.append define_tuple (List.hd (fst (a, b))) (List.hd (snd (a, b))) create_tuples (List.tl (fst (a, b)), List.tl (snd (a, b)));;
3.3.1
List.length (List.tl (fst (a, b))) = 0
You don't need to use fst (a,b), instead, just a is enough because a is already known.
It is the same for your snd usage.
Basically you don't need fst and snd all over your code.
3.3.1.1
You should check whether a and b's lengths are 0 or not, not the tl of them.
3.3.2
You also don't need (a,b) a tuple as the parameters for create_tuples, instead, you can use create_tuples a b. It is better because your code doesn't need to create a tuple for a pair of parameters.
3.3.3
List.append define_tuple (List.hd (fst (a, b))) (List.hd (snd (a, b))) create_tuples (List.tl (fst (a, b)), List.tl (snd (a, b)))
First of all, List.append is to append one list to another list. In your case, you are adding an element to a list, so you should use ::.
You should use () to include a function application if you want the value of the function application to be used.
for example, you should do (define_tuple (List.hd (fst (a, b))) (List.hd (snd (a, b)))):: (create_tuples (List.tl (fst (a, b)), List.tl (snd (a, b)))).
If you consider the previous points together, you can do
(List.hd a, List.hd b)::(create_tuples (List.tl a) (List.tl b))
3.4
You have defined function create_tuples, but did you really use it in your code? No.
So at the end, you should do
in create_tuples a b
No. 4
You should use <> to check inequality.
The full refined/corrected code is
exception Non_equal_list_length
let zip a b =
if List.length a <> List.length b then raise Non_equal_list_length
else
let rec create_tuples a b =
if List.length a = 0 && List.length b = 0 then []
else (List.hd a, List.hd b)::(create_tuples (List.tl a) (List.tl b))
in
create_tuples a b
Some more improvements:
You can use pattern matching directly on lists
You should always take tail-recursive in consideration
Final improved code:
exception Non_equal_list_length
let zip a b =
let rec zipping acc = function
| [], [] -> List.rev acc
| hd1::tl1, hd2::tl2 -> zipping ((hd1,hd2)::acc) (tl1,tl2)
| _ -> raise Non_equal_list_length
in
zipping [] (a,b)

The expression let a = b is valid only at the topmost level of a module, where it defines names to be exported from the module. Everywhere else this expression is used to introduce a local variable (or variables), and it has the form let a = b in c. You're missing the in keyword, and the expression in which you want to use your local variable create_tuples.
(There are some other errors that you will find when you get the syntax in order.)
Update
Here's a simple example of a function that uses a helper function declared with let a = b in c:
let myrev l =
let rec irev sofar = function
| [] -> sofar
| hd :: tl -> irev (hd :: sofar) tl
in
irev [] l

Related

How to represent kleisli composition of substitutions in abstract trees

Context: I have been trying to implement the unification algorithm (the algorithm to find the most general unifier of two abstract syntax trees). Since a unifier is a substitution, algorithm requires defining composition of substitutions.
To be specific, given a type treeSigma dependent on another type X, a substitution is a function of type:
X -> treeSigma X
and the function substitute takes a substitution as an input and has type
substitute: (X-> (treeSigma X))-> (treeSigma X) -> (treeSigma X)
I need to define a function to compose two substitutions:
compose_kleisli (rho1 rho2: X->(treeSigma X)) : (treeSigma X) := ...
such that,
forall tr: treeSigma X,
substitute (compose_kleisli rho1 rho2) tr = substitute rho1 (substitute rho2 tr).
I am fairly new to coq and have been stuck with defining this composition.
How can I define this composition?
I tried to define it using Record like this:
Record compose {X s} (rho1 rho2: X-> treeSigma X):= mkCompose{
RHO: X-> treeSigma X;
CONDITION: forall t, substitute RHO t = substitute rho2 (substitute rho1 t)
}.
but along with this, I would need to prove the result that the composition can be defined for any two substitutions. Something like:
Theorem composeTotal: forall {X s} (rho1 rho2: X-> treeSigma s X), exists rho3,
forall t, substitute rho3 t = substitute rho2 (substitute rho1 t).
Proving this would require a construction of rho3 which circles back to the same problem of defining compose.
treeSigma is defined as:
(* Signature *)
Record sigma: Type := mkSigma {
symbol : Type;
arity : symbol -> nat
}.
Record sigmaLeaf (s:sigma): Type := mkLeaf {
cLeaf: symbol s;
condLeaf: arity s cLeaf = 0
}.
Record sigmaNode (s:sigma): Type := mkNode {
fNode: symbol s;
condNode: arity s fNode <> 0
}.
(* Sigma Algebra *)
Record sigAlg (s:sigma) (X:Type) := mkAlg {
Carrier: Type;
meaning: forall f:(sigmaNode s), (Vector.t Carrier (arity s (fNode s f))) -> Carrier;
meanLeaf: forall f:(sigmaLeaf s), Vector.t Carrier 0 -> Carrier
}.
(* Abstract tree on arbitrary signature. *)
Inductive treeSigma (s:sigma) (X:Type):=
| VAR (x:X)
| LEAF (c: sigmaLeaf s)
| NODE (f: sigmaNode s) (sub: Vector.t (treeSigma s X) (arity s (fNode s f)) ).
(* Defining abstract syntax as a sigma algebra. *)
Definition meanTreeNode {s X} (f:sigmaNode s) (sub: Vector.t (treeSigma s X) (s.(arity)
(fNode s f))): treeSigma s X:= NODE s X f sub.
Definition meanTreeLeaf {s X} (c:sigmaLeaf s) (sub: Vector.t (treeSigma s X) 0) := LEAF s X c.
Definition treeSigAlg {s X} := mkAlg s X (treeSigma s X) meanTreeNode meanTreeLeaf.
The substitution function is defined as:
Fixpoint homoSigma1 {X:Type} {s} (A: sigAlg s X) (rho: X-> (Carrier s X A))
(wft: (treeSigma s X)) {struct wft}: (Carrier s X A) :=
match wft with
| VAR _ _ x => rho x
| LEAF _ _ c => meanLeaf s X A c []
| NODE _ _ f l2 => meanNode s X A f (
(fix homoSigVec k (l2:Vector.t _ k):= match l2 with
| [] => []
| t::l2s => (homoSigma1 A rho t):: (homoSigVec (vlen _ l2s) l2s)
end)
(arity s (fNode s f)) l2)
end.
Definition substitute {X s} (rho: X-> treeSigma s X) (t: treeSigma s X) := #homoSigma1 X s treeSigAlg rho t.
To be particular, a substitution is the homomorphic extension of rho (which is a variable valuation).
Definitions like this are challenging to work with because the tree type occurs recursively inside of another inductive type. Coq has trouble generating induction principles for these types on its own, so you need to help it a little bit. Here is a possible solution, for a slightly simplified set up:
Require Import Coq.Vectors.Vector.
Import VectorNotations.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section Dev.
Variable symbol : Type.
Variable arity : symbol -> nat.
Record alg := Alg {
alg_sort :> Type;
alg_op : forall f : symbol, Vector.t alg_sort (arity f) -> alg_sort;
}.
Arguments alg_op {_} f _.
(* Turn off the automatic generation of induction principles.
This tree type does not distinguish between leaves and nodes,
since they only differ in their arity. *)
Unset Elimination Schemes.
Inductive treeSigma (X:Type) :=
| VAR (x:X)
| NODE (f: symbol) (args : Vector.t (treeSigma X) (arity f)).
Arguments NODE {X} _ _.
Set Elimination Schemes.
(* Manual definition of a custom induction principle for treeSigma.
HNODE is the inductive case for the NODE constructor; the vs argument is
saying that the induction hypothesis holds for each tree in the vector of
arguments. *)
Definition treeSigma_rect (X : Type) (T : treeSigma X -> Type)
(HVAR : forall x, T (VAR x))
(HNODE : forall f (ts : Vector.t (treeSigma X) (arity f))
(vs : Vector.fold_right (fun t V => T t * V)%type ts unit),
T (NODE f ts)) :
forall t, T t :=
fix loopTree (t : treeSigma X) : T t :=
match t with
| VAR x => HVAR x
| NODE f ts =>
let fix loopVector n (ts : Vector.t (treeSigma X) n) :
Vector.fold_right (fun t V => T t * V)%type ts unit :=
match ts with
| [] => tt
| t :: ts => (loopTree t, loopVector _ ts)
end in
HNODE f ts (loopVector (arity f) ts)
end.
Definition treeSigma_ind (X : Type) (T : treeSigma X -> Prop) :=
#treeSigma_rect X T.
Definition treeSigma_alg (X:Type) : alg := {|
alg_sort := treeSigma X;
alg_op := #NODE X;
|}.
Fixpoint homoSigma {X : Type} {Y : alg} (ρ : X -> Y) (t : treeSigma X) : Y :=
match t with
| VAR x => ρ x
| NODE f xs => alg_op f (Vector.map (homoSigma ρ) xs)
end.
Definition substitute X (ρ : X -> treeSigma X) (t : treeSigma X) : treeSigma X :=
#homoSigma X (treeSigma_alg X) ρ t.
(* You can define composition simply by applying using substitution. *)
Definition compose X (ρ1 ρ2 : X -> treeSigma X) : X -> treeSigma X :=
fun x => substitute ρ1 (ρ2 x).
(* The property you are looking for follows by induction on the tree. Note
that this requires a nested induction on the vector of arguments. *)
Theorem composeP X (ρ1 ρ2 : X -> treeSigma X) t :
substitute (compose ρ1 ρ2) t = substitute ρ1 (substitute ρ2 t).
Proof.
unfold compose, substitute.
induction t as [x|f ts IH]; trivial.
simpl; f_equal.
induction ts as [|n t ts IH']; trivial.
simpl.
destruct IH as [e IH].
rewrite e.
f_equal.
now apply IH'.
Qed.
End Dev.
In order to do this you need to use the operations of the monad, typically:
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Section MonadKleisli.
(* Set Universe Polymorphism. // Needed for real use cases *)
Variable (M : Type -> Type).
Variable (Ma : forall A B, (A -> B) -> M A -> M B).
Variable (η : forall A, A -> M A).
Variable (μ : forall A, M (M A) -> M A).
(* Compose: o^* *)
Definition oStar A B C (f : A -> M B) (g: B -> M C) : A -> M C :=
fun x => μ (Ma g (f x)).
(* Bind *)
Definition bind A B (x : M A) (f : A -> M B) : M B := oStar (fun _ => x) f tt.
End MonadKleisli.
Depending on how you organize your definitions, proving your desired properties will likely require functional extensionality, not a big deal usually but something to keep in ind.

Recursion in Ocaml

I'm new to Ocaml and i'm trying to write a recursion function.
The function take a list of pairs and return a pair of lists, for example
[(1, 4); (2, 3); (5, 9); (6, 10)]) -> ([1; 2; 5; 6], [4; 3; 9; 10])
But the compiler say that: Error: This expression has type 'a list * 'b list
but an expression was expected of type 'a list
in the line (unzip (List.tl m))
Can someone explain why I have this error please? And is there anyway to fix this? Thank you very much!
let rec unzip m =
if List.length m = 0 then
([], [])
else
((fst (List.hd m)) :: (unzip (List.tl m)), (snd (List.hd m)) :: (unzip (List.tl m)))
in
unzip m;;
For any recursion, you have to note that the output type will be always the same.
Let's see your unzip function.
[(1, 4); (2, 3); (5, 9); (6, 10)]) -> ([1; 2; 5; 6], [4; 3; 9; 10])
Simply say, the return type of unzip is def a pair (tuple), and each element is a list, correct?
Then let's see your code
let rec unzip m =
if List.length m = 0 then
([], [])
else
((fst (List.hd m)) :: (unzip (List.tl m)), (snd (List.hd m)) :: (unzip (List.tl m)))
in
unzip m;;
You have two branches. First branch is returning ([], []). Ok, in terms of return type, it is correct as it is a pair with two empty lists and matches the return type described above.
The second branch
((fst (List.hd m)) :: (unzip (List.tl m)), (snd (List.hd m)) :: (unzip (List.tl m)))
is it correct?
It is a pair with two elements, no problem, then let's see the first element:
(fst (List.hd m)) :: (unzip (List.tl m))
You are trying to add (fst (List.hd m)) to the head of (unzip (List.tl m)).
But you can only add something to a list by using ::, so ocaml supposes (unzip (List.tl m)) is a list, right?
But it is a unzip function application, apparently described in the beginning, your unzip is not returning a list, but a pair (tuple).
So ocaml doesn't understand and thus complain.
The above is just to answer your question about the type problem. But your code has more problems.
1. incorrect use of in
Suppose you have a function f1. You can image it as the mother function, which means it can be used directly. Also in f1, you can declare another function or variable (or more formally, a binding). Only when you declare a binding inside a function, you use let...in.... If you only have the mother function, you don't use in, because in where?
In your unzip, you only have one function or binding which is unzip itself and it is in top level. So in is not necessary.
2. incorrect logic of recursion
I don't know how to explain to you about recursion here, as it needs you to read more and practise more.
But the correct code in your idea is
let rec unzip = function
| [] -> ([], [])
| (x,y)::tl ->
let l1, l2 = unzip tl in
x::l1, y::l2
If you are chasing for better or a tail-recursive version, here it is:
let unzip l =
let rec unzip_aux (l1,l2) = function
| [] -> List.rev l1, List.rev l2
| (x,y)::tl -> unzip_aux (x::l1, y::l2) tl
in
unzip_aux ([],[]) l
The error comes from the fact that (unzip ...) returns a pair of lists ('a list * 'b list), which you try to manipulate as a list when you write (fst ..) :: (unzip ...).
This would all be written much more nicely if you used pattern-matching. Skeleton:
let rec unzip = function
| [] -> ...
| (x,y) :: rest ->
let (xs, ys) = unzip rest in ...

Recursive function to calculate permutations in F# has type mismatch error

I am trying to write a general function in F# that would return all the permutations of a list. I was trying to accomplish this using a recursive algorithm inspired by the java version here
But on the final line of the recursive function, I get the error given in the comments. I am guessing this is something to do with collating the output produced when the recursive loop exits (the output of if(Array.length <= 1) then being executed) with the rest Array.Map function.
I would greatly appreciate it if someone could give an explanation of why this error is happening and how I can go about fixing it.
let GetPermutationsOfList inputList =
let rec innerLoop firstPart secondPart =
if (Array.length secondPart) <= 1 then
[| Array.append firstPart secondPart |]
else
let SliceAtMarkerElement m =
let currentMarkerElement = secondPart.[m]
let everythingBeforeMarkerElement = secondPart.[0 .. m - 1]
let everythingAfterMarkerElement = secondPart.[m+1 .. ]
let newSecondPartList = Array.append everythingBeforeMarkerElement everythingAfterMarkerElement
let newFirstPartList = Array.append firstPart [|currentMarkerElement|]
(newFirstPartList, newSecondPartList)
[|for i in 0 .. ((Array.length secondPart) - 1) -> i|] |>
Array.map(fun c -> SliceAtMarkerElement c) |>
// The following line gives the error
// "Type Mismatch. Expecting a 'a but given a 'a[] The resulting type would be infinite when unifying "a' and "a[]"
Array.map(fun d -> innerLoop (fst d) (snd d))
innerLoop Array.empty (List.toArray inputList)
Assume that your function's indentation is correct, the error message is quite informative. In the innerLoop function, Array.append firstPart secondPart should return 'b []. However, the last line Array.map(fun d -> innerLoop (fst d) (snd d)) forces it to return 'b [] [], which couldn't be unified with 'b [].
I think you would like calculate permutations in each innerLoop and concatenate these results afterwards. You have to use Array.collect instead of Array.map:
[|for i in 0 .. (Array.length secondPart)-1 -> i|]
|> Array.map (fun c -> SliceAtMarkerElement c)
|> Array.collect (fun d -> innerLoop (fst d) (snd d))
The above fragment is employing two temporary arrays, which is wasteful. You can eliminate these extra arrays by using computation expression only:
[| for i in 0 .. (Array.length secondPart)-1 do
let first, second = SliceAtMarkerElement i
yield! innerLoop first second (* concatenating results *)
|]
UPDATE:
As clarified in the comment, you want to return an array of arrays where each array is a permutation. So your change would work and map operations should be:
[| for i in 0 .. (Array.length secondPart)-1 do
let first, second = SliceAtMarkerElement i
yield innerLoop first second (* returning each array as a permutation *)
|]

Suggestion for solving fragile pattern matching

I often need to match a tuple of values that should have the same constructor. The catchall _,_ always winds-up at the end. This of course is fragile, any additional constructor added to the type will compile perfectly fine. My current thoughts are to have matches that connect the first but not second argument. But, is there any other options?
For example,
type data = | States of int array
| Chars of (char list) array
let median a b = match a,b with
| States xs, States ys ->
assert( (Array.length xs) = (Array.length ys) );
States (Array.init (Array.length xs) (fun i -> xs.(i) lor ys.(i)))
| Chars xs, Chars ys ->
assert( (Array.length xs) = (Array.length ys) );
let union c1 c2 = (List.filter (fun x -> not (List.mem x c2)) c1) # c2 in
Chars (Array.init (Array.length xs) (fun i -> union xs.(i) ys.(i)))
(* inconsistent pairs of matching *)
| Chars _, _
| States _, _ -> assert false
You can use the slightly shorter pattern below:
| (Chars _| States _), _ -> assert false
In fact, you can let the compiler generate it for you, because it's still a little tedious.
Type the following and compile:
let median a b = match a,b with
| States xs, States ys ->
assert( (Array.length xs) = (Array.length ys) );
States (Array.init (Array.length xs) (fun i -> xs.(i) lor ys.(i)))
| Chars xs, Chars ys ->
assert( (Array.length xs) = (Array.length ys) );
let union c1 c2 = (List.filter (fun x -> not (List.mem x c2)) c1) # c2 in
Chars (Array.init (Array.length xs) (fun i -> union xs.(i) ys.(i)))
Warning 8: this pattern-matching is
not exhaustive. Here is an example of
a value that is not matched: (Chars _,
States _)
You can now copy-paste the suggested pattern back into your code. This is usually how I generate non-fragile catch-all patterns for types with tens of constructors. You may need to launch the compiler several times, but it's still faster than typing them yourself.
It's only a matter of taste/style, but I tend to prefer grouping clauses on the same constructor together, rather than having the useful clauses for everything first, then all the "absurd cases" together. This can be quite helpful when you get to write several "useful" clauses for one given constructor, and want to check you didn't forget anything.
let median a b = match a,b with
| States xs, States ys ->
assert( (Array.length xs) = (Array.length ys) );
States (Array.init (Array.length xs) (fun i -> xs.(i) lor ys.(i)))
| States _, _ -> assert false
| Chars xs, Chars ys ->
assert( (Array.length xs) = (Array.length ys) );
let union c1 c2 = (List.filter (fun x -> not (List.mem x c2)) c1) # c2 in
Chars (Array.init (Array.length xs) (fun i -> union xs.(i) ys.(i)))
| Chars _, _ -> assert false
This is pretty hackish (and results in warnings) but you can use Obj to check if the tags are equal or not. It should catch all cases where a and b have different values:
type data = | States of int array
| Chars of (char list) array
let median a b = match a,b with
| States xs, States ys ->
assert( (Array.length xs) = (Array.length ys) );
States (Array.init (Array.length xs) (fun i -> xs.(i) lor ys.(i)))
| Chars xs, Chars ys ->
assert( (Array.length xs) = (Array.length ys) );
let union c1 c2 = (List.filter (fun x -> not (List.mem x c2)) c1) # c2 in
Chars (Array.init (Array.length xs) (fun i -> union xs.(i) ys.(i)))
(* inconsistent pairs of matching *)
| x, y when (Obj.tag (Obj.repr x)) <> (Obj.tag (Obj.repr y)) -> assert false
The warning is for non-exhaustive pattern-matching (since it can't tell whether or not the guarded clause matches the rest or not).
EDIT: you don't need to use Obj at all, you can just compare x and y directly:
| x, y when x <> y -> assert false
Though this still results in a warning, unfortunately.

F# System.OutOfMemoryException with recursive call

This is actually a solution to Project Euler Problem 14 in F#. However, I'm running into a System.OutOfMemory exception when attempting to calculate an iterative sequence for larger numbers. As you can see, I'm writing my recursive function with tail calls.
I was running into a problem with StackOverFlowException because I was debugging in visual studio (which disables the tail calls). I've documented that in another question. Here, I'm running in release mode--but I'm getting out of memory exceptions when I run this as a console app (on windows xp with 4gb ram).
I'm really at a loss to understand how I coded myself into this memory overflow & hoping someone can show my the error in my ways.
let E14_interativeSequence x =
let rec calc acc startNum =
match startNum with
| d when d = 1 -> List.rev (d::acc)
| e when e%2 = 0 -> calc (e::acc) (e/2)
| _ -> calc (startNum::acc) (startNum * 3 + 1)
let maxNum pl=
let rec maxPairInternal acc pairList =
match pairList with
| [] -> acc
| x::xs -> if (snd x) > (snd acc) then maxPairInternal x xs
else maxPairInternal acc xs
maxPairInternal (0,0) pl
|> fst
// if I lower this to like [2..99999] it will work.
[2..99999]
|> List.map (fun n -> (n,(calc [] n)))
|> List.map (fun pair -> ((fst pair), (List.length (snd pair))))
|> maxNum
|> (fun x-> Console.WriteLine(x))
EDIT
Given the suggestions via the answers, I rewrote to use a lazy list and also to use Int64's.
#r "FSharp.PowerPack.dll"
let E14_interativeSequence =
let rec calc acc startNum =
match startNum with
| d when d = 1L -> List.rev (d::acc) |> List.toSeq
| e when e%2L = 0L -> calc (e::acc) (e/2L)
| _ -> calc (startNum::acc) (startNum * 3L + 1L)
let maxNum (lazyPairs:LazyList<System.Int64*System.Int64>) =
let rec maxPairInternal acc (pairs:seq<System.Int64*System.Int64>) =
match pairs with
| :? LazyList<System.Int64*System.Int64> as p ->
match p with
| LazyList.Cons(x,xs)-> if (snd x) > (snd acc) then maxPairInternal x xs
else maxPairInternal acc xs
| _ -> acc
| _ -> failwith("not a lazylist of pairs")
maxPairInternal (0L,0L) lazyPairs
|> fst
{2L..999999L}
|> Seq.map (fun n -> (n,(calc [] n)))
|> Seq.map (fun pair -> ((fst pair), (Convert.ToInt64(Seq.length (snd pair)))))
|> LazyList.ofSeq
|> maxNum
which solves the problem. I'd also look at Yin Zhu's solution which is better, though.
As mentioned by Brian, List.* operations are not appropriate here. They cost too much memory.
The stackoverflow problem comes from another place. There are two possible for you to have stackoverflow: calc and maxPairInternal. It must be the first as the second has the same depth as the first. Then the problem comes to the numbers, the number in 3n+1 problem could easily go to very large. So you first get a int32 overflow, then you get a stackoverflow. That's the reason. After changing the numbers to 64bit, the program works.
Here is my solution page, where you can see a memoization trick.
open System
let E14_interativeSequence x =
let rec calc acc startNum =
match startNum with
| d when d = 1L -> List.rev (d::acc)
| e when e%2L = 0L -> calc (e::acc) (e/2L)
| _ -> calc (startNum::acc) (startNum * 3L + 1L)
let maxNum pl=
let rec maxPairInternal acc pairList =
match pairList with
| [] -> acc
| x::xs -> if (snd x) > (snd acc) then maxPairInternal x xs
else maxPairInternal acc xs
maxPairInternal (0L,0) pl
|> fst
// if I lower this to like [2..99999] it will work.
[2L..1000000L]
|> Seq.map (fun n -> (n,(calc [] n)))
|> Seq.maxBy (fun (n, lst) -> List.length lst)
|> (fun x-> Console.WriteLine(x))
If you change List.map to Seq.map (and re-work maxPairInternal to iterate over a seq) that will probably help tons. Right now, you're manifesting all the data at once in a giant structure before processing the whole structure to get a single number result. It is much better to do this lazily via Seq, and just create one row, and compare it with the next row, and create a single row at a time and then discard it.
I don't have time to code my suggestion now, but let me know if you are still having trouble and I'll revisit this.
Stop trying to use lists everywhere, this isn't Haskell! And stop writing fst pair and snd pair everywhere, this isn't Lisp!
If you want a simple solution in F# you can do it directly like this without creating any intermediate data structures:
let rec f = function
| 1L -> 0
| n when n % 2L = 0L -> 1 + f(n / 2L)
| n -> 1 + f(3L * n + 1L)
let rec g (li, i) = function
| 1L -> i
| n -> g (max (li, i) (f n, n)) (n - 1L)
let euler14 n = g (0, 1L) n
That takes around 15s on my netbook. If you want something more time efficient, reuse previous results via an array:
let rec inside (a : _ array) n =
if n <= 1L || a.[int n] > 0s then a.[int n] else
let p =
if n &&& 1L = 0L then inside a (n >>> 1) else
let n = 3L*n + 1L
if n < int64 a.Length then inside a n else outside a n
a.[int n] <- 1s + p
1s + p
and outside (a : _ array) n =
let n = if n &&& 1L = 0L then n >>> 1 else 3L*n + 1L
1s + if n < int64 a.Length then inside a n else outside a n
let euler14 n =
let a = Array.create (n+1) 0s
let a = Array.Parallel.init (n+1) (fun n -> inside a (int64 n))
let i = Array.findIndex (Array.reduce max a |> (=)) a
i, a.[i]
That takes around 0.2s on my netbook.
Found this looking for Microsoft.FSharp.Core.Operators.Checked.
I'm just learning F#, so I thought I'd take the Project Euler 14 Challenge.
This uses recursion but not tail-recursion.
Takes about 3.1 sec for me, but has the advantage that I can almost understand it.
let Collatz (n:int64) = if n % 2L = 0L then n / 2L else n * 3L + 1L
let rec CollatzLength (current:int64) (acc:int) =
match current with
| 1L -> acc
| _ -> CollatzLength (Collatz current) (acc + 1)
let collatzSeq (max:int64) =
seq{
for i in 1L..max do
yield i, CollatzLength i 0
}
let collatz = Seq.toList(collatzSeq 1000000L)
let result, steps = List.maxBy snd collatz

Resources