F# Type-directed memoization. IntTrie, knapsack problem and levenshtein distance.

Nach wochenlangem Bewerbungsstress und Frustration darüber, dass es wohl kaum F#-Jobstellen auf dem Markt gibt und die wenigen, die da sind, richten sich ausschlislich an Hochschulabsolventen, habe ich mich weiter mit der "Type-directed Memoization" beschäftigt. Dabei endeckte ich eine interessante OCaml Implementation.
Ich suchte nach konkreten praktischen Beispielen und merkte sehr schnell, dass in diesem Zusammenhang oft zwei Algorithmen genannt werden. Das Knapsack Problem
und die Levenshtein-Distanz. Hier ein paar Links zu diesen Themen.

Solving the 0-1 knapsack problem using continuation-passing style with memoization in F#.
    Haskell Version.
    Haskell Version mit der IntTrie-Datenstruktur.
    Die Levenshtein-Distanz auf Rosetta Code Seite.
    "Haskell function computes the edit distance in O(length a * (1 + dist a b)) time complexity".
    Lazy Levenshtein Distanz.

Von IntTrie war ich sofort begeistert und versuchte die abgespeckte Version - also nur positive Integers - nach F# zu übertragen.

// TypeMemo.fs
namespace TypeMemoization
// from http://hackage.haskell.org/packages/archive/data-inttrie/0.0.7/doc/html/src/Data-IntTrie.html
module BitTrie =
    
    type BitTrie<'a> = BitTrie of Lazy<'a> * Lazy<BitTrie<'a>> * Lazy<BitTrie<'a>>
    // A trie from positiv integers to values of type a. 
    type IntTrie<'a> = IntTrie of Lazy<'a> * BitTrie<'a>
    
    let inline testBit x = (x &&& 1) <> 0

    let rec fmap f (BitTrie (x, l, r)) = 
        BitTrie( lazy(f x.Value), 
                 lazy(fmap f l.Value), 
                 lazy(fmap f r.Value) )

    let identityPositive = 
        let rec go x = 
            BitTrie (x, 
                     lazy(fmap (fun n-> n <<< 1) (go x)), 
                     lazy(fmap (fun n -> (n <<< 1) ||| 1) (go x)))
        go (lazy(1))

    let inline fmapi f (IntTrie(z, pos)) = 
        IntTrie(lazy(f z.Value), fmap f pos)

    //The identity trie.
    let identity = IntTrie (lazy(0), identityPositive)

    let inline toTrie f  =  fmapi f identity

    let rec applyPositive (BitTrie (one, even, odd)) x =
        match x with
        | i when i = 1 ->       one
        | i when testBit i  ->  applyPositive odd.Value (x >>> 1) 
        | otherwise   ->        applyPositive even.Value (x >>> 1)

    // Apply the trie to an argument.
    let inline apply (IntTrie(z, pos)) x =
        match x with
        | 0 -> z.Value
        |_ -> (applyPositive pos x).Value 
    
    let inline memo f = apply (toTrie f)

    // Memoize a two argument function (just apply the table directly for
    // single argument functions).
    let inline memo2 f = memo (memo << f)

//knapsack.fs
namespace TypeMemoization

