DirectShowCapture.fs

module LangExplrExperiments.DirectShowCapture

open DirectShowLib
open System.Runtime.InteropServices
open System.Runtime.InteropServices.ComTypes


let private checkResult hresult = DsError.ThrowExceptionForHR( hresult )

let findCaptureDevice = 
   let devices = DsDevice.GetDevicesOfCat(FilterCategory.VideoInputDevice)
   let source : obj ref = ref null
   devices.[0].Mon.BindToObject(null,null,ref typeof<IBaseFilter>.GUID,source)
   devices.[0]

  
let private ConfigureSampleGrabber( sampGrabber:ISampleGrabber,callbackobject:ISampleGrabberCB) =
    let media = new AMMediaType()
        
    media.majorType <- MediaType.Video
    //media.subType <- MediaSubType.RGB24
    media.subType <- MediaSubType.RGB24
    media.formatType <- FormatType.VideoInfo
    
    sampGrabber.SetMediaType( media ) |> checkResult    
    DsUtils.FreeAMMediaType(media);
            
    sampGrabber.SetCallback( callbackobject, 1 ) |> checkResult
    

let getCaptureResolution(capGraph:ICaptureGraphBuilder2 , capFilter:IBaseFilter) =        
    let o : obj ref = ref null
    let media : AMMediaType ref = ref null            
    let videoControl = capFilter :?> IAMVideoControl

    capGraph.FindInterface(new DsGuid( PinCategory.Capture), 
                           new DsGuid( MediaType.Video), 
                           capFilter, 
                           typeof<IAMStreamConfig>.GUID, 
                           o ) |> checkResult    
                           
    let videoStreamConfig = o.Value :?> IAMStreamConfig;
                
    videoStreamConfig.GetFormat(media) |> checkResult    
        
    let v  = new VideoInfoHeader()
    Marshal.PtrToStructure( media.Value.formatPtr, v )
    DsUtils.FreeAMMediaType(media.Value)
    
    v.BmiHeader.Width,v.BmiHeader.Height

let createCaptureFilter (captureDevice:DsDevice) 
                        (sampleGrabberCBCreator: int*int -> ISampleGrabberCB) = 
   let captureGraphBuilder =  box(new CaptureGraphBuilder2()) :?> ICaptureGraphBuilder2
   let sampGrabber = box(new SampleGrabber()) :?> ISampleGrabber;
   let filterGraph = box(new FilterGraph()) :?> IFilterGraph2   
   let capFilter: IBaseFilter ref = ref null
   
   captureGraphBuilder.SetFiltergraph(filterGraph) |> checkResult   
   
   filterGraph.AddSourceFilterForMoniker(
                      captureDevice.Mon,
                      null,
                      captureDevice.Name,
                      capFilter) |> checkResult
                      
   
   let resolution = getCaptureResolution(captureGraphBuilder,capFilter.Value)   
   ConfigureSampleGrabber(sampGrabber, sampleGrabberCBCreator(resolution) )
   
   filterGraph.AddFilter(box(sampGrabber) :?> IBaseFilter , "FSGrabberFilter") |> checkResult
                 
           
   captureGraphBuilder,filterGraph,sampGrabber,capFilter.Value
   
let getMediaControl (captureGraphBuilder :ICaptureGraphBuilder2)
                    (sampGrabber: ISampleGrabber)
                    (capFilter:IBaseFilter)
                    (filterGraph:IFilterGraph2)
                    (fileNameOpt:string option)=
  let muxFilter: IBaseFilter ref = ref null
  let fileWriterFilter : IFileSinkFilter ref = ref null
  try        
      match fileNameOpt with
        | Some filename ->            
            captureGraphBuilder.SetOutputFileName(
                                                    MediaSubType.Avi, 
                                                    filename,                          
                                                    muxFilter,  
                                                    fileWriterFilter) |> checkResult
            
        | None -> ()
        
      captureGraphBuilder.RenderStream(
                                        new DsGuid( PinCategory.Capture),
                                        new DsGuid( MediaType.Video),
                                        capFilter,
                                        sampGrabber :?> IBaseFilter,
                                        muxFilter.Value) |> checkResult
      
  finally
      if fileWriterFilter.Value <> null then
         Marshal.ReleaseComObject(fileWriterFilter.Value) |> ignore
      if muxFilter.Value <> null then
         Marshal.ReleaseComObject(muxFilter.Value) |> ignore     
         
  filterGraph :?>  IMediaControl  
  

