WhatGoesHere.fs

/// See http://stackoverflow.com/questions/11800168/how-to-implement-the-list-filter-function-in-f-using-primitives

#if INTERACTIVE
#else
module WhatGoesHere
#endif

[<Sealed>]
type Id() = class end

module LC =


    type term =
        | App of term * term
        | Fun of Id * term
        | Var of Id

        static member ( * ) (a, b) = App (a, b)

    let fn f =
        let v = Id ()
        Fun (v, f (Var v))

module SKI =
    open System.IO

    type term =
        | A of term * term
        | I
        | K
        | S

        member this.Write(col: ref<int>, w: TextWriter) =
            match this with
            | A (x, y) ->
                w.Write('`')
                x.Write(col, w)
                y.Write(col, w)
            | I -> w.Write('i')
            | K -> w.Write('k')
            | S -> w.Write('s')
            incr col
            if !col >= 40 then
                w.WriteLine()
                col := 0

        override this.ToString() =
            use w = new StringWriter()
            this.Write(ref 0, w)
            w.ToString()

module Compiler =

    type t =
        | A of t * t
        | F of Id * t
        | I
        | K
        | S
        | V of Id

        static member ( * ) (a, b) = A (a, b)

    let rec fromLC t =
        match t with
        | LC.App (f, x) -> A (fromLC f, fromLC x)
        | LC.Fun (v, x) -> F (v, fromLC x)
        | LC.Var v -> V v

    let rec toSKI t =
        match t with
        | A (f, x) -> SKI.A (toSKI f, toSKI x)
        | I -> SKI.I
        | K -> SKI.K
        | S -> SKI.S
        | _ -> invalidArg "t" "Not in SKI-form"

    let rec contains v t =
        match t with
        | A (a, b) -> contains v a || contains v b
        | F (id, t) when id = v -> false
        | F (_, t) -> contains v t
        | V id -> id = v
        | _ -> false

    let rec convert t =
        match t with
        | A (a, b) -> A (convert a, convert b)
        | F (v, b) -> close v (convert b)
        | _ -> t

    and close v t =
        if contains v t then
            match t with
            | A (a, b) -> S * convert (F (v, a)) * convert (F (v, b))
            | F _ -> invalidArg "t" "Not a compiled term"
            | V x when x = v -> I
            | t -> K * t
        else
            K * t

    let compile t =
        toSKI (convert (fromLC t))

module Futile =
    open LC

    let fn2 f = fn (fun x -> fn (fun y -> f x y))
    let fn3 f = fn (fun x -> fn2 (fun y z -> f x y z))
    let fn4 f = fn (fun a -> fn3 (fun b c d -> f a b c d))

    let nil = fn2 (fun cons nil -> nil)

    let cons =
        fn4 <| fun head tail cons nil ->
            cons * head * (tail * cons * nil)

    let true_ = fn2 <| fun x y -> x
    let false_ = fn2 <| fun x y -> y

    let if_ = fn3 <| fun ok y n -> ok * y * n

    let wgh = fn3 <| fun f x xs ->
        if_ * (f * x) * (cons * x * xs) * xs

    let foldBack = fn3 <| fun cons list nil ->
        list * cons * nil

    let filter = fn2 <| fun f list ->
        foldBack * wgh * list * nil

#if INTERACTIVE

printfn "whatGoesHere = "

Futile.wgh
|> Compiler.compile
|> printfn "%O"

printfn "List.filter = "

Futile.filter
|> Compiler.compile
|> printfn "%O"

#endif