7 people like it.
Like the snippet!

A parametric fixpoint combinator

Writing functions that recursively generate lambdas from a given parameter is a useful practice, but things get trickier when you need the output functions themselves to be mutually recursive. This is my attempt at creating a fix-point combinator that transparently handles this requirement. It also gives memoization for free as a side-effect.

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57:

open System.Collections.Generic

type Dictionary<'K,'V> with
    member d.TryFind(k : 'K) =
        let v = ref Unchecked.defaultof<_>
        if d.TryGetValue(k, v) then Some v.Value else None


let rec Y F x = F (Y F) x

let YParam (F : ('Seed -> 'a -> 'b) -> 'Seed -> 'a -> 'b) =
    let dict = new Dictionary<'Seed, ('a -> 'b) ref> ()

    let F' (self : 'Seed -> 'a -> 'b) (s : 'Seed) =
        match dict.TryFind s with
        | None ->
            let fp = ref (fun _ -> failwith "Bottom!")
            dict.Add(s, fp)
            let f = F self s
            fp := f
            f
        | Some fp -> (fun a -> fp.Value a)

    Y F'

// example : computing the maximum depth of F# DUs

open System
open System.Reflection
open Microsoft.FSharp.Reflection

let maxDepth<'T> = 
    let f = 
        YParam (fun self (t : Type) ->
                printfn "Precomputing depth counter for %A" t
                if FSharpType.IsUnion t then
                    let reader = FSharpValue.PreComputeUnionTagReader t
                    // recursively precompute children
                    let fieldDepth (f : PropertyInfo) = let depthF = self f.PropertyType in fun o -> f.GetValue(o, [||]) |> depthF
                    let ucis = FSharpType.GetUnionCases(t) |> Seq.map(fun u -> u.Tag, u.GetFields() |> Array.map fieldDepth) |> Map.ofSeq

                    fun (o : obj) ->
                        let depths = ucis.[reader o] |> Array.map (fun f -> f o)
                        if Seq.isEmpty depths then 0 else (Seq.max depths) + 1
                else fun _ -> 0) typeof<'T>

    fun (x : 'T) -> f (x :> obj)


type Peano = Zero | Succ of Peano

let rec int2Peano = function 0 -> Zero | n -> Succ(int2Peano(n-1))

// Peano is recursive, would stack overflow if used regular Y combinator
let d = maxDepth<Peano option>

d <| Some (int2Peano 41)

namespace System

namespace System.Collections

namespace System.Collections.Generic

Multiple items
type Dictionary<'TKey,'TValue> =
  new : unit -> Dictionary<'TKey, 'TValue> + 5 overloads
  member Add : key:'TKey * value:'TValue -> unit
  member Clear : unit -> unit
  member Comparer : IEqualityComparer<'TKey>
  member ContainsKey : key:'TKey -> bool
  member ContainsValue : value:'TValue -> bool
  member Count : int
  member GetEnumerator : unit -> Enumerator<'TKey, 'TValue>
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member Item : 'TKey -> 'TValue with get, set
  ...
  nested type Enumerator
  nested type KeyCollection
  nested type ValueCollection

Full name: System.Collections.Generic.Dictionary<_,_>

--------------------
Dictionary() : unit
Dictionary(capacity: int) : unit
Dictionary(comparer: IEqualityComparer<'TKey>) : unit
Dictionary(dictionary: IDictionary<'TKey,'TValue>) : unit
Dictionary(capacity: int, comparer: IEqualityComparer<'TKey>) : unit
Dictionary(dictionary: IDictionary<'TKey,'TValue>, comparer: IEqualityComparer<'TKey>) : unit

val d : Dictionary<'TKey,'TValue>

member Dictionary.TryFind : k:'TKey -> 'TValue option

Full name: Script.TryFind

val k : 'TKey

val v : 'TValue ref

Multiple items
val ref : value:'T -> 'T ref

Full name: Microsoft.FSharp.Core.Operators.ref

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>

module Unchecked

from Microsoft.FSharp.Core.Operators

val defaultof<'T> : 'T

Full name: Microsoft.FSharp.Core.Operators.Unchecked.defaultof

Dictionary.TryGetValue(key: 'TKey, value: byref<'TValue>) : bool

union case Option.Some: Value: 'T -> Option<'T>

property Ref.Value: 'TValue

union case Option.None: Option<'T>

val Y : F:(('a -> 'b) -> 'a -> 'b) -> x:'a -> 'b

Full name: Script.Y

val F : (('a -> 'b) -> 'a -> 'b)

val x : 'a

val YParam : F:(('Seed -> 'a -> 'b) -> 'Seed -> 'a -> 'b) -> ('Seed -> 'a -> 'b) (requires equality)

Full name: Script.YParam

val F : (('Seed -> 'a -> 'b) -> 'Seed -> 'a -> 'b) (requires equality)

val dict : Dictionary<'Seed,('a -> 'b) ref> (requires equality)

val F' : (('Seed -> 'a -> 'b) -> 'Seed -> 'a -> 'b) (requires equality)

val self : ('Seed -> 'a -> 'b) (requires equality)

val s : 'Seed (requires equality)

member Dictionary.TryFind : k:'TKey -> 'TValue option

val fp : ('a -> 'b) ref

val failwith : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.failwith

Dictionary.Add(key: 'Seed, value: ('a -> 'b) ref) : unit

val f : ('a -> 'b)

val a : 'a

property Ref.Value: 'a -> 'b

namespace System.Reflection

namespace Microsoft

namespace Microsoft.FSharp

namespace Microsoft.FSharp.Reflection

val maxDepth<'T> : ('T -> int)

Full name: Script.maxDepth

val f : (obj -> int)

val self : (Type -> obj -> int)

val t : Type

type Type =
  inherit MemberInfo
  member Assembly : Assembly
  member AssemblyQualifiedName : string
  member Attributes : TypeAttributes
  member BaseType : Type
  member ContainsGenericParameters : bool
  member DeclaringMethod : MethodBase
  member DeclaringType : Type
  member Equals : o:obj -> bool + 1 overload
  member FindInterfaces : filter:TypeFilter * filterCriteria:obj -> Type[]
  member FindMembers : memberType:MemberTypes * bindingAttr:BindingFlags * filter:MemberFilter * filterCriteria:obj -> MemberInfo[]
  ...

Full name: System.Type

val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn

type FSharpType =
  static member GetExceptionFields : exceptionType:Type * ?bindingFlags:BindingFlags -> PropertyInfo []
  static member GetFunctionElements : functionType:Type -> Type * Type
  static member GetRecordFields : recordType:Type * ?bindingFlags:BindingFlags -> PropertyInfo []
  static member GetTupleElements : tupleType:Type -> Type []
  static member GetUnionCases : unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo []
  static member IsExceptionRepresentation : exceptionType:Type * ?bindingFlags:BindingFlags -> bool
  static member IsFunction : typ:Type -> bool
  static member IsModule : typ:Type -> bool
  static member IsRecord : typ:Type * ?bindingFlags:BindingFlags -> bool
  static member IsTuple : typ:Type -> bool
  ...

Full name: Microsoft.FSharp.Reflection.FSharpType

static member FSharpType.IsUnion : typ:Type * ?allowAccessToPrivateRepresentation:bool -> bool
static member FSharpType.IsUnion : typ:Type * ?bindingFlags:BindingFlags -> bool

val reader : (obj -> int)

type FSharpValue =
  static member GetExceptionFields : exn:obj * ?bindingFlags:BindingFlags -> obj []
  static member GetRecordField : record:obj * info:PropertyInfo -> obj
  static member GetRecordFields : record:obj * ?bindingFlags:BindingFlags -> obj []
  static member GetTupleField : tuple:obj * index:int -> obj
  static member GetTupleFields : tuple:obj -> obj []
  static member GetUnionFields : value:obj * unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo * obj []
  static member MakeFunction : functionType:Type * implementation:(obj -> obj) -> obj
  static member MakeRecord : recordType:Type * values:obj [] * ?bindingFlags:BindingFlags -> obj
  static member MakeTuple : tupleElements:obj [] * tupleType:Type -> obj
  static member MakeUnion : unionCase:UnionCaseInfo * args:obj [] * ?bindingFlags:BindingFlags -> obj
  ...

Full name: Microsoft.FSharp.Reflection.FSharpValue

static member FSharpValue.PreComputeUnionTagReader : unionType:Type * ?allowAccessToPrivateRepresentation:bool -> (obj -> int)
static member FSharpValue.PreComputeUnionTagReader : unionType:Type * ?bindingFlags:BindingFlags -> (obj -> int)

val fieldDepth : (PropertyInfo -> 'a -> int)

val f : PropertyInfo

type PropertyInfo =
  inherit MemberInfo
  member Attributes : PropertyAttributes
  member CanRead : bool
  member CanWrite : bool
  member Equals : obj:obj -> bool
  member GetAccessors : unit -> MethodInfo[] + 1 overload
  member GetConstantValue : unit -> obj
  member GetGetMethod : unit -> MethodInfo + 1 overload
  member GetHashCode : unit -> int
  member GetIndexParameters : unit -> ParameterInfo[]
  member GetOptionalCustomModifiers : unit -> Type[]
  ...

Full name: System.Reflection.PropertyInfo

val depthF : (obj -> int)

property PropertyInfo.PropertyType: Type

val o : 'a

PropertyInfo.GetValue(obj: obj, index: obj []) : obj
PropertyInfo.GetValue(obj: obj, invokeAttr: BindingFlags, binder: Binder, index: obj [], culture: Globalization.CultureInfo) : obj

val ucis : Map<int,(obj -> int) []>

static member FSharpType.GetUnionCases : unionType:Type * ?allowAccessToPrivateRepresentation:bool -> UnionCaseInfo []
static member FSharpType.GetUnionCases : unionType:Type * ?bindingFlags:BindingFlags -> UnionCaseInfo []

module Seq

from Microsoft.FSharp.Collections

val map : mapping:('T -> 'U) -> source:seq<'T> -> seq<'U>

Full name: Microsoft.FSharp.Collections.Seq.map

val u : UnionCaseInfo

property UnionCaseInfo.Tag: int

member UnionCaseInfo.GetFields : unit -> PropertyInfo []

type Array =
  member Clone : unit -> obj
  member CopyTo : array:Array * index:int -> unit + 1 overload
  member GetEnumerator : unit -> IEnumerator
  member GetLength : dimension:int -> int
  member GetLongLength : dimension:int -> int64
  member GetLowerBound : dimension:int -> int
  member GetUpperBound : dimension:int -> int
  member GetValue : [<ParamArray>] indices:int[] -> obj + 7 overloads
  member Initialize : unit -> unit
  member IsFixedSize : bool
  ...

Full name: System.Array

val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map

Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
  interface IEnumerable
  interface IComparable
  interface IEnumerable<KeyValuePair<'Key,'Value>>
  interface ICollection<KeyValuePair<'Key,'Value>>
  interface IDictionary<'Key,'Value>
  new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
  member Add : key:'Key * value:'Value -> Map<'Key,'Value>
  member ContainsKey : key:'Key -> bool
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>

val ofSeq : elements:seq<'Key * 'T> -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.ofSeq

val o : obj

type obj = Object

Full name: Microsoft.FSharp.Core.obj

val depths : int []

val isEmpty : source:seq<'T> -> bool

Full name: Microsoft.FSharp.Collections.Seq.isEmpty

val max : source:seq<'T> -> 'T (requires comparison)

Full name: Microsoft.FSharp.Collections.Seq.max

val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof

val x : 'T

type Peano =
| Zero
| Succ of Peano

Full name: Script.Peano

union case Peano.Zero: Peano

union case Peano.Succ: Peano -> Peano

val int2Peano : _arg1:int -> Peano

Full name: Script.int2Peano

val n : int

val d : (Peano option -> int)

Full name: Script.d

type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>

Previous Version Raw view Test code New version

More information

Link:	http://fssnip.net/gi
Posted:	11 years ago
Author:	Eirik Tsarpalis
Tags:	fixpoint combinator , memoization , denotational semantics