To memoize or not to memoize - optimization

... that is the question. I have been working on an algorithm which takes an array of vectors as input, and part of the algorithm repeatedly picks pairs of vectors and evaluates a function of these two vectors, which doesn't change over time. Looking at ways to optimize the algorithm, I thought this would be a good case for memoization: instead of recomputing the same function value over and over again, cache it lazily and hit the cache.
Before jumping to code, here is the gist of my question: the benefits I get from memoization depend on the number of vectors, which I think is inversely related to number of repeated calls, and in some circumstances memoization completely degrades performance. So is my situation inadequate for memoization? Am I doing something wrong, and are there smarter ways to optimize for my situation?
Here is a simplified test script, which is fairly close to the real thing:
open System
open System.Diagnostics
open System.Collections.Generic
let size = 10 // observations
let dim = 10 // features per observation
let runs = 10000000 // number of function calls
let rng = new Random()
let clock = new Stopwatch()
let data =
[| for i in 1 .. size ->
[ for j in 1 .. dim -> rng.NextDouble() ] |]
let testPairs = [| for i in 1 .. runs -> rng.Next(size), rng.Next(size) |]
let f v1 v2 = List.fold2 (fun acc x y -> acc + (x-y) * (x-y)) 0.0 v1 v2
printfn "Raw"
clock.Restart()
testPairs |> Array.averageBy (fun (i, j) -> f data.[i] data.[j]) |> printfn "Check: %f"
printfn "Raw: %i" clock.ElapsedMilliseconds
I create a list of random vectors (data), a random collection of indexes (testPairs), and run f on each of the pairs.
Here is the memoized version:
let memoized =
let cache = new Dictionary<(int*int),float>(HashIdentity.Structural)
fun key ->
match cache.TryGetValue(key) with
| true, v -> v
| false, _ ->
let v = f data.[fst key] data.[snd key]
cache.Add(key, v)
v
printfn "Memoized"
clock.Restart()
testPairs |> Array.averageBy (fun (i, j) -> memoized (i, j)) |> printfn "Check: %f"
printfn "Memoized: %i" clock.ElapsedMilliseconds
Here is what I am observing:
* when size is small (10), memoization goes about twice as fast as the raw version,
* when size is large (1000), memoization take 15x more time than raw version,
* when f is costly, memoization improves things
My interpretation is that when the size is small, we have more repeat computations, and the cache pays off.
What surprised me was the huge performance hit for larger sizes, and I am not certain what is causing it. I know I could improve the dictionary access a bit, with a struct key for instance - but I didn't expect the "naive" version to behave so poorly.
So - is there something obviously wrong with what I am doing? Is memoization the wrong approach for my situation, and if yes, is there a better approach?

I think memoization is a useful technique, but it is not a silver bullet. It is very useful in dynamic programming where it reduces the (theoretical) complexity of the algorithm. As an optimization, it can (as you would probably expect) have varying results.
In your case, the cache is certainly more useful when the number of observations is smaller (and f is more expensive computation). You can add simple statistics to your memoization:
let stats = ref (0, 0) // Count number of cache misses & hits
let memoized =
let cache = new Dictionary<(int*int),float>(HashIdentity.Structural)
fun key ->
let (mis, hit) = !stats
match cache.TryGetValue(key) with
| true, v -> stats := (mis, hit + 1); v // Increment hit count
| false, _ ->
stats := (mis + 1, hit); // Increment miss count
let v = f data.[fst key] data.[snd key]
cache.Add(key, v)
v
For small size, the numbers I get are something like (100, 999900) so there is a huge benefit from memoization - the function f is computed 100x and then each result is reused 9999x.
For big size, I get something like (632331, 1367669) so f is called many times and each result is reused just twice. In that case, the overhead with allocation and lookup in the (big) hash table is much bigger.
As a minor optimization, you can pre-allocate the Dictionary and write new Dictionary<_, _>(10000,HashIdentity.Structural), but that does not seem to help much in this case.
To make this optimization efficient, I think you would need to know some more information about the memoized function. In your example, the inputs are quite regular, so there is porbably no point in memoization, but if you know that the function is more often called with some values of arguments, you can perhaps only memoize only for these common arguments.

