How to wrap last/first element making building interpolation? - algorithm

I've this code that iterate some samples and build a simple linear interpolation between the points:
foreach sample:
base = floor(index_pointer)
frac = index_pointer - base
out = in[base] * (1 - frac) + in[base + 1] * frac
index_pointer += speed
// restart
if(index_pointer >= sample_length)
{
index_pointer = 0
}
using "speed" equal to 1, the game is done. But if the index_pointer is different than 1 (i.e. got fractional part) I need to wrap last/first element keeping the translation consistent.
How would you do this? Double indexes?
Here's an example of values I have. Let say in array of 4 values: [8, 12, 16, 20].
It will be:
1.0*in[0] + 0.0*in[1]=8
0.28*in[0] + 0.72*in[1]=10.88
0.56*in[1] + 0.44*in[2]=13.76
0.84*in[2] + 0.14*in[3]=16.64
0.12*in[2] + 0.88*in[3]=19.52
0.4*in[3] + 0.6*in[4]=8 // wrong; here I need to wrapper
the last point is wrong. [4] will be 0 because I don't have [4], but the first part need to take care of 0.4 and the weight of first sample (I think?).

Just wrap around the indices:
out = in[base] * (1 - frac) + in[(base + 1) % N] * frac
, where % is the modulo operator and N is the number of input samples.
This procedure generates the following line for your sample data (the dashed lines are the interpolated sample points, the circles are the input values):

I think I understand the problem now (answer only applies if I really did...):
You sample values at a nominal speed sn. But actually your sampler samples at a real speed s, where s != sn. Now, you want to create a function which re-samples the series, sampled at speed s, so it yields a series as if it were sampled with speed sn by means of linear interpolation between 2 adjacent samples. Or, your sampler jitters (has variances in time when it actually samples, which is sn + Noise(sn)).
Here is my approach - a function named "re-sample". It takes the sample data and a list of desired re-sample-points.
For any re-sample point which would index outside the raw data, it returns the respective border value.
let resample (data : float array) times =
let N = Array.length data
let maxIndex = N-1
let weight (t : float) =
t - (floor t)
let interpolate x1 x2 w = x1 * (1.0 - w) + x2 * w
let interp t1 t2 w =
//printfn "t1 = %d t2 = %d w = %f" t1 t2 w
interpolate (data.[t1]) (data.[t2]) w
let inter t =
let t1 = int (floor t)
match t1 with
| x when x >= 0 && x < maxIndex ->
let t2 = t1 + 1
interp t1 t2 (weight t)
| x when x >= maxIndex -> data.[maxIndex]
| _ -> data.[0]
times
|> List.map (fun t -> t, inter t)
|> Array.ofList
let raw_data = [8; 12; 16; 20] |> List.map float |> Array.ofList
let resampled = resample raw_data [0.0..0.2..4.0]
And yields:
val resample : data:float array -> times:float list -> (float * float) []
val raw_data : float [] = [|8.0; 12.0; 16.0; 20.0|]
val resampled : (float * float) [] =
[|(0.0, 8.0); (0.2, 8.8); (0.4, 9.6); (0.6, 10.4); (0.8, 11.2); (1.0, 12.0);
(1.2, 12.8); (1.4, 13.6); (1.6, 14.4); (1.8, 15.2); (2.0, 16.0);
(2.2, 16.8); (2.4, 17.6); (2.6, 18.4); (2.8, 19.2); (3.0, 20.0);
(3.2, 20.0); (3.4, 20.0); (3.6, 20.0); (3.8, 20.0); (4.0, 20.0)|]
Now, I still fail to understand the "wrap around" part of your question. In the end, interpolation - in contrast to extrapolation is only defined for values in [0..N-1]. So it is up to you to decide if the function should produce a run time error or simply use the edge values (or 0) for time values out of bounds of your raw data array.
EDIT
As it turned out, it is about how to use a cyclic (ring) buffer for this as well.
Here, a version of the resample function, using a cyclic buffer. Along with some operations.
update adds a new sample value to the ring buffer
read reads the content a ring buffer element as if it were a normal array, indexed from [0..N-1].
initXXX functions which create the ring buffer in various forms.
length which returns the length or capacity of the ring buffer.
The ring buffer logics is factored into a module to keep it all clean.
module Cyclic =
let wrap n x = x % n // % is modulo operator, just like in C/C++
type Series = { A : float array; WritePosition : int }
let init (n : int) =
{ A = Array.init n (fun i -> 0.);
WritePosition = 0
}
let initFromArray a =
let n = Array.length a
{ A = Array.copy a;
WritePosition = 0
}
let initUseArray a =
let n = Array.length a
{ A = a;
WritePosition = 0
}
let update (sample : float ) (series : Series) =
let wrapper = wrap (Array.length series.A)
series.A.[series.WritePosition] <- sample
{ series with
WritePosition = wrapper (series.WritePosition + 1) }
let read i series =
let n = Array.length series.A
let wrapper = wrap (Array.length series.A)
series.A.[wrapper (series.WritePosition + i)]
let length (series : Series) = Array.length (series.A)
let resampleSeries (data : Cyclic.Series) times =
let N = Cyclic.length data
let maxIndex = N-1
let weight (t : float) =
t - (floor t)
let interpolate x1 x2 w = x1 * (1.0 - w) + x2 * w
let interp t1 t2 w =
interpolate (Cyclic.read t1 data) (Cyclic.read t2 data) w
let inter t =
let t1 = int (floor t)
match t1 with
| x when x >= 0 && x < maxIndex ->
let t2 = t1 + 1
interp t1 t2 (weight t)
| x when x >= maxIndex -> Cyclic.read maxIndex data
| _ -> Cyclic.read 0 data
times
|> List.map (fun t -> t, inter t)
|> Array.ofList
let input = raw_data
let rawSeries0 = Cyclic.initFromArray input
(resampleSeries rawSeries0 [0.0..0.2..4.0]) = resampled

Related

Implementing a FIR filter using Vectors

