Yet Another Semantic Network

I know I keep complaining about being tired of building semantic networks in F#, but here’s another one. This one, I hope, is the most F#-like yet. I even managed to use a computation expression! Next up, I’ll add better search capabilities.

As always, no warranties or implied fitness; use at your own risk. Formatted for blog width.

Code:

module SemanticNet

open System.Collections.Generic


// I'm a fool for syntactic sugar.
type internal Rel       = string*string*string
type internal RelHash   = HashSet<Rel>
type internal RelDict   = Dictionary<string,RelHash>
type internal FinderVal = bool*(RelHash option)


// Holds the relationships.
type Graph () =

  // Holds all the relationships.
  let relHash = new RelHash()

  // Maps a node in each position 
  // to the relationships for that node.
  let n0ToRelHash = new RelDict()
  let n1ToRelHash = new RelDict()
  let n2ToRelHash = new RelDict()

  // Computation expression builder for finds.
  let relFinder = RelFinder()
  
  // Internal function for finds.
  let relFinderComp (d:RelDict) 
                    (so:string option) 
                    (bhi:FinderVal) =
    match so with 
    | None -> bhi
    | Some(s) ->
        match d.TryGetValue s with
        | (true,h) -> 
            match bhi with 
            // Copy the first hash found.
            | (true,None) -> (true,Some(RelHash(h)))
            | (true,Some(hi)) ->
                hi.IntersectWith(h)
                (true,Some(hi))
            | _ -> failwith "Internal program error."
        | _ -> (false,None)

//  // For a slightly more efficient first call, 
//  // this can be used.
//      
//  let relFinderCompFst (d:RelDict) 
//                       (so:string option) =
//    match so with 
//    | None -> (true,None)
//    | Some(s) ->
//        match d.TryGetValue s with
//        | (true,h) -> (true,Some(RelHash(h)))
//        | _ -> (false,None)
  
  // Add a relationship to a dictionary. 
  let tryAddRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        h.Add r |> ignore
    | _ -> 
        let h = new RelHash()
        h.Add r |> ignore
        d.Add(k,h)
  
  // Remove a relationship from a dictionary. 
  let tryRemoveRel (d:RelDict) k r =
    match d.TryGetValue k with
    | (true,h) -> 
        let rmv = h.Remove r 
        // Clean up empty hash tables.
        if (h.Count=0) then d.Remove k |> ignore
        rmv
    | _ -> false
  
  // Add a relationship.
  member this.Add r =
    match relHash.Add r with
    | false -> r
    | _ -> 
        let (s0,s1,s2) = r
        tryAddRel n0ToRelHash s0 r 
        tryAddRel n1ToRelHash s1 r 
        tryAddRel n2ToRelHash s1 r 
        r
  
  // Add a bunch of relationships.
  member this.Add (e:IEnumerable<Rel>) =
    for r in e do
      this.Add r |> ignore
  
  // Return a hash of all relationships.      
  member this.All =  
    RelHash(relHash)
  
  // Return true if a relationship exists.      
  member this.Exists r =  
    relHash.Contains r
  
  // Return a hash option of the matched relationships.
  // Note: Uses string option; None acts as a wildcard in Find.
  member this.Find (s0,s1,s2) =
    match 
      (relFinder {
        // // See note above.
        // let! r0 = relFinderCompFst n0ToRelHash s0 
        let! r0 = relFinderComp n0ToRelHash s0 (true,None)
        let! r1 = relFinderComp n1ToRelHash s1 r0
        return    relFinderComp n2ToRelHash s2 r1 }) with
    // Three wildcards.
    | (true,None) -> Some(RelHash(relHash))
    // Something found.
    | (true,h) -> h
    // Nothing found.
    | _ -> None
  
  // Return a hash option of the matched relationships.
  // Note: Uses strings; explicit wildcard.
  member this.FindW w (s0,s1,s2) =
    this.Find (
      (if s0=w then None else Some(s0)),
      (if s1=w then None else Some(s1)),
      (if s2=w then None else Some(s2)))
  
  // Remove a relationship.
  member this.Remove r =
    match relHash.Remove r with
    | true -> 
        let (s0,s1,s2) = r
        tryRemoveRel n0ToRelHash s0 r |> ignore
        tryRemoveRel n1ToRelHash s1 r |> ignore
        tryRemoveRel n2ToRelHash s2 r |> ignore
        true 
    | _ -> false
  
  // Remove a bunch of relationships.
  member this.Remove (e:IEnumerable<Rel>) =
    for r in e do
      this.Remove r |> ignore
  
  // + operator adds a relationship, returns graph.      
  static member (+) ((g:Graph),(r:Rel)) =
    g.Add r |> ignore
    g
  
  // - operator removes a relationship, returns graph.      
  static member (-) ((g:Graph),(r:Rel)) =
    g.Remove r |> ignore
    g


// Computation expression builder for finds.
and internal RelFinder () =

  // "let!" function.
  member this.Bind (((b,h):FinderVal),
                    (f:FinderVal->FinderVal)) =
    match b with 
      | true -> f (b,h)
      | _ -> (b,h)

  // "return" function.
  member this.Return bh = bh

And test:

open SemanticNet

let g0 = Graph()

// Add some relationships.

g0 + 
  ("mammal","isA", "animal") + 
  ("dog",   "isA", "mammal") + 
  ("dog",   "isA", "pet")    + 
  ("dog",   "hasA","tag")    + 
  ("cat",   "isA", "pet")    |> ignore

// Sundry experiments.

let h0 = g0.Find(None,(Some "isA"),(Some "pet")) 
let h1 = g0.Find((Some "dog"),None,None) 

g0 - ("cat","isA","pet") |> ignore

let h2 = g0.Find(None,(Some "isA"),(Some "pet")) 

g0 + ("cat","isA","pet") |> ignore

let h3 = g0.Find(None,(Some "isA"),(Some "pet"))

let b0 = g0.Exists("cat","isA","pet")
let b1 = g0.Exists("tiger","isA","pet") 

let find = g0.FindW ""

let h4 = find("dog","","")

if h4.IsSome then g0.Remove h4.Value 

let h5 = find("dog","","")

printfn "All done!"