Tomas's answer is great for when you should use memoization. Here's why memoization is going so slow in your case.
It sounds like you're testing in Debug mode. Run your test again in Release and you should get a faster result for memoization. Tuples can cause a large performance hit while in Debug mode. I added a hashed version for comparison along with some micro optimizations.
Release
Raw
Check: 1.441687
Raw: 894
Memoized
Check: 1.441687
Memoized: 733
memoizedHash
Check: 1.441687
memoizedHash: 552
memoizedHashInline
Check: 1.441687
memoizedHashInline: 493
memoizedHashInline2
Check: 1.441687
memoizedHashInline2: 385
Debug
Raw
Check: 1.409310
Raw: 797
Memoized
Check: 1.409310
Memoized: 5190
memoizedHash
Check: 1.409310
memoizedHash: 593
memoizedHashInline
Check: 1.409310
memoizedHashInline: 497
memoizedHashInline2
Check: 1.409310
memoizedHashInline2: 373
Source
open System
open System.Diagnostics
open System.Collections.Generic
let size = 10 // observations
let dim = 10 // features per observation
let runs = 10000000 // number of function calls
let rng = new Random()
let clock = new Stopwatch()
let data =
[| for i in 1 .. size ->
[ for j in 1 .. dim -> rng.NextDouble() ] |]
let testPairs = [| for i in 1 .. runs -> rng.Next(size), rng.Next(size) |]
let f v1 v2 = List.fold2 (fun acc x y -> acc + (x-y) * (x-y)) 0.0 v1 v2
printfn "Raw"
clock.Restart()
testPairs |> Array.averageBy (fun (i, j) -> f data.[i] data.[j]) |> printfn "Check: %f"
printfn "Raw: %i\n" clock.ElapsedMilliseconds
let memoized =
let cache = new Dictionary<(int*int),float>(HashIdentity.Structural)
fun key ->
match cache.TryGetValue(key) with
| true, v -> v
| false, _ ->
let v = f data.[fst key] data.[snd key]
cache.Add(key, v)
v
printfn "Memoized"
clock.Restart()
testPairs |> Array.averageBy (fun (i, j) -> memoized (i, j)) |> printfn "Check: %f"
printfn "Memoized: %i\n" clock.ElapsedMilliseconds
let memoizedHash =
let cache = new Dictionary<int,float>(HashIdentity.Structural)
fun key ->
match cache.TryGetValue(key) with
| true, v -> v
| false, _ ->
let i = key / size
let j = key % size
let v = f data.[i] data.[j]
cache.Add(key, v)
v
printfn "memoizedHash"
clock.Restart()
testPairs |> Array.averageBy (fun (i, j) -> memoizedHash (i * size + j)) |> printfn "Check: %f"
printfn "memoizedHash: %i\n" clock.ElapsedMilliseconds
let memoizedHashInline =
let cache = new Dictionary<int,float>(HashIdentity.Structural)
fun key ->
match cache.TryGetValue(key) with
| true, v -> v
| false, _ ->
let i = key / size
let j = key % size
let v = f data.[i] data.[j]
cache.Add(key, v)
v
printfn "memoizedHashInline"
clock.Restart()
let mutable total = 0.0
for i, j in testPairs do
total <- total + memoizedHashInline (i * size + j)
printfn "Check: %f" (total / float testPairs.Length)
printfn "memoizedHashInline: %i\n" clock.ElapsedMilliseconds
printfn "memoizedHashInline2"
clock.Restart()
let mutable total2 = 0.0
let cache = new Dictionary<int,float>(HashIdentity.Structural)
for i, j in testPairs do
let key = (i * size + j)
match cache.TryGetValue(key) with
| true, v -> total2 <- total2 + v
| false, _ ->
let i = key / size
let j = key % size
let v = f data.[i] data.[j]
cache.Add(key, v)
total2 <- total2 + v
printfn "Check: %f" (total2 / float testPairs.Length)
printfn "memoizedHashInline2: %i\n" clock.ElapsedMilliseconds
Console.ReadLine() |> ignore

