add: msbfs parents

Author: artemiipatov

src/GraphBLAS-sharp.Backend/Algorithms/MSBFS.fs

@@ -3,6 +3,7 @@ namespace GraphBLAS.FSharp.Backend.Algorithms
 open Brahma.FSharp
 open FSharp.Quotations
 open GraphBLAS.FSharp
+open GraphBLAS.FSharp.Backend.Quotes
 open GraphBLAS.FSharp.Objects
 open GraphBLAS.FSharp.Objects.ClMatrix
 open GraphBLAS.FSharp.Objects.ArraysExtensions
@@ -11,35 +12,35 @@ open GraphBLAS.FSharp.Backend.Matrix.LIL
 open GraphBLAS.FSharp.Backend.Matrix.COO
 
 module internal MSBFS =
-    module Levels =
-        let private updateFront (clContext: ClContext) workGroupSize =
+    let private frontExclude (clContext: ClContext) workGroupSize =
 
-            let excludeValues = ClArray.excludeElements clContext workGroupSize
+        let excludeValues = ClArray.excludeElements clContext workGroupSize
 
-            let excludeIndices = ClArray.excludeElements clContext workGroupSize
+        let excludeIndices = ClArray.excludeElements clContext workGroupSize
 
-            fun (queue: MailboxProcessor<_>) allocationMode (front: ClMatrix.COO<_>) (intersection: ClArray<int>) ->
+        fun (queue: MailboxProcessor<_>) allocationMode (front: ClMatrix.COO<_>) (intersection: ClArray<int>) ->
 
-                let newRows = excludeIndices queue allocationMode intersection front.Rows
+            let newRows = excludeIndices queue allocationMode intersection front.Rows
 
-                let newColumns = excludeIndices queue allocationMode intersection front.Columns
+            let newColumns = excludeIndices queue allocationMode intersection front.Columns
 
-                let newValues = excludeValues queue allocationMode intersection front.Values
+            let newValues = excludeValues queue allocationMode intersection front.Values
 
-                match newRows, newColumns, newValues with
-                | Some rows, Some columns, Some values ->
-                    { Context = clContext
-                      Rows = rows
-                      Columns = columns
-                      Values = values
-                      RowCount = front.RowCount
-                      ColumnCount = front.ColumnCount }
-                    |> Some
-                | _ -> None
+            match newRows, newColumns, newValues with
+            | Some rows, Some columns, Some values ->
+                { Context = clContext
+                  Rows = rows
+                  Columns = columns
+                  Values = values
+                  RowCount = front.RowCount
+                  ColumnCount = front.ColumnCount }
+                |> Some
+            | _ -> None
 
+    module Levels =
         let private updateFrontAndLevels (clContext: ClContext) workGroupSize =
 
-            let updateFront = updateFront clContext workGroupSize
+            let updateFront = frontExclude clContext workGroupSize
 
             let mergeDisjoint = Matrix.mergeDisjoint clContext workGroupSize
 
@@ -130,4 +131,78 @@ module internal MSBFS =
                 |> List.map (SSBFS queue matrix)
 
     module Parents =
-        let run = 0
+        let updateFrontAndParents (clContext: ClContext) workGroupSize =
+            // update parents same as levels
+            // every front value should be equal to its column number
+            let frontExclude = frontExclude clContext workGroupSize
+
+            let mergeDisjoint = Matrix.mergeDisjoint clContext workGroupSize
+
+            let findIntersection = Intersect.findKeysIntersection clContext workGroupSize
+
+            fun (queue: MailboxProcessor<Msg>) allocationMode (front: ClMatrix.COO<_>) (parents: ClMatrix.COO<_>) ->
+
+                // Find intersection of levels and front indices.
+                let intersection = findIntersection queue DeviceOnly front parents
+
+                // Remove mutual elements
+                let newFront = frontExclude queue allocationMode front intersection
+
+                intersection.Free queue
+
+                match newFront with
+                | Some f ->
+                    // Update levels
+                    let resultFront =
+                        { f with Values = f.Columns }
+                    let newLevels = mergeDisjoint queue parents f
+                    newLevels, Some resultFront
+                | _ -> parents, None
+
+        let run<'a when 'a: struct>
+            (clContext: ClContext)
+            workGroupSize
+            =
+
+            let spGeMM =
+                Operations.SpGeMM.COO.expand (ArithmeticOperations.min 0) (ArithmeticOperations.fst 0) clContext workGroupSize
+
+            let updateFrontAndLevels = updateFrontAndParents clContext workGroupSize
+
+            fun (queue: MailboxProcessor<Msg>) (matrix: ClMatrix<'a>) (source: int list) ->
+                let vertexCount = matrix.RowCount
+                let sourceVertexCount = source.Length
+
+                let mutable parents =
+                    source
+                    |> List.mapi (fun i vertex -> i, vertex, 0)
+                    |> Matrix.ofList clContext DeviceOnly sourceVertexCount vertexCount
+
+                let mutable front =
+                    source
+                    |> List.mapi (fun i vertex -> i, vertex, vertex)
+                    |> Matrix.ofList clContext DeviceOnly sourceVertexCount vertexCount
+
+                let mutable stop = false
+
+                while not stop do
+
+                    //Getting new frontier
+                    match spGeMM queue DeviceOnly (ClMatrix.COO front) matrix with
+                    | None ->
+                        front.Dispose queue
+                        stop <- true
+                    | Some newFrontier ->
+                        front.Dispose queue
+                        //Filtering visited vertices
+                        match updateFrontAndLevels queue DeviceOnly newFrontier parents with
+                        | l, Some f ->
+                            front <- f
+                            parents.Dispose queue
+                            parents <- l
+                            newFrontier.Dispose queue
+                        | _, None ->
+                            stop <- true
+                            newFrontier.Dispose queue
+
+                parents

src/GraphBLAS-sharp.Backend/Algorithms/SSSP.fs

@@ -11,7 +11,7 @@ module internal SSSP =
     let run (clContext: ClContext) workGroupSize =
 
         let less = ArithmeticOperations.less<int>
-        let min = ArithmeticOperations.min<int>
+        let min = ArithmeticOperations.minOption<int>
         let plus = ArithmeticOperations.intSumAsMul
 
         let spMVInPlace =

src/GraphBLAS-sharp.Backend/Quotes/Arithmetic.fs

@@ -240,14 +240,23 @@ module ArithmeticOperations =
             | Some x, None -> Some 1
             | _ -> None @>
 
-    let min<'a when 'a: comparison> =
+    let minOption<'a when 'a: comparison> =
         <@ fun (x: 'a option) (y: 'a option) ->
             match x, y with
             | Some x, Some y -> Some(min x y)
             | Some x, None -> Some x
             | None, Some y -> Some y
             | _ -> None @>
 
+    let min zero =
+        <@ fun x y ->
+            let result = min x y
+            if result = zero then None else Some result @>
+
+    let fst zero =
+        <@ fun x _ ->
+            if x = zero then None else Some x @>
+
     //PageRank specific
     let squareOfDifference =
         <@ fun (x: float32 option) (y: float32 option) ->