let createVideoCaptureWithSampleGrabber (device:DsDevice) 
                                        (sampleGrabberCBCreator: int*int -> ISampleGrabberCB) 
                                        (outputFileName: string option) =
   let capGraphBuilder,filterGraph,sampGrabber,capFilter = createCaptureFilter device sampleGrabberCBCreator
   
   let mediaControl = getMediaControl capGraphBuilder sampGrabber capFilter filterGraph outputFileName
   
   Marshal.ReleaseComObject capGraphBuilder |> ignore
   Marshal.ReleaseComObject capFilter |> ignore
   Marshal.ReleaseComObject sampGrabber |> ignore
   
   mediaControl,filterGraph
  
   
let configureVideoWindow windowHandle width height (filterGraph:IFilterGraph2) =
   let videoWindow  = filterGraph :?> IVideoWindow

   videoWindow.put_Owner(windowHandle) |> checkResult   
   videoWindow.put_WindowStyle(WindowStyle.Child ||| WindowStyle.ClipChildren) |> checkResult   
   videoWindow.SetWindowPosition(0,0,width,height) |> checkResult   
   videoWindow.put_Visible(OABool.True)|> checkResult
   
   videoWindow
   

imageproc.fs

module LangexplrExperiments.ImageProc

open System
open System.Runtime.InteropServices


let inline getArray (data:IntPtr) (size:int)  = 
   let array : byte[] = Array.create size (byte(0))
   Marshal.Copy(data,array,0,size) |> ignore
   array
   
let inline getGrayImage (data:IntPtr) (size:int)  = 
    let grayImage = Array.create (size/3) (byte(0))
    let pixelBuffer = Array.create 3 (byte(0))
    let mutable it = 0
    for i in 0..(size - 3 ) do 
       if (i + 1) % 3 = 0 then 
          Marshal.Copy(new System.IntPtr(data.ToInt32()+i),pixelBuffer,0,3) |> ignore
          grayImage.[it] <-  byte(float(pixelBuffer.[0])*0.3 + 
                                  float(pixelBuffer.[1])*0.59 + 
                                  float(pixelBuffer.[2])*0.11)
          it <- it+1
    grayImage

let inline saveGrayImageToRGBBuffer (grayImage:byte array) (data:IntPtr) (size:int) =
    let mutable targetIndex = 0
    for i in 0..(size/3 - 1) do
      let p = grayImage.[i]
      Marshal.WriteByte(data,targetIndex,p)
      Marshal.WriteByte(data,targetIndex+1,p)
      Marshal.WriteByte(data,targetIndex+2,p)
      targetIndex <- targetIndex+3  
    ()
   
let inline getPixelRGB width height (image:byte array) x y  =
   let baseHeightOffset = y*width*3
   let offset = baseHeightOffset + x*3
   image.[offset],image.[offset+1],image.[offset+2]

let inline setPixelRGB width height (image:byte array) x y  (value1,value2,value3) =
   let baseHeightOffset = y*width*3
   let offset = baseHeightOffset + x*3
   image.[offset] <- value1
   image.[offset+1] <- value2
   image.[offset+2] <- value3
   ()
   
let convolveRGB w h (image:byte array) (template:float[,]) =
   let hhalf = Array2D.length1 template / 2
   let whalf = Array2D.length2 template / 2
   
   let result = Array.create (image.Length) (byte(0))
   
   let getPixelRGB' = getPixelRGB w h image
   let setPixelRGB' = setPixelRGB w h result
   
   (seq { for y in (hhalf + 1) .. (h - hhalf - 1 ) do
          for x in (whalf + 1) .. (w - whalf - 1 ) do
             yield (x,y) })
      |> Seq.iter (fun (x,y) -> let r,g,b = getPixelRGB' x y
                                let tr,tg,tb =
                                    (seq { for ty in 0 .. (Array2D.length1 template - 1) do
                                           for tx in 0 .. (Array2D.length2 template - 1) do
                                             let ir,ig,ib = getPixelRGB' ( x + (tx - whalf))
                                                                         ( y + (ty - hhalf))
                                             yield template.[tx ,ty ]*float(ir), 
                                                    template.[tx ,ty ]*float(ig),
                                                    template.[tx ,ty ]*float(ib)
                                           } |> Seq.fold (fun (sr,sg,sb) (cr,cg,cb) -> sr+cr,sg+cg,sb+cb) (0.0,0.0,0.0) )
                                setPixelRGB' x y (byte(tr),byte(tg),byte(tb))
                                )
      
   result
            
        