I have implemented a FIR filter in Haskell. I don't know that much about FIR filters and my code is heavily based on an existing C# implementation. Therefore, I have a feeling that my implementation is has too much of a C# style and is not really Haskell-like. I would like to know if there is a more idiomatic Haskell way of implementing my code. Ideally, I'm lucky for some combination of higher-order functions (map, filter, fold, etc.) that implement the algorithm.
My Haskell code looks like this:
applyFIR :: Vector Double -> Vector Double -> Vector Double
applyFIR b x = generate (U.length x) help
where
help i = if i >= (U.length b - 1) then loop i (U.length b - 1) else 0
loop yi bi = if bi < 0 then 0 else b !! bi * x !! (yi-bi) + loop yi (bi-1)
vec !! i = unsafeIndex vec i -- Shorthand for unsafeIndex
This code is based on the following C# code:
public float[] RunFilter(double[] x)
{
int M = coeff.Length;
int n = x.Length;
//y[n]=b0x[n]+b1x[n-1]+....bmx[n-M]
var y = new float[n];
for (int yi = 0; yi < n; yi++)
{
double t = 0.0f;
for (int bi = M - 1; bi >= 0; bi--)
{
if (yi - bi < 0) continue;
t += coeff[bi] * x[yi - bi];
}
y[yi] = (float) t;
}
return y;
}
As you can see, it's almost a straight copy. How can I turn my implementation into a more Haskell-like one? Do you have any ideas? The only thing I could come up with was using Vector.generate.
I know that the DSP library has an implementation available. But it uses lists and is way too slow for my use case. This Vector implementation is a lot faster than the one in DSP.
I've also tried implementing the algorithm using Repa. It is faster than the Vector implementation. Here is the result:
applyFIR :: V.Vector Float -> Array U DIM1 Float -> Array D DIM1 Float
applyFIR b x = R.traverse x id (\_ (Z :. i) -> if i >= len then loop i (len - 1) else 0)
where
len = V.length b
loop :: Int -> Int -> Float
loop yi bi = if bi < 0 then 0 else (V.unsafeIndex b bi) * x !! (Z :. (yi-bi)) + loop yi (bi-1)
arr !! i = unsafeIndex arr i
First of all, I don't think that your initial vector code is a faithful translation - that is, I think it disagrees with the C# code. For example, suppose that both "x" and "b" ("b" is coeff in C#) have length 3, and have all values of 1.0. Then for y[0] the C# code would produce x[0] * coeff[0], or 1.0. (it would hit continue for all other values of bi)
With your Haskell code, however, help 0 produces 0. Your Repa version seems to suffer from the same problem.
So let's start with a more faithful translation:
applyFIR :: Vector Double -> Vector Double -> Vector Double
applyFIR b x = generate (U.length x) help
where
help i = loop i (min i $ U.length b - 1)
loop yi bi = if bi < 0 then 0 else b !! bi * x !! (yi-bi) + loop yi (bi-1)
vec !! i = unsafeIndex vec i -- Shorthand for unsafeIndex
Now, you're basically doing a calculation like this for computing, say, y[3]:
... b[3] | b[2] | b[1] | b[0]
x[0] | x[1] | x[2] | x[3] | x[4] | x[5] | ....
multiply
b[3]*x[0]|b[2]*x[1] |b[1]*x[2] |b[0]*x[3]
sum
y[3] = b[3]*x[0] + b[2]*x[1] + b[1]*x[2] + b[0]*x[3]
So one way to think of what you're doing is "take the b vector, reverse it, and to compute spot i of the result, line b[0] up with x[i], multiply all the corresponding x and b entries, and compute the sum".
So let's do that:
applyFIR :: Vector Double -> Vector Double -> Vector Double
applyFIR b x = generate (U.length x) help
where
revB = U.reverse b
bLen = U.length b
help i = let sliceLen = min (i+1) bLen
bSlice = U.slice (bLen - sliceLen) sliceLen revB
xSlice = U.slice (i + 1 - sliceLen) sliceLen x
in U.sum $ U.zipWith (*) bSlice xSlice

F# better performance when mapping a 2DArray -> arraymodule.mapindexed

