image processing comonad

images.fsx

[<AutoOpen>]
module Helpers =
    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
    let arraySize arr = Array2D.length1 arr, Array2D.length2 arr
    let safeGet i' j' (arr:_[,])  = try arr.[i',j'] with | ex -> Unchecked.defaultof<'a>

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

    let toArray2d (image:Bitmap) =
        let f i j = image.GetPixel(i,j) 
        let arr = Array2D.init image.Width image.Height f
        arr

    let fromArray arr =
        let w, h = arraySize arr
        let res = new Bitmap (w,h)
        Array2D.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 CArray2D =
    type Composed () = class end
    type Raw () = class end
    type CArray2D<'a,'p> = CA2 of 'a[,] * int * int
    let create arr = CA2(arr, 0, 0)
    let get i' j' (CA2(a, i, j):CArray2D<'a, Raw>)  = safeGet (i+ i') (j + j') a
    let (?) c (i':int,j':int) = get i' j' c 
    let extract c = get 0 0 c

    let extend (f: CArray2D<'a, Raw> -> 'b) (CA2(a, i, j) : CArray2D<'a, Composed>) : CArray2D<'b, Composed> = 
        let w, h = arraySize a
        let f i j =  f(CA2(a,i,j)) 
        let r = Array2D.init w h f
        CA2(r,i,j)

    let run (f: CArray2D<'a, Composed> -> CArray2D<'b, Composed>) arr = 
        let (CA2(arr,_,_)) = f (CA2(arr,0,0)) 
        arr

    let zip (CA2(a, i, j)) (CA2(b, _, _)) =
        let w, h = arraySize a
        let f i j =  (safeGet i j a, safeGet i j b)
        let r = Array2D.init w h f
        CA2(r,i,j)

module ImageProcessing =
    open CArray2D
    open System.Drawing
    open System.Drawing.Imaging
    
    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 contours x = 
        let y = extend gauss2D x
        let z = extend gauss2D y
        let yz = zip y z
        let w = extend (extract >> fun (a,b) -> a + b) yz
        extend laplace2d w

    let gaussLaplace = extend gauss2D >> extend  laplace2d

    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)

open ImageProcessing
open CArray2D

let applyTransform (ipath, f, fname) =
    Bitmap.load ipath 
    |> Bitmap.toArray2d 
    |> Array2D.map toGrayScale
    |> run f
    |> Array2D.map fromGrayScale
    |> Bitmap.fromArray
    |> Bitmap.save (sprintf "%s.out.%s.%s" ipath fname (ipath.Split('.').[1])) 

let tests = [extend extract, "id";
             extend gauss2D, "gauss2D";
             extend 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) applyTransform (file, testf, fname)