let prepareConvolveFunction  (template:float[,]) =
   let hhalf = Array2D.length1 template / 2
   let whalf = Array2D.length2 template / 2
   let m =
       ([  for ty in 0 .. (Array2D.length1 template - 1) do
           for tx in 0 .. (Array2D.length2 template - 1) do
                yield
                  if (template.[tx ,ty ] <> 0.0) then
                     Some (fun x y w h image result -> 
                             let ir,ig,ib = getPixelRGB w h image ( x + (tx - whalf))
                                                                  ( y + (ty - hhalf))
                             template.[tx ,ty ]*float(ir), 
                                    template.[tx ,ty ]*float(ig),
                                    template.[tx ,ty ]*float(ib)) 
                  else None]
             ) |> Seq.filter (Option.isSome) |> Seq.map (fun (Some x) -> x)
   (fun x y w h image result -> 
         Seq.fold (fun (sr,sg,sb) f ->
                     let cr,cg,cb = (f x y w h image result)
                     sr+cr,sg+cg,sb+cb) (0.0,0.0,0.0) m)
         
         
   
let convolveRGB2 w h (image:byte array) (templateFunction) (template:float[,]) =
   let hhalf = Array2D.length1 template / 2
   let whalf = Array2D.length2 template / 2
   
   let result = Array.create (image.Length) (byte(0))
   
   let getPixelRGB' = getPixelRGB w h image
   let setPixelRGB' = setPixelRGB w h result
   
   (seq { for y in (hhalf + 1) .. (h - hhalf - 1 ) do
          for x in (whalf + 1) .. (w - whalf - 1 ) do
             yield (x,y) })
      |> Seq.iter (fun (x,y) -> let r,g,b = getPixelRGB' x y
                                let (tr:float),(tg:float),(tb:float) =
                                    (templateFunction x y w h image result)
                                setPixelRGB' x y (byte(tr),byte(tg),byte(tb))
                                )
      
   result

   
   
let convolveRGB3 w h (image:byte array) (template:float[,]) hhalf whalf =
   //let hhalf = Array2D.length1 template / 2
   //let whalf = Array2D.length2 template / 2
   
   let result = Array.create (image.Length) (byte(0))
   
   let getPixelRGB' = getPixelRGB w h image
   let setPixelRGB' = setPixelRGB w h result
   
   for y in (hhalf + 1) .. (h - ((Array2D.length1 template) - hhalf - 1) - 1 ) do
       for x in (whalf + 1) .. (w - ((Array2D.length2 template) - whalf - 1) - 1 ) do
          let r,g,b = getPixelRGB' x y
          let mutable rr = 0.0
          let mutable rg = 0.0
          let mutable rb = 0.0
          for ty in 0 .. (Array2D.length1 template - 1) do
          for tx in 0 .. (Array2D.length2 template - 1) do
             let ir,ig,ib = getPixelRGB' ( x + (tx - whalf)) ( y + (ty - hhalf))
             rr <- rr + template.[tx ,ty ]*float(ir)
             rg <- rg + template.[tx ,ty ]*float(ig)
             rb <- rb + template.[tx ,ty ]*float(ib)
          setPixelRGB' x y (byte(rr),byte(rg),byte(rb))
      
   result
   
let inline getPixelGray width height (image:byte array) x y  =
   let baseHeightOffset = y*width
   let offset = baseHeightOffset + x
   image.[offset]

let inline setPixelGray width height (image:byte array) x y value1 =
   let baseHeightOffset = y*width
   let offset = baseHeightOffset + x
   image.[offset] <- value1  
   ()
   
   
let histogramNormalization (image:byte array) =
  let max = Array.max image
  let min = Array.min image
  let range = float(max - min)
  Array.map (fun p -> byte(float(p - min)*255.0/range)) image
  
let convolveGray3 w h (image:byte array) (template:float[,]) hhalf whalf =
   //let hhalf = Array2D.length1 template / 2
   //let whalf = Array2D.length2 template / 2         
      
   let result = Array.create (image.Length) (byte(0))
   
   let getPixelGray' = getPixelGray w h image
   let setPixelGray' = setPixelGray w h result
   
   for y in (hhalf + 1) .. (h - ((Array2D.length1 template) - hhalf - 1) - 1 ) do
       for x in (whalf + 1) .. (w - ((Array2D.length2 template) - whalf - 1) - 1 ) do
          
          let mutable r = 0.0
          
          for ty in 0 .. (Array2D.length1 template - 1) do
          for tx in 0 .. (Array2D.length2 template - 1) do
             let ir = getPixelGray' ( x + (tx - whalf)) ( y + (ty - hhalf))
             r <- r + template.[ty ,tx ]*float(ir)  
             
          setPixelGray' x y (byte(Math.Abs r))
      
   //histogramNormalization result
   result
   
   
   

program.fs

open System.Windows.Forms
open System.Drawing
open DirectShowLib
open System.Runtime.InteropServices
open System.Runtime.InteropServices.ComTypes
open LangExplrExperiments.DirectShowCapture
open LangexplrExperiments.ImageProc


type MyFG(width:int,height:int) = 
  let mutable ct = 0
  interface ISampleGrabberCB with        
        member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 
           0        
