free dsl cofree interpreter

dslinterpreter.fsx

module Dsl =
    type AdderF<'k> =
      | Add of int * (bool -> 'k)
      | Clear of 'k
      | Total of (int -> 'k)

    let fmap f d =
        match d with
            | Add(x,k) -> Add(x,f << k)
            | Clear k -> Clear (f k)
            | Total k -> Total (f << k)
    type Free<'a> =
      | Pure of 'a
      | Free of AdderF<Free<'a>>

    type FreeBuilder() =
        member x.Bind(v:Free<'a>,f:'a->Free<'b>) = 
            match v with
                | Free(m) -> Free(fmap (fun x' -> x.Bind(x', f)) m)
                | Pure(v) -> f(v)

        member x.Return v = Pure(v)

    let liftF x = Free (fmap Pure x)

    let rec foldFree f x =
        match x with
            | (Pure a) -> a
            | (Free x) -> f (fmap (foldFree f) x)

    let free = FreeBuilder() 

    let add x = liftF <| Add(x,id)
    let clear = liftF <| Clear()
    let total = liftF <| Total(id)

module AdHoc =
    open Dsl
    let rec interpret limit count a =
      match a with
        | Pure r -> r
        | Free (Add(x,k)) ->
              let count' = x + count
              let test = count' <= limit
              let next = if test then count' else count
              interpret limit next (k test)
        | Free (Clear k) ->
          interpret limit 0 k
        |  Free (Total k) ->
          interpret limit count (k count)

module DslI =
    type CoAdderF<'k> = {
                addH   : int -> (bool * 'k);
                clearH : 'k;
                totalH : int * 'k
              }

    let rec fmap f c = {
        addH = fun i -> let b, k = c.addH i
                        b, f k
        clearH = (f c.clearH)
        totalH = let i,k = c.totalH
                 i, f k
        }

module CoFreeI = 
    let typeFmap = DslI.fmap

    type Cofree<'a> = CoFree of 'a * Lazy<DslI.CoAdderF<Cofree<'a>>>

//    let extract (CoFree(a,_)) = a
//    let rec duplicate c = 
//        let (CoFree(_,fs)) = c 
//        CoFree(c,lazy(typeFmap duplicate (fs.Force())))
//    let rec fmap f (CoFree(a,fs)) = CoFree(f a, lazy((typeFmap <| fmap f) (fs.Force()))) 
//    let extend f = fmap f << duplicate
//    let rec unfold (f:'b -> 'a * DslI.CoAdderF<'b>) (c:'b) : Cofree<'a> = 
//        match f c with
//            | (x, d) -> CoFree(x, lazy(DslI.fmap (unfold f) d))

    let rec coiter f a = CoFree(a, lazy(DslI.fmap (coiter f) (f a)))
    
    type Limit = int
    type Count = int

    let coClear (limit, count) = (limit, 0)
    let coTotal (limit, count) = (count, (limit, count))
    let coAdd (limit, count) x = 
        let count' = count + x                        
        let test = count' <= limit                   
        let next = if test then count' else count 
        (test, (limit, next))

    let mkCoAdder limit count = 
        let next w = { DslI.CoAdderF.addH = coAdd w;
                       DslI.CoAdderF.clearH = coClear w;
                       DslI.CoAdderF.totalH  = coTotal w}
        let start = (limit, count) 
        coiter next start

module Pair =
    open Dsl
    open DslI
    let uncurry f = fun (a,b) -> f a b
    let pairTF (p:'a -> 'b -> 'r) (f:'c * 'a) (g:'c-> 'b) = p (snd f) (g (fst f))
    let pairFT (p:'a -> 'b -> 'r) (f:'a0 -> 'a) g = uncurry (p << f) g

    let rec pair<'a,'b,'r> (f:'a -> 'b -> 'r) (c : DslI.CoAdderF<'a>) (d: Dsl.AdderF<'b>) : 'r =
        match d with
            | Add(x,k) -> pairTF f (c.addH x) k
            | Clear k  -> f c.clearH k
            | Total k  -> pairTF f c.totalH k
    and pairF<'a,'b,'r> (p:'a -> 'b -> 'r) (CoFreeI.CoFree(a, fs) : CoFreeI.Cofree<'a>) (free: Dsl.Free<'b>) : 'r =
        match free with
            | Dsl.Pure x  -> p a x
            | Dsl.Free gs -> pair (pairF p) (fs.Force()) gs

    let runLimit w progr = pairF (fun _ b -> b) w progr

open Dsl

let program = free{
        let! _ = add 1
        let! _ = add 1
        let! c = total
        return c 
    }

let limit = 10
let start = 9
AdHoc.interpret limit start program |> printfn "adhoc %A"
let coFreeInterpreter = CoFreeI.mkCoAdder limit start
Pair.runLimit coFreeInterpreter program |> printfn "cofree %A"