Related

Elm calculation using fold

I just started playing around with Elm and functional programming. I really like the language but I do have trouble implementing very simply calculations.
My below code takes as input wacc : Float and cfs : List Float and should calculate a net preset value (i.e. for each element of cfs calculate cfs_i / (1 + wacc)^i and then calculate the sum of the values).
The code works but is very verbose and potentially not idiomatic.
My main question besides hints how to make it more concise / idiomatic is how do I change my code to be able to accept wacc and cfs of types Maybe.
Helpful for any hint / info. Thanks!
-- helper functions
zip : List a -> List b -> List (a,b)
zip list1 list2 =
List.map2 Tuple.pair list1 list2
calcDF : Float -> Int -> List Float
calcDF wacc n =
let
waccs = List.repeat n wacc
time = List.range 0 n |> List.map toFloat
waccs_time = zip waccs time
in
List.map (\x -> 1/ (1 + Tuple.first x)^(Tuple.second x)) waccs_time
-- my npv function
calcNPV : List Float -> Float -> Html text
calcNPV cfs wacc =
let
n = List.length cfs
df = calcDF wacc n
cfs_df = zip cfs df
in
List.map (\x -> (Tuple.first x) * (Tuple.second x)) cfs_df
|> List.foldl (+) 0
Example:
calcNPV [100,100,100] 0.1
-- returns 273.553719
I'm not sure why you want to use Maybes.
But as you suspected, you have made the current code more complex than needed. Here's a reworking of the first function. You want n discount values, so we start by creating something with n items to loop over and then just do the calculation in the map function
calcDF : Float -> Int -> List Float
calcDF wacc n =
List.range 0 n
|> List.map (calcDF_ wacc)
calcDF_ : Float -> Int -> Float
calcDF_ wacc idx =
1 / (1 + toFloat idx) ^ wacc
If you use https://package.elm-lang.org/packages/elm-community/list-extra/latest/List-Extra#indexedFoldl you could simplify the main function just to call calcDF_ while looping folding over cfs and skip calcDF altogether
With the help from Elm discourse forum (see here) I came up with the following solutions.
NPV calculation without type Maybe
calcNPV : List Float -> Float -> Float
calcNPV cashflows wacc =
let
time = List.length cashflows |> List.range 0 |> List.map toFloat
waccs = List.repeat (List.length cashflows) wacc
calcPV : Float -> Float -> Float -> Float
calcPV cf i t = cf / (1+i)^t
in
List.map3 calcPV cashflows waccs time |> List.foldl (+) 0
NPV calculation with type Maybe
calcMaybeNPV : List (Maybe Float) -> Maybe Float -> Maybe Float
calcMaybeNPV maybecashflows maybewacc =
let
time = List.length maybecashflows |> List.range 0 |> List.map (\x -> Just (toFloat x))
waccs = List.repeat (List.length maybecashflows) maybewacc
calcPV : Maybe Float -> Maybe Float -> Maybe Float -> Maybe Float
calcPV cf i t =
Maybe.map3 (\a b c -> a / (1+b)^c) cf i t
in
List.map3 calcPV maybecashflows waccs time |> List.foldl (Maybe.map2 (+)) (Just 0)

F# comparing lambdas for equality

