image processing comonad

image.fsx

[<AutoOpen>]
module Helpers =
    let memoize f =
        let dict = new System.Collections.Generic.Dictionary<_,_>()
        fun n ->
            match dict.TryGetValue(n) with
            | (true, v) -> v
            | _ ->
                let temp = f(n)
                dict.Add(n, temp)
                temp

    let memoize2 f = 
        let f = (fun (a,b) -> f a b) |> memoize
        fun a b -> f (a,b)

    let memoize3 f = 
        let f = (fun (a,b,c) -> f a b c) |> memoize
        fun a b c -> f (a,b,c)

    let time name f a =
        let stopWatch = System.Diagnostics.Stopwatch.StartNew()
        let r = f a
        stopWatch.Stop()
        printfn "%s %f" name stopWatch.Elapsed.TotalMilliseconds
        r

module LazyArray2D = 
    type LArray2D<'a> = LArray2D of (int -> int -> 'a)  * int * int
    let empty x y v = LArray2D((fun _ _ -> v), x, y)
    let get (LArray2D(f, x, y)) i j  = f i j
    let size (LArray2D(f, x, y)) = x,y
    let init x y f = LArray2D(f, x, y)
    let map f' (LArray2D(f, x, y)) = 
        let f' = fun i j -> f' (f i j)
        LArray2D(f', x, y)

    let mapi f' (LArray2D(f, x, y)) = 
        let f' = fun i j -> f' i j (f i j)
        LArray2D(f', x, y)

    let iteri f' (LArray2D(f, x, y)) = 
        for i in 0..(x-1) do
            for j in 0..(y-1) do
                f' i j (f i j)

module CArray2D =
    open LazyArray2D
    type CArray2D<'a> = CA2 of LArray2D<'a> * int * int
    let fmap f (CA2(a, i,j)) = CA2(map f a, i, j)
    let extract (CA2(a, i, j)) = get a i j
    let extend f (CA2(a, i, j)) =
        let f = fun i j _ -> f (CA2(a,i,j)) 
        let es' = mapi f a 
        in CA2(es',i,j)

    let get (CA2(a, i, j)) i' j' = 
        get a (i + i') (j + j')

#r "System.Drawing.dll"
module Bitmap =
    open CArray2D
    open System
    open System.IO
    open System.Drawing
    open System.Drawing.Imaging

    let toCarray2d (image:Bitmap) =
        let f i j = try image.GetPixel(i,j) with | ex -> Color.Black
        let arr = LazyArray2D.init image.Width image.Height f
        CA2(arr, 0, 0)

    let fromCarray (CA2(arr, _, _)) =
        let w,h = LazyArray2D.size arr
        let res = new Bitmap (w,h)
        LazyArray2D.iteri (fun i j c -> res.SetPixel(i,j,c)) arr
        res

    let load path : Bitmap = downcast Image.FromFile(path, true)
    let save path (image : Bitmap) = image.Save path

module ImageProcessing =
    open CArray2D
    open System.Drawing
    open System.Drawing.Imaging

    let (?) c (i,j) = get c i j

    let laplace2d a = 
          a ? (-1,0) 
        + a ? (0,1) 
        + a ? (0,-1) 
        + a ? (1,0) 
        - 4 * a ? (0,0)

    let gauss2D a = (a ? (-1, 0) + a ? (1, 0) + a ? (0, -1) + a ? (0, 1) + 2 * a ? (0, 0)) / 6

    let toGrayScale (c:Color) = (int(c.R) + int(c.G) + int(c.B)) / 3
    let fromGrayScale s = 
        let s = if s < 0 then 0 
                elif s > 255 then 255
                else s
        Color.FromArgb(s,s,s)

let apply (ipath, f, fname) =
    Bitmap.load ipath 
    |> Bitmap.toCarray2d 
    |> CArray2D.fmap ImageProcessing.toGrayScale
    |> CArray2D.extend f
    |> CArray2D.fmap ImageProcessing.fromGrayScale
    |> Bitmap.fromCarray
    |> Bitmap.save (sprintf "%s.out.%s.%s" ipath fname (ipath.Split('.').[1])) 


let minus x y = CArray2D.extract x - CArray2D.extract y

let contours x = 
    let y = CArray2D.extend ImageProcessing.gauss2D x
    let w = CArray2D.extend (fun y' -> let z = CArray2D.extend ImageProcessing.gauss2D y'
                                       in minus y' z) y
    ImageProcessing.laplace2d w

let gaussLaplace = CArray2D.extend ImageProcessing.gauss2D >> ImageProcessing.laplace2d

let tests = [CArray2D.extract >> id, "id";
            ImageProcessing.gauss2D, "gauss2D";
            ImageProcessing.laplace2d, "laplace2d";
            gaussLaplace, "gaussLaplace";
            contours, "contours"]

let fname = sprintf "D:\\img\\%s" 
let files = ["test.bmp";
             "laplacian1.jpg";
             "Lena.png";
             "fce2.bmp";
             "tahaa.jpg";] |> List.map fname
for file in files do
    for testf, fname in tests do
        time (sprintf "%s - %s" file fname) apply (file, testf, fname)