module knapsack =
    open System

    let inline genItems n = 
        match n with
        | 0 -> Array.empty 
        | _ -> Array.init n 
                        ( fun i ->
                            let weight = i % 5
                            let value = (float)(weight * i)
                            weight, value )
    let inline max (x:float) (y:float) = max x y 

    let inline knapsackOriginal desiredWeight (items:_[]) =               
        let inline weightOf i = fst items.[i-1]
        let inline valueOf i = snd items.[i-1] 

        let rec knapsack' i w  = 
            match i, w  with
            | 0, _ | _, 0 -> 0.
            | i, w    -> 
                match i with
                | i' when (weightOf i') > w -> 
                    knapsack' (i' - 1) w           
                | _ -> 
                    max (knapsack' (i - 1) w)  ((knapsack' (i - 1) (w - weightOf i)) + valueOf i)
                    
        knapsack' items.Length desiredWeight

    let inline knapsack weight (value:int->float) =                
        
        let rec knapsack' i w  = 
            match i, w  with
            | 0, _ | _, 0 -> 0.
            | i, w    -> 
                match i with
                | i' when (weight i') > w ->
                    knapsackMemo (i' - 1) w           
                | _ -> 
                    max (knapsackMemo (i - 1) w)  ((knapsackMemo (i - 1) (w - weight i)) + value i)
                    
        and knapsackMemo  = BitTrie.memo2 knapsack'
        knapsackMemo  

    let inline knapsackMemoized desiredWeight (items:_[]) =
        let inline weightOf i = fst items.[i-1]
        let inline valueOf i = snd items.[i-1] 

        knapsack weightOf valueOf (items.Length) (desiredWeight)

Zwar ist die "memoized" Version schneller als der originale Knapsack-Algorithmus, aber leider viel langsamer als Zach Bray's Version und folglich um X-faches langsamer als die imperative Variante. Es kann aber auch sein, dass meine F# Implementierung von IntTrie nicht die beste ist.

Mit der Levenshtein Distanz sieht es noch schlimmer aus. Wieder ist die "memoized" Variante besser als die naive Version, aber mit der Array-Lösung kann sie überhaupt nicht mithalten. Interessant ist der bereits erwähnte Lazy Levenshtein Algorithmus. Dieser in F# zu übertragen ist mir leider nicht gelungen.
Also ist mein Frust nur noch tiefer geworden.

// from http://research.microsoft.com/en-us/um/people/simonpj/papers/assoc-types/fun-with-type-funs/typefun.pdf.
// chapter "3.1 Type-directed memoization".
namespace TypeMemoization
module BitTrie =
    ...
module TypeMemo =
    open BitTrie

    type IFromTable<'a,'w > =
        abstract inline fromTable : 'a->'w
    
    let inline fromTable t = (t :> IFromTable<_,_>).fromTable
    // "we can memoise any function from Bool by storing its two
    // return values as a lazy pair. This lazy pair is the memo table."
    type BoolTable<'w> = 
        | BTable of Lazy<'w> * Lazy<'w> 
        interface IFromTable<bool,'w> with
            member inline x.fromTable b = 
                match x with
                | BTable(x,y) -> if b then x.Force() else y.Force()
    
    let inline boolToTable f = 
        BTable (lazy(f true), lazy(f false))
    
    
    //"memoise functions from any sum type, such as the type Either."
    type Either<'a,'b>= 
        |Left of 'a
        |Right of 'b
    // "We can memoise a function from Either a b by storing a lazy pair of a
    // memo table from a and a memo table from b. That is, we take advantage
    // of the isomorphism between the function type Either a b -> w and the
    // product type (a -> w, b -> w)."
    type DiscriminatedUnionTable<'a,'b,'w> = 
        | STable of IFromTable<'a,'w> * IFromTable<'b,'w> 
        interface IFromTable<Either<'a,'b>,'w> with
            member inline x.fromTable e = 
                match x, e with
                | STable (t,_), Left  v   -> t.fromTable v
                | STable (_,t), Right v   -> t.fromTable v
    
    let inline discriminatedUnionToTable f fa fb =
        STable (fa (f<<Left),fb (f<<Right))
    
    
    // "Dually, we can memoise functions from the product type (a,b) by storing a memo table
    // from a whose entries are memo tables from b."
    type ProductTable<'a,'b,'w> = 
        | PTable of IFromTable<'a, IFromTable<'b,'w>>
        interface IFromTable<('a*'b),'w> with
            member inline x.fromTable p = 
                match x, p with
                | PTable t,(a,b)-> (t.fromTable a).fromTable b

    let inline productToTable f fa fb = 
        PTable ((fa (fun a -> fb (fun b -> f (a, b)) :> IFromTable<_,_> )) :> IFromTable<_,_>)   
   

    // "A list is a combination of a sum, a product, and recursion.
    // Since a list is either empty or not, ListTable<'a,'w> is represented by a pair, whose first component is the result of applying
    // the memoised function f to the empty list, and whose second component
    // memoises applying f to non-empty lists."
    type ListTable<'a,'w> =
        | LTable of Lazy<'w> * IFromTable<'a, IFromTable<'a list, 'w>>
        interface IFromTable<'a list,'w> with
            member inline x.fromTable l =
                match x, l with
                | LTable(t, _), [] -> t.Force() 
                | LTable(_, t), x :: xs -> fromTable (fromTable t x ) xs
                    
    let rec listToTable f fa =
        LTable (lazy(f []), fa (fun x -> listToTable (fun xs ->  f (x::xs)) fa :> IFromTable<_,_>) :> IFromTable<_,_>)
    let inline flip1 f a b c = f c a b

    type CharTable<'w> =
        | CharTable of IntTrie<'w>  
        interface IFromTable<char, 'w> with
            member inline x.fromTable c =
                match x with
                | CharTable t ->  apply t (int c)
    let inline charToTable f = 
        CharTable (toTrie (f << char))
    
    let inline memoCharList2 f = 
        let memo g =
            listToTable g charToTable  |> fromTable
        memo (memo << f)

Levenshtein Distanz.

//levenshtein .fs
namespace TypeMemoisation
module levenshtein =
    open System
    
    let inline private naiveLevenshteinDistance del sub ins  =  
        let rec inner s1 s2 =
            match s1, s2 with
            | s1,     []     -> ins * List.length s1 
            | [],     s2     -> ins * List.length s2 
            | x :: xs, y :: ys ->
                match x = y with
                | true -> inner xs ys
                | _ -> List.min [ del + inner xs s2; 
                                 sub + inner s1 ys; 
                                 ins + inner xs ys] 
        inner

    let inline runNaiveLevenshteinDistance (s1:string) (s2:string) =
        naiveLevenshteinDistance 1 1 1 (List.ofSeq s1) (List.ofSeq s2)
    //memoized version.
    let inline private levenshteinDistance del sub ins  =  
        let rec inner s1 s2 =
            match s1, s2 with
            | s1,     []     -> ins * List.length s1 
            | [],     s2     -> ins * List.length s2 
            | x :: xs, y :: ys ->
                match x = y with
                | true -> memo xs ys
                | _ -> min (del + memo xs s2)   
                                 (min (sub + memo s1 ys) (ins + memo xs ys)) 
        and memo = 
                TypeMemo.memoCharList2 inner
        memo

    let inline levenshteinDistanceMemoized (s1:string) (s2:string) =
        levenshteinDistance 1 1 1 (List.ofSeq s1) (List.ofSeq s2)
    
    //array version.
    let inline levenshteinDistanceArray (s1:string) (s2:string) =
         let sa, sb:char [] * char [] = s1.ToCharArray(), s2.ToCharArray()
         let len = Array.length sa
         let m = len - 1

         let inline compute z xc = min (z+1) xc

         let inline transform (narr : int []) chb =
              Array.zip3 sa.[..m] narr.[..m] narr.[1..m+1] 
              |> Array.map (fun (cha, x, y) -> min (y + 1) (x + abs(compare cha chb)) )
              |> Array.scan compute (narr.[0] + 1)
         let result = Array.fold transform [|0..len|] sb
         result.[result.Length - 1]