I would like to try and compare F# lambdas for equality. This is, at first inspection, not possible.
let foo = 10
let la = (fun x y -> x + y + foo)
let lb = (fun x y -> x + y + foo)
printfn "lambda equals %b" (la = lb)
which generates the error
The type '('a -> 'b -> int)' does not support the 'equality' constraint because it is a function typeF# Compiler(1)
However, and surprisingly, it is possible to serialize lambda functions.
open System.Runtime.Serialization.Formatters.Binary
open System.IO
let serialize o =
let bf = BinaryFormatter()
use ms = new MemoryStream()
bf.Serialize(ms,o)
ms.ToArray()
let ByteToHex bytes =
bytes
|> Array.map (fun (x : byte) -> System.String.Format("{0:X2}", x))
|> String.concat System.String.Empty
let foo = 10
let la = (fun x y -> x + y + foo)
let lb = (fun x y -> x + y + foo)
let a = serialize la
let b = serialize lb
printfn "%s" (ByteToHex a)
printfn "%s" (ByteToHex b)
printfn "lambda equals %b" (a = b)
which suggests that if they can be serialized they can be compared. However, inspection of the byte stream for this example shows two bytes where there is a difference.
Is there possibly a strategy to solve this problem by intelligently comparing the byte arrays?
From an equivalence perspective, functions aren't meaningfully serialized.
Curryable functions in F# are implemented as derived from FSharpFunc.
let la = (fun x y -> x + y + foo)
would be implemented as an instance of the following class (in equivalent C#):
[Serializable] class Impl : FSharpFunc<int, int, int>
{
public int foo;
Impl(int foo_) => foo = foo_;
public override int Invoke(int x, int y) =>
x + y + _foo;
}
What binary serialization captures would be the full typename and the value of foo.
In fact if we look at strings in the byte stream we see:
test, Version=1.0.0.0, Culture=neutral, PublicKeyToken=null
Program+la#28
foo
...where la#28 is the name of our derived class.
Where the byte stream for la and lb differs is the name of the implementing class. The implementations of la and lb could be entirely different.
You could, for instance, change lb into let lb = (fun x y -> x * y + foo), and the result would be same for both runs.
You can however, do this with Code Quotations:
let foo = 10
let la = <# fun x y -> x + y + foo #>
let lb = <# fun x y -> x + y + foo #>
printfn "Is same: %b" (la.ToString() = lb.ToString()) //true
F# also supports Expression<Func<>> (C#'s expression trees) - which is also a valid avenue for comparison.

Partition list into more than 2 parts

So I want to partitision a List ItemModel in Elm into List (List ItemModel). List.partition only makes the list into two lists.
I wrote some code that makes the list into the parts I want (code below).
But it's not as nice of a solution as I'd like, and since it seems like an issue many people would have, I wonder are there better examples of doing this?
partition : List (ItemModel -> Bool) -> List ItemModel -> List (List ItemModel)
partition filters models =
let
filterMaybe =
List.head filters
in
case filterMaybe of
Just filter ->
let
part =
Tuple.first (List.partition filter models)
in
part :: (partition (List.drop 1 filters) models)
Nothing ->
[]
The returned list maps directly from the filters parameter, so it's actually pretty straightforward to do this using just List.map and List.filter (which is what you're really doing since you're discarding the remainder list returned from List.partition):
multifilter : List (a -> Bool) -> List a -> List (List a)
multifilter filters values =
filters |> List.map(\filter -> List.filter filter values)
Repeated partitioning needs to use the leftovers from each step as the input for the next step. This is different than simple repeated filtering of the same sequence by several filters.
In Haskell (which this question was initially tagged as, as well),
partitions :: [a -> Bool] -> [a] -> [[a]]
partitions preds xs = go preds xs
where
go [] xs = []
go (p:ps) xs = let { (a,b) = partition p xs } in (a : go ps b)
which is to say,
partitions preds xs = foldr g (const []) preds xs
where
g p r xs = let { (a,b) = partition p xs } in (a : r b)
or
-- mapAccumL :: (acc -> x -> (acc, y)) -> acc -> [x] -> (acc, [y])
partitions preds xs = snd $ mapAccumL (\xs p -> partition (not . p) xs) xs preds
Testing:
> partitions [ (<5), (<10), const True ] [1..15]
[[1,2,3,4],[5,6,7,8,9],[10,11,12,13,14,15]]
unlike the repeated filtering,
> [ filter p xs | let xs = [1..15], p <- [ (<5), (<10), const True ]]
[[1,2,3,4],[1,2,3,4,5,6,7,8,9],[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15]]

Changing a mutable field in OCaml

When I run the following code I get a syntax error, although as far as I can tell the syntax is correct. This attempts to implement a queue structure, where the function from_list converts a list to a queue with the corresponding values. I wrote str_of_int_q to print the contents of a queue. x and y are supposed to be two nodes, with x at the head and y at the tail.
;; open Assert
type 'a qnode = {v: 'a;
mutable next: 'a qnode option}
type 'a queue = {mutable head: 'a qnode option;
mutable tail: 'a qnode option}
let from_list (l: 'a list) : 'a queue =
let rec loop (l2: 'a list) (qu: 'a queue) =
begin match l2 with
| [] -> qu
| [x] -> let y = {v = x; next = None} in
qu.head <- Some y; qu.tail <- Some y;
qu
| h1::h2::t -> let y = qu.head in
let z = {v = h1; next = y} in
qu.head <- Some z;
qu
end
in loop l {head = None; tail = None}
let str_of_int_q (q: int queue) : string =
let rec loop (r: int qnode option) (s: string) : string =
begin match r with
| None -> s
| Some n -> loop n.next (s ^ (string_of_int n.v))
end
in loop q.head ""
let x = {v = 1; next = None}
let y = {v = 2; next = None}
x.next <- Some y;
let z = {head = Some x; tail = Some y}
;; print_endline (str_of_int_q z)
My error:
line 32, characters 7-9:
Error: Syntax error
Line 32 is the line x.next <- Some y; and characters 7-9 indicate the <-. But I'm storing into a mutable field an object of the appropriate type, so I don't see what's going wrong.
Top-level statements are separated by ;; in OCaml. However, ;; is optional before several keywords, such as let, open, type, etc. This is why you don't need ;; most of the time.
In your case, ;; is needed to disambiguate between let y = {v = 2; next = None} and x.next <- Some y. The latter is an expression and doesn't start with a special keyword, so OCaml doesn't know to insert an implicit ;; here.
See also http://ocaml.org/learn/tutorials/structure_of_ocaml_programs.html#The-disappearance-of.
As explained there, you can either do
let y = {v = 2; next = None}
;; x.next <- Some y
or
let y = {v = 2; next = None}
let () = x.next <- Some y
This latter solution works because by introducing a dummy binding we're starting our statement with let, which disambiguates again.
Note: I've also removed the trailing ; from your code. ; is actually an infix operator that combines two expressions (by throwing the result of the first one away and returning the result of the second one). This is not what you want here.

How to Eliminate Cost-centres in String Taversals and List Comprehensions

I'm implementing a motif finding algorithm from the domain of bioinformatics using Haskell. I wont go into the details of the algorithm other then to say it's branch and bound median string search. I had planned on making my implementation more interesting by implementing a concurrent approach (and later an STM approach) in order to get a multicore speed up but after compiling with the follow flags
$ ghc -prof -auto-all -O2 -fllvm -threaded -rtsopts --make main
and printing the profile I saw something interesting (and perhaps obvious):
COST CENTRE entries %time %alloc
hammingDistance 34677951 47.6 14.7
motifs 4835446 43.8 71.1
It's clear that a remarkable speedup could be gained without going anywhere near multicore programming (although that's been done and I just need to find some good test data and sort out Criterion for that).
Anyway, both of these functions are purely functional and in no way concurrent. They're also doing quite simple stuff, so I was surprised that they took so much time. Here's the code for them:
data NukeTide = A | T | C | G deriving (Read, Show, Eq, Ord, Enum)
type Motif = [NukeTide]
hammingDistance :: Motif -> Motif -> Int
hammingDistance [] [] = 0
hammingDistance xs [] = 0 -- optimistic
hammingDistance [] ys = 0 -- optimistic
hammingDistance (x:xs) (y:ys) = case (x == y) of
True -> hammingDistance xs ys
False -> 1 + hammingDistance xs ys
motifs :: Int -> [a] -> [[a]]
motifs n nukeTides = [ take n $ drop k nukeTides | k <- [0..length nukeTides - n] ]
Note that of the two arguments to hammingDistance, I can actually assume that xs is going to be x long and that ys is going to be less than or equal to that, if that opens up room for improvements.
As you can see, hammingDistance calculates the hamming distance between two motifs, which are lists of nucleotides. The motifs function takes a number and a list and returns all the sub strings of that length, e.g.:
> motifs 3 "hello world"
["hel","ell","llo","lo ","o w"," wo","wor","orl","rld"]
Since the algorithmic processes involved are so simple I can't think of a way to optimize this further. I do however have two guesses as to where I should be headed:
HammingDistance: The data types I'm using (NukeTides and []) are slow/clumsy. This is just a guess, since I'm not familiar with their implementations but I think defining my own datatype, although more legible, probably involves more overhead then I intend. Also the pattern matching is foreign to me, I don't know if that is trivial or costly.
Motifs: If I'm reading this correctly, 70% of all memory allocations are done by motifs, and I'd assume that has to be garbage collected at some time. Again using the all purpose list might be slowing me down or the list comprehension, since the cost of that is incredibly unclear to me.
Does anybody have any advice on the usual procedure here? If data types are the problem, would arrays be the right answer? (I've heard they come in boxes)
Thanks for the help.
Edit: It just occurred to me that it might be useful if I describe the manner in which these two functions are called:
totalDistance :: Motif -> Int
totalDistance motif = sum $ map (minimum . map (hammingDistance motif) . motifs l) dna
This function is the result of another function, and is passed around nodes in a tree. At each node in the tree an evaluation of the nucleotide (of length <= n, that is if == n then it is a leaf node) is done, using totalDistance to score the node. From then on it's your typical branch and bound algorithm.
Edit: John asked that I print out the change I made which virutally eliminated the cost of motifs:
scoreFunction :: DNA -> Int -> (Motif -> Int)
scoreFunction dna l = totalDistance
where
-- The sum of the minimum hamming distance in each line of dna
-- is given by totalDistance motif
totalDistance motif = sum $ map (minimum . map (hammingDistance motif)) possibleMotifs
possibleMotifs = map (motifs l) dna -- Previously this was computed in the line above
I didn't make it clear in my original post, but scoreFunction is only called once, and the result is passed around in a tree traversal/branch and bound and used to evaluate nodes. Recomputing motifs at every step of the way, in retrospect, isn't one of the brightest things I've done.
Your definition of motifs looks like it's doing a lot more traversing than necessary because each application of drop has to traverse the list from the beginning. I would implement it using Data.List.tails instead:
motifs2 :: Int -> [a] -> [[a]]
motifs2 n nukeTides = map (take n) $ take count $ tails nukeTides
where count = length nukeTides - n + 1
A quick comparison in GHCi shows the difference (using sum . map length to force evaluation):
*Main> let xs = concat (replicate 10000 [A, T, C, G])
(0.06 secs, 17914912 bytes)
*Main> sum . map length $ motifs 5 xs
199980
(3.47 secs, 56561208 bytes)
*Main> sum . map length $ motifs2 5 xs
199980
(0.15 secs, 47978952 bytes)
Your definition of hammingDistance is probably much less efficient than it could be.
hammingDistance (x:xs) (y:ys) = case (x == y) of
True -> hammingDistance xs ys
False -> 1 + hammingDistance xs ys
Because of haskell's laziness, this will be expanded to (in the worst case):
(1 + (1 + (1 + ...)))
which will exist as a thunk on the stack, getting reduced only when it's used. Whether this is actually a problem depends on the call site, compiler options, etc., so it's often good practice to write your code in a form which avoids this issue altogether.
A common solution is to create a tail-recursive form with a strict accumulator, but in this case you could use higher-order functions, like this:
hammingDistance :: Motif -> Motif -> Int
hammingDistance xs ys = length . filter (uncurry (==)) $ zip xs ys
here's the tail-recursive implementation, for comparison
hammingDistance :: Motif -> Motif -> Int
hammingDistance xs ys = go 0 xs ys
where
go !acc [] [] = acc
go !acc xs [] = acc -- optimistic
go !acc [] ys = acc -- optimistic
go !acc (x:xs) (y:ys) = case (x == y) of
True -> go acc xs ys
False -> go (acc+1) xs ys
This uses the BangPatterns extension to force the accumulator to be strictly evaluated, otherwise it would have the same problem as your current definition.
To directly answer some of your other questions:
Pattern matching is trivial
Whether you should use lists or arrays depends mostly on how the data is created and how it's consumed. For this case, it's possible that lists may be the best type. In particular, if your lists are all consumed as they're created, and you don't ever need the whole list in memory, they should be fine. If you do retain lists in memory though, they have a lot of space overhead.
Usage patterns
I think the way you use these functions does some extra work as well:
(minimum . map (hammingDistance motif) . motifs l
Since you only need the minimum hammingDistance, you may be calculating a lot of extra values which aren't necessary. I can think of two solutions to this:
Option 1. Define a new function hammingDistanceThresh :: Motif -> Int -> Motif -> Int, which stops when it exceeds the threshold. The slightly odd type ordering is to facilitate using it in a fold, like this:
let motifs' = motifs l
in foldl' (hammingDistanceThresh motif) (hammingDistance motif $ head motifs') (tail motifs')
Option 2. If you define a lazy natural number type, you can use that instead of Ints for the result of hammingDistance. Then only as much of the hamming distance as necessary will be calculated.
One final note: using -auto-all will very frequently generate much slower code than other profiling options. I would suggest you try using just -auto first, and then adding manual SCC annotations if necessary.
Right... I could not resist going to the limit and wrote a plain-metal-ish packed-bits implementation:
{-# language TypeSynonymInstances #-}
{-# language BangPatterns #-}
import Data.Bits
import Data.Word
data NukeTide = A | T | C | G deriving (Read, Show, Eq, Ord, Enum)
type UnpackedMotif = [NukeTide]
type PackageType = Word32
nukesInPackage = 16 :: Int
allSetMask = complement 0 :: PackageType
-- Be careful to have length of motif == nukesInPackage here!
packNukesToWord :: UnpackedMotif -> PackageType
packNukesToWord = packAt 0
where packAt _ [] = 0
packAt i (m:ml) = (b0 m .&. bit i)
.|. (b1 m .&. bit (i+1))
.|. packAt (i+2) ml
b0 A = 0
b0 T = allSetMask
b0 C = 0
b0 G = allSetMask
b1 A = 0
b1 T = 0
b1 C = allSetMask
b1 G = allSetMask
unpackNukesWord :: PackageType -> UnpackedMotif
unpackNukesWord = unpackNNukesFromWord nukesInPackage
unpackNNukesFromWord :: Int -> PackageType -> UnpackedMotif
unpackNNukesFromWord = unpackN
where unpackN 0 _ = []
unpackN i w = (nukeOf $ w .&. r2Mask):(unpackN (i-1) $ w`shiftR`2)
nukeOf bs
| bs == 0 = A
| bs == bit 0 = T
| bs == bit 1 = C
| otherwise = G
r2Mask = (bit 1 .|. bit 0) :: PackageType
data PackedMotif = PackedMotif { motifPackets::[PackageType]
, nukesInLastPack::Int }
-- note nukesInLastPack will never be zero; motifPackets must be [] to represent empty motifs.
packNukes :: UnpackedMotif -> PackedMotif
packNukes m = case remain of
[] -> PackedMotif [packNukesToWord takeN] (length takeN)
r -> prAppend (packNukesToWord takeN) (packNukes r)
where (takeN, remain) = splitAt nukesInPackage m
prAppend w (PackedMotif l i) = PackedMotif (w:l) i
unpackNukes :: PackedMotif -> UnpackedMotif
unpackNukes (PackedMotif l i) = unpack l i
where unpack [l] i = unpackNNukesFromWord i l
unpack (l:ls) i = unpackNukesWord l ++ unpack ls i
unpack [] _ = []
instance Show PackedMotif where
show = show . unpackNukes
class Nukes a where
pLength :: a -> Int
shiftLN1 :: a -> a
hammingDistance :: a -> a -> Int
motifs :: Int -> a -> [a]
instance Nukes PackageType where
pLength _ = nukesInPackage
shiftLN1 = (`shiftR`2)
hammingDistance !x !y = fromIntegral $ abt (x `xor` y)
where abt !b = bbt(b.&.a0Mask .|. ((b.&.a1Mask) `shiftR` 1))
bbt !b = sbt $ (b.&.r16Mask) + (b `shiftR` nukesInPackage)
sbt !b = (r2Mask .&. b) + (r2Mask .&. (b`shiftR`2))
+ (r2Mask .&. (b`shiftR`4)) + (r2Mask .&. (b`shiftR`6))
+ (r2Mask .&. (b`shiftR`8)) + (r2Mask .&. (b`shiftR`10))
+ (r2Mask .&. (b`shiftR`12)) + (r2Mask .&. (b`shiftR`14))
a0Mask = 0x55555555 :: PackageType
a1Mask = 0xAAAAAAAA :: PackageType
r16Mask = 0xFFFF :: PackageType
r2Mask = 0x3 :: PackageType
motifs 0 _ = []
motifs l x = x : motifs (l-1) (shiftLN1 x)
maskNukesBut :: Int -> PackageType -> PackageType
maskNukesBut i = ( ( allSetMask `shiftR` (2*(nukesInPackage - i)) ) .&.)
instance Nukes PackedMotif where
pLength (PackedMotif (x:xs) ix) = nukesInPackage * (length xs) + ix
pLength _ = 0
shiftLN1 ξ#(PackedMotif [] _) = ξ
shiftLN1 (PackedMotif [x] ix) | ix>1 = PackedMotif [x`shiftR`2] (ix-1)
| otherwise = PackedMotif [] nukesInPackage
shiftLN1 (PackedMotif (x:x':xs) ix)
= PackedMotif (( shiftLN1 x .|. pnext ):sxs) resLMod
where sxs = motifPackets $ shiftLN1 (PackedMotif (x':xs) ix)
pnext = shiftL (x'.&.0x3) 30
resLMod = if ix > 1 then (ix-1) else nukesInPackage
hammingDistance xs ys = go 0 xs ys
where
go :: Int -> PackedMotif -> PackedMotif -> Int
go !acc (PackedMotif [x] ix) (PackedMotif [y] iy)
| ix > iy = acc + (hammingDistance y $ maskNukesBut iy x)
| otherwise = acc + (hammingDistance x $ maskNukesBut ix y)
go !acc (PackedMotif [x] ix) (PackedMotif (y:ys) iy)
= acc + (hammingDistance x $ maskNukesBut ix y)
go !acc (PackedMotif (x:xs) ix) (PackedMotif [y] iy)
= acc + (hammingDistance y $ maskNukesBut iy x)
go !acc (PackedMotif (x:xs) ix) (PackedMotif (y:ys) iy)
= go (acc + hammingDistance x y) (PackedMotif xs ix) (PackedMotif ys iy)
go !acc _ _ = acc
motifs l ξ
| l>0 = fShfts (min nukesInPackage $ pLength ξ + 1 - l) ξ >>= ct
| otherwise = []
where fShfts k χ | k > 0 = χ : fShfts (k-1) (shiftLN1 χ)
| otherwise = []
ct (PackedMotif ys iy) = case remain of
[] -> if (length takeN - 1) * nukesInPackage + iy >= l
then [PackedMotif takeN lMod] else []
_ -> PackedMotif takeN lMod : ct(PackedMotif (tail ys) iy)
where (takeN, remain) = splitAt lQuot ys
(lQuot,lMod) = case l `quotRem` nukesInPackage of
(i,0) -> (i, nukesInPackage)
(i,m) -> (i+1, m)
It can be used from UnpackedMotif = [NukeTide]s with the packNukes function, e.g.
*BioNuke0> motifs 23 $ packNukes $ take 27 $ cycle [A,T,G,C,A]
[[A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G],[T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C],[G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A],[C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A],[A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T,G,C,A,A,T]]
*BioNuke0> hammingDistance (packNukes [A,T,G,C,A,A,T,G]) (packNukes [A,T,C,C,A,T,G])
3
*BioNuke0> map (hammingDistance (packNukes $ take 52 $ cycle [A,T,C,C,A,T,G])) (motifs 52 $ packNukes $ take 523 $ cycle [A,T,C,C,A,T,G])
[0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44,38,52,0,52,36,45,44]
I haven't compared the performance to the original version yet, but it should be quite a bit faster than any algebraic-datatype implementation. Plus, it readily offers a space-efficient storage format.