What would be a more performant way to process this 2DArray without 3rd party?
#time
let ar = array2D[[5.0; 6.0; 7.0; 8.0]; [1.0; 2.0; 3.0; 4.0]]
[0..5000000]
let a2 = ar |> Array2D.mapi(fun rowi coli value -> (value + 1.6) * double(coli + 6) * double(rowi + 7))
If you run the above code, it takes about 0ms, so I it really depends on the context in which you are calling it. If you just run it in a loop 1M times, then it takes about 600ms on my machine:
for i in 0 .. 1000000 do
let a2 = ar |> Array2D.mapi(fun rowi coli value ->
(value + 1.6) * double ((coli + 6) * (rowi + 7)))
()
Here, most of the time is spent allocating the result array - for each iteration, we need to allocate a new 2D array to store the result. This gives you nice functional properties (the results can be shared because they're not mutated) but it is why it takes longer.
You can use some mutation and avoid this. This depends on the context, and so that's why you probably won't get a useful answer here.
For example, in this artificial 1M loop example, I could just allocate one array to store the results and then write there repeatedly:
let res = ar |> Array2D.map id
for i in 0 .. 1000000 do
for x in 0 .. ar.GetLength(0) - 1 do
for y in 0 .. ar.GetLength(1) - 1 do
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
This takes about 100ms, so that gives you an idea about the cost of the allocation. But then, you should not do this change if it can break your program because now you'd be using mutable arrays...
I did some measurements of this problem which I thought could be interesting.
I created 8 different test cases and ran over 3 differently sized matrixes; 1000x1000, 100x100 and 10x10.
In addition I ran the tests in x64 as well as x86.
In the end I ended up with 48 test results presented in two graphs. The y-axis is the execution time in milliseconds.
Creating Zero Matrix - the cost of creating a zero matrix
Copying Matrix - the cost of copying a matrix with Array2D.copy
Mapping Matrix with id - the cost of copying a matrix with Array2D.copy map id
Original Algorithm - the cost of the algorithm posted by OP
Tomas Petricek Algorithm - the cost of the algorithm by Tomas
Modified Tomas Petricek Algorithm - the cost of the modified algorithm to use Array.zeroCreate
Reverse Algorithm - the cost of iterating over the matrix in reverse
Flipped x,y Algorithm - the cost of the modified algorithm but flipping x,y iteration order
Some observations
Tomas wanted to demonstrate the cost of the copy compared to the computation so in his example the copy was not part of the inner loop. I wanted to include his code so I moved the copy into the inner loop to be able to compare with the others. The modified Tomas algorithm is the same code but uses Array2D.zeroCreate to create a fresh matrix. When writing this I realize it would have been better to call both of them modified.
On .NET 4.5.2 x64 is doing significantly better in general
There are performance benefits of using Array2D.zeroCreate and populate the matrix over using Array2D.copy
For large matrixes the x,y iteration order is extremely important. For small matrixes it doesn't matter. This is because how CPU caches works
Iterating reverse order over a the array seems to give a small benefit. The reason is that it's cheaper to check y >= 0 than y < xl.
The reverse algorithm has to use tail-recursion as F# for y = (yl - 1) downto 0 uses y > variable_that_is_always_minus_1 to check for loop end. With tail-recursion we can force y >= 0
For smaller sized Matrixes the cost of creating them and the cost of the GC is increasing.
The code used to generate the measurements.
open System
open System.IO
open System.Diagnostics
let clock =
let sw = Stopwatch ()
sw.Start ()
sw
let collectionCount () =
GC.CollectionCount 0 + GC.CollectionCount 1 + GC.CollectionCount 2
let timeIt (n : string) (outer : int) (a : unit -> 'T) : 'T*int64 =
printfn "Timing '%s'..." n
let v = a ()
let t = clock.ElapsedMilliseconds
for i in 1..outer do
a () |> ignore
let e = clock.ElapsedMilliseconds - t
printfn " took %d ms" e
v, e
[<EntryPoint>]
let main argv =
let random = Random 19740531
let total = 100000000
let outers = [|100;10000;1000000|]
use output = new StreamWriter ".\output.tsv"
"Dimensions\tName\tSum\tCollectionCounts\tMilliseconds" |> output.WriteLine
for outer in outers do
let inner = total / outer
let dim = inner |> float |> sqrt |> int32
let ar = Array2D.init dim dim (fun _ _ -> random.NextDouble ())
printfn "New test run, matrix dimensions are %dx%d" dim dim
let run = sprintf "%d_%d" dim dim
let perf_zero () : float[,] =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
res
let perf_copy () : float[,] =
Array2D.copy ar
let perf_id () : float[,] =
ar |> Array2D.map id
let perf_op () : float[,] =
ar |> Array2D.mapi(fun rowi coli value -> (value + 1.6) * double(coli + 6) * double(rowi + 7))
let perf_tp () : float[,] =
let res = ar |> Array2D.map id
for x in 0 .. ar.GetLength(0) - 1 do
for y in 0 .. ar.GetLength(1) - 1 do
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
res
let perf_tpm () : float[,] =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
for x in 0 .. xl - 1 do
for y in 0 .. yl - 1 do
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
res
let perf_tpmf () : float[,] =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
for y in 0 .. yl - 1 do
for x in 0 .. xl - 1 do
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
res
let perf_tr () : float[,] =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
let rec loopy x y =
if y >= 0 then
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
loopy x (y - 1)
else
()
and loopx x =
if x >= 0 then
loopy x (yl - 1)
loopx (x - 1)
else
()
loopx (xl - 1)
res
let testCases =
[|
"Creating Zero Matrix" , perf_zero
"Copying Matrix" , perf_copy
"Mapping Matrix with id" , perf_id
"Original Algorithm" , perf_op
"Tomas Petricek Algorithm" , perf_tp
"Modified Tomas Petricek Algorithm" , perf_tpm
"Reverse Algoritm" , perf_tr
"Flipped x,y Algoritm" , perf_tpmf
|]
for name, a in testCases do
let pcc = collectionCount ()
let vs, t = timeIt name outer a
let sum = ref 0.
vs |> Array2D.iter (fun v -> sum := !sum + v)
let dcc = collectionCount () - pcc
sprintf "%s\t%s\t%f\t%d\t%d" run name !sum dcc t |> output.WriteLine
0
As OP specified that his problem dealt with smaller Matrixes like 9x4 I did another set of metrics. However since I thought my previous answers held some interesting points on metrics with larger sizes I decided to create a new answer
I did some measurements of this problem which I thought could be interesting.
I created 9 different test cases and ran over it over a 10x5 matrix. All tests run in Release(obviously)/x64.
The first graph shows the execution time in milliseconds:
The second graph shows the number of GC collections during test run:
Creating Zero Matrix - the cost of creating a zero matrix
Copying Matrix - the cost of copying a matrix with Array2D.copy
Mapping Matrix with id - the cost of copying a matrix with Array2D.copy map id
Original Algorithm - the cost of the algorithm posted by OP
Tomas P Algorithm with Zero Init - the cost of the algorithm by Tomas with Array2D.zeroInit
Creating Zero Fixed Size Matrix - the cost of creating a zero fixed size matrix
Copying Fixed Size Matrix - the cost of creating a zero fixed size matrix
Fixed Size Algorithm - the cost of OP:s algorithm adapted to fixed size matrix
Fixed Size Updater - the cost of OP:s algorithm using an updater function
The Fixed Size Matrix is a struct that uses unsafe code to avoid GC allocations. It's written in C# but might be portable to F#. It should not be seen as production worthy code, more like an inspiration for something of your own creation.
Some observations:
Copying a Fixed Size matrix is quick
The Fixed Size Algorithm doesn't perform as good as one hoped. Potentially because JIT:er have to perform some extra lifting because of unsafe code
The Fixed Size Updater (which is similar to Array2D.iteri) has the best performance
As expected Fixed Size Matrixes don't create any GC pressure as it don't rely on GC allocation.
It's hard to judge for me if the Fixed Size Matrix is a viable path for OP but it's an option that might be worth considering.
F# code:
open System
open System.IO
open System.Diagnostics
open Unsafe
let clock =
let sw = Stopwatch ()
sw.Start ()
sw
let collectionCount () =
GC.CollectionCount 0 + GC.CollectionCount 1 + GC.CollectionCount 2
let createTimer (n : string) (a : unit -> 'T) (r : 'T -> 'TResult) : string*(int -> 'TResult*int64*int) =
n, fun outer ->
printfn "Timing '%s'..." n
let v = a () |> r
GC.Collect ()
GC.WaitForFullGCComplete () |> ignore
let pcc = collectionCount ()
let t = clock.ElapsedMilliseconds
for i in 1..outer do
a () |> ignore
let e = clock.ElapsedMilliseconds - t
let dcc = collectionCount () - pcc
printfn " took %d ms, collected %d times, result is %A" e dcc v
v, e, dcc
[<EntryPoint>]
let main argv =
let random = Random 19740531
let total = 300000000
use output = new StreamWriter ".\output.tsv"
"Name\tSum\tCollectionCounts\tMilliseconds" |> output.WriteLine
let cols = 5
let rows = 10
let inner = cols*rows
let outer = total / inner
let ar = Array2D.init rows cols (fun _ _ -> random.NextDouble ())
let mtx5x10 =
let mutable m = Matrix5x10 ()
ar |> Array2D.iteri (fun row col v -> (m.[col, row] <- v))
m
printfn "New test run, matrix dimensions are %dx%d" cols rows
let perf_zero () =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
res
let perf_copy () =
Array2D.copy ar
let perf_id () =
ar |> Array2D.map id
let perf_op () =
ar |> Array2D.mapi(fun rowi coli value -> (value + 1.6) * double(rowi + 6) * double(coli + 7))
let perf_tpm () =
let xl = ar.GetLength(0)
let yl = ar.GetLength(1)
let res = Array2D.zeroCreate xl yl
for x in 0 .. xl - 1 do
for y in 0 .. yl - 1 do
res.[x, y] <- (ar.[x, y] + 1.6) * double ((x + 6) * (y + 7))
res
let perf_fzero () =
let m = Matrix5x10()
m
let perf_fcopy () =
let m = mtx5x10
m
let perf_fs () =
let mutable m = Matrix5x10 ()
for row = 0 to Matrix5x10.Rows - 1 do
for col = 0 to Matrix5x10.Columns - 1 do
m.[col, row] <- (mtx5x10.[col, row] + 1.6) * double ((row + 6) * (col + 7))
m
let perf_fsui = Func<int, int, double, double> (fun col row v -> (v + 1.6) * double ((row + 6) * (col + 7)))
let perf_fsu () =
let mutable m = mtx5x10
m.Update perf_fsui
m
let sumArray vs =
let sum = ref 0.
vs |> Array2D.iter (fun v -> sum := !sum + v)
!sum
let sumMatrix (mtx : Matrix5x10) =
let sum = ref 0.
mtx.Update (fun _ _ v -> sum := !sum + v; v)
!sum
let testCases =
[|
createTimer "Creating Zero Matrix" perf_zero sumArray
createTimer "Copying Matrix" perf_copy sumArray
createTimer "Mapping Matrix with id" perf_id sumArray
createTimer "Original Algorithm" perf_op sumArray
createTimer "Tomas P Algorithm with Zero Init" perf_tpm sumArray
createTimer "Creating Zero Fixed Size Matrix" perf_fzero sumMatrix
createTimer "Copying Fixed Size Matrix" perf_fcopy sumMatrix
createTimer "Fixed Size Algorithm" perf_fs sumMatrix
createTimer "Fixed Size Updater" perf_fsu sumMatrix
|]
for name, a in testCases do
let sum, t, dcc = a outer
sprintf "%s\t%f\t%d\t%d" name sum dcc t |> output.WriteLine
0
C# code (for those that care I generated this with T4):
namespace Unsafe
{
using System;
using System.Diagnostics;
using System.Runtime.CompilerServices;
using System.Runtime.InteropServices;
[StructLayout(LayoutKind.Sequential)]
public struct Matrix5x10
{
double m_c0_r0;
double m_c1_r0;
double m_c2_r0;
double m_c3_r0;
double m_c4_r0;
double m_c0_r1;
double m_c1_r1;
double m_c2_r1;
double m_c3_r1;
double m_c4_r1;
double m_c0_r2;
double m_c1_r2;
double m_c2_r2;
double m_c3_r2;
double m_c4_r2;
double m_c0_r3;
double m_c1_r3;
double m_c2_r3;
double m_c3_r3;
double m_c4_r3;
double m_c0_r4;
double m_c1_r4;
double m_c2_r4;
double m_c3_r4;
double m_c4_r4;
double m_c0_r5;
double m_c1_r5;
double m_c2_r5;
double m_c3_r5;
double m_c4_r5;
double m_c0_r6;
double m_c1_r6;
double m_c2_r6;
double m_c3_r6;
double m_c4_r6;
double m_c0_r7;
double m_c1_r7;
double m_c2_r7;
double m_c3_r7;
double m_c4_r7;
double m_c0_r8;
double m_c1_r8;
double m_c2_r8;
double m_c3_r8;
double m_c4_r8;
double m_c0_r9;
double m_c1_r9;
double m_c2_r9;
double m_c3_r9;
double m_c4_r9;
public const int Columns = 5;
public const int Rows = 10;
unsafe public double this[int x, int y]
{
[MethodImpl (MethodImplOptions.AggressiveInlining)]
get
{
var i = 5 * y + x;
if (i < 0 || i >= 50)
{
throw new IndexOutOfRangeException ("0 <= x <= 5 && 0 <= y <= 10");
}
fixed (double * ms = &m_c0_r0)
{
return ms[i];
}
}
[MethodImpl (MethodImplOptions.AggressiveInlining)]
set
{
var i = 5 * y + x;
if (i < 0 || i >= 50)
{
throw new IndexOutOfRangeException ("0 <= x <= 5 && 0 <= y <= 10");
}
fixed (double * ms = &m_c0_r0)
{
ms[i] = value;
}
}
}
public void Update (Func<int, int, double, double> updater)
{
if (updater == null)
{
return;
}
m_c0_r0 = updater (0, 0, m_c0_r0);
m_c1_r0 = updater (1, 0, m_c1_r0);
m_c2_r0 = updater (2, 0, m_c2_r0);
m_c3_r0 = updater (3, 0, m_c3_r0);
m_c4_r0 = updater (4, 0, m_c4_r0);
m_c0_r1 = updater (0, 1, m_c0_r1);
m_c1_r1 = updater (1, 1, m_c1_r1);
m_c2_r1 = updater (2, 1, m_c2_r1);
m_c3_r1 = updater (3, 1, m_c3_r1);
m_c4_r1 = updater (4, 1, m_c4_r1);
m_c0_r2 = updater (0, 2, m_c0_r2);
m_c1_r2 = updater (1, 2, m_c1_r2);
m_c2_r2 = updater (2, 2, m_c2_r2);
m_c3_r2 = updater (3, 2, m_c3_r2);
m_c4_r2 = updater (4, 2, m_c4_r2);
m_c0_r3 = updater (0, 3, m_c0_r3);
m_c1_r3 = updater (1, 3, m_c1_r3);
m_c2_r3 = updater (2, 3, m_c2_r3);
m_c3_r3 = updater (3, 3, m_c3_r3);
m_c4_r3 = updater (4, 3, m_c4_r3);
m_c0_r4 = updater (0, 4, m_c0_r4);
m_c1_r4 = updater (1, 4, m_c1_r4);
m_c2_r4 = updater (2, 4, m_c2_r4);
m_c3_r4 = updater (3, 4, m_c3_r4);
m_c4_r4 = updater (4, 4, m_c4_r4);
m_c0_r5 = updater (0, 5, m_c0_r5);
m_c1_r5 = updater (1, 5, m_c1_r5);
m_c2_r5 = updater (2, 5, m_c2_r5);
m_c3_r5 = updater (3, 5, m_c3_r5);
m_c4_r5 = updater (4, 5, m_c4_r5);
m_c0_r6 = updater (0, 6, m_c0_r6);
m_c1_r6 = updater (1, 6, m_c1_r6);
m_c2_r6 = updater (2, 6, m_c2_r6);
m_c3_r6 = updater (3, 6, m_c3_r6);
m_c4_r6 = updater (4, 6, m_c4_r6);
m_c0_r7 = updater (0, 7, m_c0_r7);
m_c1_r7 = updater (1, 7, m_c1_r7);
m_c2_r7 = updater (2, 7, m_c2_r7);
m_c3_r7 = updater (3, 7, m_c3_r7);
m_c4_r7 = updater (4, 7, m_c4_r7);
m_c0_r8 = updater (0, 8, m_c0_r8);
m_c1_r8 = updater (1, 8, m_c1_r8);
m_c2_r8 = updater (2, 8, m_c2_r8);
m_c3_r8 = updater (3, 8, m_c3_r8);
m_c4_r8 = updater (4, 8, m_c4_r8);
m_c0_r9 = updater (0, 9, m_c0_r9);
m_c1_r9 = updater (1, 9, m_c1_r9);
m_c2_r9 = updater (2, 9, m_c2_r9);
m_c3_r9 = updater (3, 9, m_c3_r9);
m_c4_r9 = updater (4, 9, m_c4_r9);
}
}
}

Generate two different randoms in F#

I have a F# list and I'm taking two elements of that list.
If the list has 10 elements in it :
let rnd = new Random()
let elem1 = list.Item(rnd.Next(0,9))
let elem2 = list.Item(rnd.Next(0,9))
There is a chance elem1 and elem2 are equal.
I have checked some workarounds and most of them work using a do while, but I don't want to implement a function that may never end in F#.
Is there a way to create a restriction in the random function?
First random : 0 <= x <= 9
Second random : 0 <= y <= 9 <> x
A simple solution:
let rnd = new Random()
let ndx1 = rnd.Next(9)
let ndx2 =
let x = rnd.Next(8)
if x < ndx1 then x else x + 1
let elem1, elem2 = list.[ndx1], list.[ndx2]
Another way, using maths and calling the random function once:
let r = Random().Next(9 * 8)
let x = 1 + r + r / 9
let elem1, elem2 = list.[x / 9], list.[x % 9]
which may be generalised to:
let getTwoElements lst =
let c = List.length lst
let x, y = Math.DivRem(Random().Next(c * (c-1)) * (c+1) / c + 1, c)
lst.[x], lst.[y]
A more declarative approach, taking into account your comment about points in the image:
let rnd = System.Random()
/// this will build you a list of 10 pairs of indices where a <> b.
let indices =
Seq.initInfinite (fun _ -> rnd.Next(0,10), rnd.Next(0,10))
|> Seq.filter (fun (a,b) -> a <> b)
|> Seq.take 10
|> List.ofSeq
/// map indices into actual points.
let elems =
let points = list |> Array.ofList
List.map (fun (a, b) -> points.[a], points.[b]) indices
As a side note, do not use random access on lists. They're not made for that and performance of that is poor. Convert them to an array first.
There are lots of way to achieve this. A simple one would be something like this:
open System
open System.Linq
let rnd = new Random()
let elem1 = list.Item(rnd.Next(0,9))
let elem2 = list.Where(fun x->x <> elem1).ElementAt(rnd.Next(0,8))

Optimising F# answer for Euler #4

I have recently begun learning F#. Hoping to use it to perform any mathematically heavy algorithms in C# applications and to broaden my knowledge
I have so far avoided StackOverflow as I didn't want to see the answer to this until I came to one myself.
I want to be able to write very efficient F# code, focused on performance and then maybe in other ways, such as writing in F# concisely (number of lines etc.).
Project Euler Question 4:
A palindromic number reads the same both ways. The largest palindrome made from the product of two 2-digit numbers is 9009 = 91 × 99.
Find the largest palindrome made from the product of two 3-digit numbers.
My Answer:
let IsPalindrome (x:int) = if x.ToString().ToCharArray() = Array.rev(x.ToString().ToCharArray()) then x else 0
let euler4 = [for i in [100..999] do
for j in [i..999] do yield i*j]
|> Seq.filter(fun x -> x = IsPalindrome(x)) |> Seq.max |> printf "Largest product of two 3-digit numbers is %d"
I tried using option and returning Some(x) and None in IsPalindrome but kept getting compiling errors as I was passing in an int and returning int option. I got a NullRefenceException trying to return None.Value.
Instead I return 0 if the number isn't a palindrome, these 0's go into the Sequence, unfortunately.
Maybe I could order the sequence and then get the top value? instead of using Seq.Max? Or filter out results > 1?
Would this be better? Any advice would be much appreciated, even if it's general F# advice.
Efficiency being a primary concern, using string allocation/manipulation to find a numeric palindrome seems misguided – here's my approach:
module NumericLiteralG =
let inline FromZero () = LanguagePrimitives.GenericZero
let inline FromOne () = LanguagePrimitives.GenericOne
module Euler =
let inline isNumPalindrome number =
let ten = 1G + 1G + 1G + 1G + 1G + 1G + 1G + 1G + 1G + 1G
let hundred = ten * ten
let rec findHighDiv div =
let div' = div * ten
if number / div' = 0G then div else findHighDiv div'
let rec impl n div =
div = 0G || n / div = n % ten && impl (n % div / ten) (div / hundred)
findHighDiv 1G |> impl number
let problem004 () =
{ 100 .. 999 }
|> Seq.collect (fun n -> Seq.init (1000 - n) ((+) n >> (*) n))
|> Seq.filter isNumPalindrome
|> Seq.max
Here's one way to do it:
/// handy extension for reversing a string
type System.String with
member s.Reverse() = String(Array.rev (s.ToCharArray()))
let isPalindrome x = let s = string x in s = s.Reverse()
seq {
for i in 100..999 do
for j in i..999 -> i * j
}
|> Seq.filter isPalindrome
|> Seq.max
|> printfn "The answer is: %d"
let IsPalindrom (str:string)=
let rec fn(a,b)=a>b||str.[a]=str.[b]&&fn(a+1,b-1)
fn(0,str.Length-1)
let IsIntPalindrome = (string>>IsPalindrom)
let sq={100..999}
sq|>Seq.map (fun x->sq|>Seq.map (fun y->(x,y),x*y))
|>Seq.concat|>Seq.filter (snd>>IsIntPalindrome)|>Seq.maxBy (snd)
just my solution:
let isPalin x =
x.ToString() = new string(Array.rev (x.ToString().ToCharArray()))
let isGood num seq1 = Seq.exists (fun elem -> (num % elem = 0 && (num / elem) < 999)) seq1
{998001 .. -1 .. 10000} |> Seq.filter(fun x -> isPalin x) |> Seq.filter(fun x -> isGood x {999 .. -1 .. 100}) |> Seq.nth 0
simplest way is to go from 999 to 100, because is much likley to be product of two large numbers.
j can then start from i because other way around was already tested
other optimisations would go in directions where multiplactions would go descending order, but that makes everything little more difficult. In general it is expressed as list mergeing.
Haskell (my best try in functional programming)
merge f x [] = x
merge f [] y = y
merge f (x:xs) (y:ys)
| f x y = x : merge f xs (y:ys)
| otherwise = y : merge f (x:xs) ys
compare_tuples (a,b) (c,d) = a*b >= c*d
gen_mul n = (n,n) : merge compare_tuples
( gen_mul (n-1) )
( map (\x -> (n,x)) [n-1,n-2 .. 1] )
is_product_palindrome (a,b) = x == reverse x where x = show (a*b)
main = print $ take 10 $ map ( \(a,b)->(a,b,a*b) )
$ filter is_product_palindrome $ gen_mul 9999
output (less than 1s)- first 10 palindromes =>
[(9999,9901,99000099),
(9967,9867,98344389),
(9999,9811,98100189),
(9999,9721,97200279),
(9999,9631,96300369),
(9999,9541,95400459),
(9999,9451,94500549),
(9767,9647,94222249),
(9867,9547,94200249),
(9999,9361,93600639)]
One can see that this sequence is lazy generated from large to small
Optimized version:
let Euler dgt=
let [mine;maxe]=[dgt-1;dgt]|>List.map (fun x->String.replicate x "9"|>int)
let IsPalindrom (str:string)=
let rec fn(a,b)=a>b||str.[a]=str.[b]&&fn(a+1,b-1)
fn(0,str.Length-1)
let IsIntPalindrome = (string>>IsPalindrom)
let rec fn=function
|x,y,max,a,_ when a=mine->x,y,max
|x,y,max,a,b when b=mine->fn(x,y,max,a-1,maxe)
|x,y,max,a,b->a*b|>function
|m when b=maxe&&m<max->x,y,max
|m when m>max&&IsIntPalindrome(m)->fn(a,b,m,a-1,maxe)
|m when m>max->fn(x,y,max,a,b-1)
|_->fn(x,y,max,a-1,maxe)
fn(0,0,0,maxe,maxe)
Log (switch #time on):
> Euler 2;;
Real: 00:00:00.004, CPU: 00:00:00.015, GC gen0: 0, gen1: 0, gen2: 0
val it : int * int * int = (99, 91, 9009)
> Euler 3;;
Real: 00:00:00.004, CPU: 00:00:00.015, GC gen0: 0, gen1: 0, gen2: 0
val it : int * int * int = (993, 913, 906609)
> Euler 4;;
Real: 00:00:00.002, CPU: 00:00:00.000, GC gen0: 0, gen1: 0, gen2: 0
val it : int * int * int = (9999, 9901, 99000099)
> Euler 5;;
Real: 00:00:00.702, CPU: 00:00:00.686, GC gen0: 108, gen1: 1, gen2: 0
val it : int * int * int = (99793, 99041, 1293663921) //int32 overflow
Extern to BigInteger:
let Euler dgt=
let [mine;maxe]=[dgt-1;dgt]|>List.map (fun x->new System.Numerics.BigInteger(String.replicate x "9"|>int))
let IsPalindrom (str:string)=
let rec fn(a,b)=a>b||str.[a]=str.[b]&&fn(a+1,b-1)
fn(0,str.Length-1)
let IsIntPalindrome = (string>>IsPalindrom)
let rec fn=function
|x,y,max,a,_ when a=mine->x,y,max
|x,y,max,a,b when b=mine->fn(x,y,max,a-1I,maxe)
|x,y,max,a,b->a*b|>function
|m when b=maxe&&m<max->x,y,max
|m when m>max&&IsIntPalindrome(m)->fn(a,b,m,a-1I,maxe)
|m when m>max->fn(x,y,max,a,b-1I)
|_->fn(x,y,max,a-1I,maxe)
fn(0I,0I,0I,maxe,maxe)
Check:
Euler 5;;
Real: 00:00:02.658, CPU: 00:00:02.605, GC gen0: 592, gen1: 1, gen2: 0
val it :
System.Numerics.BigInteger * System.Numerics.BigInteger *
System.Numerics.BigInteger =
(99979 {...}, 99681 {...}, 9966006699 {...})

how to match dna sequence pattern

I am getting a trouble finding an approach to solve this problem.
Input-output sequences are as follows :
**input1 :** aaagctgctagag
**output1 :** a3gct2ag2
**input2 :** aaaaaaagctaagctaag
**output2 :** a6agcta2ag
Input nsequence can be of 10^6 characters and largest continuous patterns will be considered.
For example for input2 "agctaagcta" output will not be "agcta2gcta" but it will be "agcta2".
Any help appreciated.
Explanation of the algorithm:
Having a sequence S with symbols s(1), s(2),…, s(N).
Let B(i) be the best compressed sequence with elements s(1), s(2),…,s(i).
So, for example, B(3) will be the best compressed sequence for s(1), s(2), s(3).
What we want to know is B(N).
To find it, we will proceed by induction. We want to calculate B(i+1), knowing B(i), B(i-1), B(i-2), …, B(1), B(0), where B(0) is empty sequence, and and B(1) = s(1). At the same time, this constitutes a proof that the solution is optimal. ;)
To calculate B(i+1), we will pick the best sequence among the candidates:
Candidate sequences where the last block has one element:
B(i )s(i+1)1
B(i-1)s(i+1)2 ; only if s(i) = s(i+1)
B(i-2)s(i+1)3 ; only if s(i-1) = s(i) and s(i) = s(i+1)
…
B(1)s(i+1)[i-1] ; only if s(2)=s(3) and s(3)=s(4) and … and s(i) = s(i+1)
B(0)s(i+1)i = s(i+1)i ; only if s(1)=s(2) and s(2)=s(3) and … and s(i) = s(i+1)
Candidate sequences where the last block has 2 elements:
B(i-1)s(i)s(i+1)1
B(i-3)s(i)s(i+1)2 ; only if s(i-2)s(i-1)=s(i)s(i+1)
B(i-5)s(i)s(i+1)3 ; only if s(i-4)s(i-3)=s(i-2)s(i-1) and s(i-2)s(i-1)=s(i)s(i+1)
…
Candidate sequences where the last block has 3 elements:
…
Candidate sequences where the last block has 4 elements:
…
…
Candidate sequences where last block has n+1 elements:
s(1)s(2)s(3)………s(i+1)
For each possibility, the algorithm stops when the sequence block is no longer repeated. And that’s it.
The algorithm will be some thing like this in psude-c code:
B(0) = “”
for (i=1; i<=N; i++) {
// Calculate all the candidates for B(i)
BestCandidate=null
for (j=1; j<=i; j++) {
Calculate all the candidates of length (i)
r=1;
do {
Candidadte = B([i-j]*r-1) s(i-j+1)…s(i-1)s(i) r
If ( (BestCandidate==null)
|| (Candidate is shorter that BestCandidate))
{
BestCandidate=Candidate.
}
r++;
} while ( ([i-j]*r <= i)
&&(s(i-j*r+1) s(i-j*r+2)…s(i-j*r+j) == s(i-j+1) s(i-j+2)…s(i-j+j))
}
B(i)=BestCandidate
}
Hope that this can help a little more.
The full C program performing the required task is given below. It runs in O(n^2). The central part is only 30 lines of code.
EDIT I have restructured a little bit the code, changed the names of the variables and added some comment in order to be more readable.
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <limits.h>
// This struct represents a compressed segment like atg4, g3, agc1
struct Segment {
char *elements;
int nElements;
int count;
};
// As an example, for the segment agagt3 elements would be:
// {
// elements: "agagt",
// nElements: 5,
// count: 3
// }
struct Sequence {
struct Segment lastSegment;
struct Sequence *prev; // Points to a sequence without the last segment or NULL if it is the first segment
int totalLen; // Total length of the compressed sequence.
};
// as an example, for the sequence agt32ta5, the representation will be:
// {
// lastSegment:{"ta" , 2 , 5},
// prev: #A,
// totalLen: 8
// }
// and A will be
// {
// lastSegment{ "agt", 3, 32},
// prev: NULL,
// totalLen: 5
// }
// This function converts a sequence to a string.
// You have to free the string after using it.
// The strategy is to construct the string from right to left.
char *sequence2string(struct Sequence *S) {
char *Res=malloc(S->totalLen + 1);
char *digits="0123456789";
int p= S->totalLen;
Res[p]=0;
while (S!=NULL) {
// first we insert the count of the last element.
// We do digit by digit starting with the units.
int C = S->lastSegment.count;
while (C) {
p--;
Res[p] = digits[ C % 10 ];
C /= 10;
}
p -= S->lastSegment.nElements;
strncpy(Res + p , S->lastSegment.elements, S->lastSegment.nElements);
S = S ->prev;
}
return Res;
}
// Compresses a dna sequence.
// Returns a string with the in sequence compressed.
// The returned string must be freed after using it.
char *dnaCompress(char *in) {
int i,j;
int N = strlen(in);; // Number of elements of a in sequence.
// B is an array of N+1 sequences where B(i) is the best compressed sequence sequence of the first i characters.
// What we want to return is B[N];
struct Sequence *B;
B = malloc((N+1) * sizeof (struct Sequence));
// We first do an initialization for i=0
B[0].lastSegment.elements="";
B[0].lastSegment.nElements=0;
B[0].lastSegment.count=0;
B[0].prev = NULL;
B[0].totalLen=0;
// and set totalLen of all the sequences to a very HIGH VALUE in this case N*2 will be enougth, We will try different sequences and keep the minimum one.
for (i=1; i<=N; i++) B[i].totalLen = INT_MAX; // A very high value
for (i=1; i<=N; i++) {
// at this point we want to calculate B[i] and we know B[i-1], B[i-2], .... ,B[0]
for (j=1; j<=i; j++) {
// Here we will check all the candidates where the last segment has j elements
int r=1; // number of times the last segment is repeated
int rNDigits=1; // Number of digits of r
int rNDigitsBound=10; // We will increment r, so this value is when r will have an extra digit.
// when r = 0,1,...,9 => rNDigitsBound = 10
// when r = 10,11,...,99 => rNDigitsBound = 100
// when r = 100,101,.,999 => rNDigitsBound = 1000 and so on.
do {
// Here we analitze a candidate B(i).
// where the las segment has j elements repeated r times.
int CandidateLen = B[i-j*r].totalLen + j + rNDigits;
if (CandidateLen < B[i].totalLen) {
B[i].lastSegment.elements = in + i - j*r;
B[i].lastSegment.nElements = j;
B[i].lastSegment.count = r;
B[i].prev = &(B[i-j*r]);
B[i].totalLen = CandidateLen;
}
r++;
if (r == rNDigitsBound ) {
rNDigits++;
rNDigitsBound *= 10;
}
} while ( (i - j*r >= 0)
&& (strncmp(in + i -j, in + i - j*r, j)==0));
}
}
char *Res=sequence2string(&(B[N]));
free(B);
return Res;
}
int main(int argc, char** argv) {
char *compressedDNA=dnaCompress(argv[1]);
puts(compressedDNA);
free(compressedDNA);
return 0;
}
Forget Ukonnen. Dynamic programming it is. With 3-dimensional table:
sequence position
subsequence size
number of segments
TERMINOLOGY: For example, having a = "aaagctgctagag", sequence position coordinate would run from 1 to 13. At sequence position 3 (letter 'g'), having subsequence size 4, the subsequence would be "gctg". Understood? And as for the number of segments, then expressing a as "aaagctgctagag1" consists of 1 segment (the sequence itself). Expressing it as "a3gct2ag2" consists of 3 segments. "aaagctgct1ag2" consists of 2 segments. "a2a1ctg2ag2" would consist of 4 segments. Understood? Now, with this, you start filling a 3-dimensional array 13 x 13 x 13, so your time and memory complexity seems to be around n ** 3 for this. Are you sure you can handle it for million-bp sequences? I think that greedy approach would be better, because large DNA sequences are unlikely to repeat exactly. And, I would suggest that you widen your assignment to approximate matches, and you can publish it straight in a journal.
Anyway, you will start filling the table of compressing a subsequence starting at some position (dimension 1) with length equal to dimension 2 coordinate, having at most dimension 3 segments. So you first fill the first row, representing compressions of subsequences of length 1 consisting of at most 1 segment:
a a a g c t g c t a g a g
1(a1) 1(a1) 1(a1) 1(g1) 1(c1) 1(t1) 1(g1) 1(c1) 1(t1) 1(a1) 1(g1) 1(a1) 1(g1)
The number is the character cost (always 1 for these trivial 1-char sequences; number 1 does not count into the character cost), and in the parenthesis, you have the compression (also trivial for this simple case). The second row will be still simple:
2(a2) 2(a2) 2(ag1) 2(gc1) 2(ct1) 2(tg1) 2(gc1) 2(ct1) 2(ta1) 2(ag1) 2(ga1) 2(ag1)
There is only 1 way to decompose a 2-character sequence into 2 subsequences -- 1 character + 1 character. If they are identical, the result is like a + a = a2. If they are different, such as a + g, then, because only 1-segment sequences are admissible, the result cannot be a1g1, but must be ag1. The third row will be finally more interesting:
2(a3) 2(aag1) 3(agc1) 3(gct1) 3(ctg1) 3(tgc1) 3(gct1) 3(cta1) 3(tag1) 3(aga1) 3(gag1)
Here, you can always choose between 2 ways of composing the compressed string. For example, aag can be composed either as aa + g or a + ag. But again, we cannot have 2 segments, as in aa1g1 or a1ag1, so we must be satisfied with aag1, unless both components consist of the same character, as in aa + a => a3, with character cost 2. We can continue onto 4 th line:
4(aaag1) 4(aagc1) 4(agct1) 4(gctg1) 4(ctgc1) 4(tgct1) 4(gcta1) 4(ctag1) 4(taga1) 3(ag2)
Here, on the first position, we cannot use a3g1, because only 1 segment is allowed at this layer. But at the last position, compression to character cost 3 is agchieved by ag1 + ag1 = ag2. This way, one can fill the whole first-level table all the way up to the single subsequence of 13 characters, and each subsequence will have its optimal character cost and its compression under the first-level constraint of at most 1 segment associated with it.
Then you go to the 2nd level, where 2 segments are allowed... And again, from the bottom up, you identify the optimum cost and compression of each table coordinate under the given level's segment count constraint, by comparing all the possible ways to compose the subsequence using already computed positions, until you fill the table completely and thus compute the global optimum. There are some details to solve, but sorry, I'm not gonna code this for you.
After trying my own way for a while, my kudos to jbaylina for his beautiful algorithm and C implementation. Here's my attempted version of jbaylina's algorithm in Haskell, and below it further development of my attempt at a linear-time algorithm that attempts to compress segments that include repeated patterns in a one-by-one fashion:
import Data.Map (fromList, insert, size, (!))
compress s = (foldl f (fromList [(0,([],0)),(1,([s!!0],1))]) [1..n - 1]) ! n
where
n = length s
f b i = insert (size b) bestCandidate b where
add (sequence, sLength) (sequence', sLength') =
(sequence ++ sequence', sLength + sLength')
j' = [1..min 100 i]
bestCandidate = foldr combCandidates (b!i `add` ([s!!i,'1'],2)) j'
combCandidates j candidate' =
let nextCandidate' = comb 2 (b!(i - j + 1)
`add` ((take j . drop (i - j + 1) $ s) ++ "1", j + 1))
in if snd nextCandidate' <= snd candidate'
then nextCandidate'
else candidate' where
comb r candidate
| r > uBound = candidate
| not (strcmp r True) = candidate
| snd nextCandidate <= snd candidate = comb (r + 1) nextCandidate
| otherwise = comb (r + 1) candidate
where
uBound = div (i + 1) j
prev = b!(i - r * j + 1)
nextCandidate = prev `add`
((take j . drop (i - j + 1) $ s) ++ show r, j + length (show r))
strcmp 1 _ = True
strcmp num bool
| (take j . drop (i - num * j + 1) $ s)
== (take j . drop (i - (num - 1) * j + 1) $ s) =
strcmp (num - 1) True
| otherwise = False
Output:
*Main> compress "aaagctgctagag"
("a3gct2ag2",9)
*Main> compress "aaabbbaaabbbaaabbbaaabbb"
("aaabbb4",7)
Linear-time attempt:
import Data.List (sortBy)
group' xxs sAccum (chr, count)
| null xxs = if null chr
then singles
else if count <= 2
then reverse sAccum ++ multiples ++ "1"
else singles ++ if null chr then [] else chr ++ show count
| [x] == chr = group' xs sAccum (chr,count + 1)
| otherwise = if null chr
then group' xs (sAccum) ([x],1)
else if count <= 2
then group' xs (multiples ++ sAccum) ([x],1)
else singles
++ chr ++ show count ++ group' xs [] ([x],1)
where x:xs = xxs
singles = reverse sAccum ++ (if null sAccum then [] else "1")
multiples = concat (replicate count chr)
sequences ws strIndex maxSeqLen = repeated' where
half = if null . drop (2 * maxSeqLen - 1) $ ws
then div (length ws) 2 else maxSeqLen
repeated' = let (sequence,(sequenceStart, sequenceEnd'),notSinglesFlag) = repeated
in (sequence,(sequenceStart, sequenceEnd'))
repeated = foldr divide ([],(strIndex,strIndex),False) [1..half]
equalChunksOf t a = takeWhile(==t) . map (take a) . iterate (drop a)
divide chunkSize b#(sequence,(sequenceStart, sequenceEnd'),notSinglesFlag) =
let t = take (2*chunkSize) ws
t' = take chunkSize t
in if t' == drop chunkSize t
then let ts = equalChunksOf t' chunkSize ws
lenTs = length ts
sequenceEnd = strIndex + lenTs * chunkSize
newEnd = if sequenceEnd > sequenceEnd'
then sequenceEnd else sequenceEnd'
in if chunkSize > 1
then if length (group' (concat (replicate lenTs t')) [] ([],0)) > length (t' ++ show lenTs)
then (((strIndex,sequenceEnd,chunkSize,lenTs),t'):sequence, (sequenceStart,newEnd),True)
else b
else if notSinglesFlag
then b
else (((strIndex,sequenceEnd,chunkSize,lenTs),t'):sequence, (sequenceStart,newEnd),False)
else b
addOne a b
| null (fst b) = a
| null (fst a) = b
| otherwise =
let (((start,end,patLen,lenS),sequence):rest,(sStart,sEnd)) = a
(((start',end',patLen',lenS'),sequence'):rest',(sStart',sEnd')) = b
in if sStart' < sEnd && sEnd < sEnd'
then let c = ((start,end,patLen,lenS),sequence):rest
d = ((start',end',patLen',lenS'),sequence'):rest'
in (c ++ d, (sStart, sEnd'))
else a
segment xs baseIndex maxSeqLen = segment' xs baseIndex baseIndex where
segment' zzs#(z:zs) strIndex farthest
| null zs = initial
| strIndex >= farthest && strIndex > 0 = ([],(0,0))
| otherwise = addOne initial next
where
next#(s',(start',end')) = segment' zs (strIndex + 1) farthest'
farthest' | null s = farthest
| otherwise = if start /= end && end > farthest then end else farthest
initial#(s,(start,end)) = sequences zzs strIndex maxSeqLen
areExclusive ((a,b,_,_),_) ((a',b',_,_),_) = (a' >= b) || (b' <= a)
combs [] r = [r]
combs (x:xs) r
| null r = combs xs (x:r) ++ if null xs then [] else combs xs r
| otherwise = if areExclusive (head r) x
then combs xs (x:r) ++ combs xs r
else if l' > lowerBound
then combs xs (x: reduced : drop 1 r) ++ combs xs r
else combs xs r
where lowerBound = l + 2 * patLen
((l,u,patLen,lenS),s) = head r
((l',u',patLen',lenS'),s') = x
reduce = takeWhile (>=l') . iterate (\x -> x - patLen) $ u
lenReduced = length reduce
reduced = ((l,u - lenReduced * patLen,patLen,lenS - lenReduced),s)
buildString origStr sequences = buildString' origStr sequences 0 (0,"",0)
where
buildString' origStr sequences index accum#(lenC,cStr,lenOrig)
| null sequences = accum
| l /= index =
buildString' (drop l' origStr) sequences l (lenC + l' + 1, cStr ++ take l' origStr ++ "1", lenOrig + l')
| otherwise =
buildString' (drop u' origStr) rest u (lenC + length s', cStr ++ s', lenOrig + u')
where
l' = l - index
u' = u - l
s' = s ++ show lenS
(((l,u,patLen,lenS),s):rest) = sequences
compress [] _ accum = reverse accum ++ (if null accum then [] else "1")
compress zzs#(z:zs) maxSeqLen accum
| null (fst segment') = compress zs maxSeqLen (z:accum)
| (start,end) == (0,2) && not (null accum) = compress zs maxSeqLen (z:accum)
| otherwise =
reverse accum ++ (if null accum || takeWhile' compressedStr 0 /= 0 then [] else "1")
++ compressedStr
++ compress (drop lengthOriginal zzs) maxSeqLen []
where segment'#(s,(start,end)) = segment zzs 0 maxSeqLen
combinations = combs (fst $ segment') []
takeWhile' xxs count
| null xxs = 0
| x == '1' && null (reads (take 1 xs)::[(Int,String)]) = count
| not (null (reads [x]::[(Int,String)])) = 0
| otherwise = takeWhile' xs (count + 1)
where x:xs = xxs
f (lenC,cStr,lenOrig) (lenC',cStr',lenOrig') =
let g = compare ((fromIntegral lenC + if not (null accum) && takeWhile' cStr 0 == 0 then 1 else 0) / fromIntegral lenOrig)
((fromIntegral lenC' + if not (null accum) && takeWhile' cStr' 0 == 0 then 1 else 0) / fromIntegral lenOrig')
in if g == EQ
then compare (takeWhile' cStr' 0) (takeWhile' cStr 0)
else g
(lenCompressed,compressedStr,lengthOriginal) =
head $ sortBy f (map (buildString (take end zzs)) (map reverse combinations))
Output:
*Main> compress "aaaaaaaaabbbbbbbbbaaaaaaaaabbbbbbbbb" 100 []
"a9b9a9b9"
*Main> compress "aaabbbaaabbbaaabbbaaabbb" 100 []
"aaabbb4"

Resources