//        member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =
//           ct <- ct + 1
//           let inc = if ct > 50 then
//                         ct <- 0
//                         5000
//                     else 15000
//           for i = 1 to 1000 do
//              Marshal.WriteByte(pBuffer,inc+i ,byte(0x77))
//           0

        member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =           
           for i = 0 to (288-1) do
              let x = i
              let y = i
              let value = byte(0xff)
              let offset = y*(3*width) + (x*3)              
              Marshal.WriteByte(pBuffer,offset,value)           
           0
           
//        member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =
//           ct <- ct + 1
//           let inc = if ct > 50 then
//                         ct <- 0
//                         5000
//                     else 15000
//           for i = 0 to (bufferLen - 1) do
//              Marshal.WriteByte(pBuffer,i ,Marshal.ReadByte(pBuffer,i)+byte(100))
//           0


//Application.Run(new MyForm()) 

let incrementGrabber = 
     fun (width,height) ->
      {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                for i = 0 to (bufferLen - 1) do
                   let c = Marshal.ReadByte(pBuffer,i)
                   Marshal.WriteByte(pBuffer,i ,if c > byte(150) then byte(255) else c+byte(100))
                0 }

let averagingTemplate (windowSize) =
  Array2D.create windowSize windowSize (1.0/float(windowSize*windowSize))
                
//let template = 
//             (array2D [|[|1.0;0.0;-1.0|];
//                      [|1.0;0.0;-1.0|];
//                      [|1.0;0.0;-1.0|];|])   
                      
let firstOrderEdgeDetectTemplate = 
             (array2D [|[|2.0;-1.0|];
                        [|-1.0;0.0|];|])   
                      
let convGrabber = 
     fun (width,height) ->
      {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                let a = getArray pBuffer bufferLen 
                let r = convolveRGB width height a firstOrderEdgeDetectTemplate
                Marshal.Copy(r,0,pBuffer,bufferLen) 
                0
                }

let convFunc = prepareConvolveFunction firstOrderEdgeDetectTemplate
                
let convGrabber2 = 
     fun (width,height) ->
      {  new ISampleGrabberCB with                                      
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                let a = getArray pBuffer bufferLen 
                let r = convolveRGB2 width height a convFunc firstOrderEdgeDetectTemplate
                Marshal.Copy(r,0,pBuffer,bufferLen) 
                0
               
                }
                


let convGrabber3 template = 
     fun (width,height) ->
      {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                let a = getArray pBuffer bufferLen 
                let r = convolveRGB3 width height a firstOrderEdgeDetectTemplate 0 0
                Marshal.Copy(r,0,pBuffer,bufferLen) 
                0
                }
                
let grayGrabber(transform) = 
     fun (width,height) ->
      {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                let grayImage = getGrayImage pBuffer bufferLen
                                
                let resultImage = transform width height grayImage
                
                saveGrayImageToRGBBuffer resultImage  pBuffer bufferLen                                                                   
                0
                }
                
let convGrayGrabber1 = 
    grayGrabber (fun width height grayImage -> convolveGray3 width height grayImage firstOrderEdgeDetectTemplate 0 0 )
      
let nullGrayGrabber = grayGrabber (fun (_:int) (_:int) image -> image)

let averagingGrayGrabber = 
    let template = averagingTemplate 3
    grayGrabber (fun width height grayImage -> convolveGray3 width height grayImage template 1 1 )
  

let drawLineGrabber =
    fun (width,height) ->
          {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) =                       
                for i = 0 to (288-1) do
                  let x = i
                  let y = i
                  let value = byte(0xff)
                  let offset = y*(3*width) + (x*3)              
                  Marshal.WriteByte(pBuffer,offset,value)           
                0 }
                
let nullGrabber =
    fun (width,height) ->
          {  new ISampleGrabberCB with
             member this.SampleCB(sampleTime:double , pSample:IMediaSample )= 0                     
             member this.BufferCB(sampleTime:double , pBuffer:System.IntPtr , bufferLen:int) = 0 
          }

let device = findCaptureDevice

let mediaControl,filterGraph = createVideoCaptureWithSampleGrabber 
                                      device 
                                      averagingGrayGrabber //(fun (w,h) -> new MyFG(w,h) :> ISampleGrabberCB)
                                      None



let form = new Form(Size = new Size(300,300), Visible = true,Text = "Webcam input")


let videoWindow = configureVideoWindow (form.Handle) 300 300 filterGraph

form.Closing.Add (fun _ -> 
                      mediaControl.StopWhenReady() 
                      Marshal.ReleaseComObject(videoWindow) |> ignore
                      Marshal.ReleaseComObject(mediaControl) |> ignore
                      Marshal.ReleaseComObject(filterGraph) |> ignore)
                      

mediaControl.Run() |> ignore

Application.Run(form)