Commit 27a03fb8 authored by Josh Kunz's avatar Josh Kunz

Graph updates now working.

parent a89ba52d
...@@ -16,47 +16,68 @@ type fact = {head: string; rel: string; tail: string};; ...@@ -16,47 +16,68 @@ type fact = {head: string; rel: string; tail: string};;
(* Yields a new empty graph *) (* Yields a new empty graph *)
let empty () = Graph.create 1;; let empty () = Graph.create 1;;
(* Yields a new list that contains all edges in 'l' except 'e' *)
let rec remove_edge l e =
match l with
| [] -> []
| _e :: l when _e.out = e.out && _e.label = e.label -> l
| _e :: l -> _e :: remove_edge l e;;
(* Yields a new list that contains all edges in 'l' plus 'e' *)
let rec update_edge l e =
match l with
| [] -> [e]
| _e :: l when _e.out = e.out && _e.label = e.label -> _e :: l
| _e :: l -> _e :: update_edge l e;;
(* Yields a list of all facts 'f' such that there is an edge n -> f. Yields
* an empty list if there are no such facts. *)
let facts_off g n =
if Graph.mem g n then
Graph.find g n |>
List.map (fun e -> {head = n; rel = e.label; tail = e.out})
else [];;
(* Yields a list of all facts in the graph. *)
let all_facts g : fact list =
let aggregator k v a =
(List.map (fun e -> {head=k; rel=e.label; tail=e.out}) v) @ a in
Graph.fold aggregator g [];;
(** Add a fact to the given knowledge graph. *) (** Add a fact to the given knowledge graph. *)
let madd_fact g f = let madd_fact g f =
let e = {out = f.tail; label = f.rel} in let e = {out = f.tail; label = f.rel} in
if Graph.mem g f.head then if Graph.mem g f.head then
e :: (Graph.find g f.head) |> Graph.replace g f.head (update_edge (Graph.find g f.head) e) |> Graph.replace g f.head
else else
Graph.replace g f.head [e];; Graph.replace g f.head [e];;
(** Remove the first fact that matches 'f' from the given graph. This function (** Remove the first fact that matches 'f' from the given graph. This function
* has no effect if f is not in g. *) * has no effect if f is not in g. *)
let mremove_fact g f = let mremove_fact g f =
let rec mremove_edge l e =
match l with
| [] -> []
| {out = o; label = la} :: l when o = e.out && la = e.label -> l
| _e :: l -> _e :: mremove_edge l e
in
let e = {out = f.tail; label = f.rel} in let e = {out = f.tail; label = f.rel} in
try try
(Graph.find g f.head |> mremove_edge) e |> Graph.replace g f.head (Graph.find g f.head |> remove_edge) e |> Graph.replace g f.head
with Not_found -> ();; with Not_found -> ();;
(* Non-mutating versions of add_fact and remove_fact *) (* Modify the graph on the left hand side to reflect all edges that are
* in the graph on the right hand side *)
let mjoin_graph_left g1 g2 =
all_facts g2 |> List.iter (fun f -> madd_fact g1 f);;
(* Returns a new graph that contains all facts in 'g' plus the new fact 'f' *)
let add_fact g f = let add_fact g f =
let ng = (Graph.copy g) in let ng = Graph.copy g in
madd_fact ng f; ng;; madd_fact ng f; ng;;
(* Returns a new graph that contains all facts in 'g' except 'f' *)
let remove_fact g f = let remove_fact g f =
let ng = (Graph.copy g) in let ng = Graph.copy g in
mremove_fact ng f; ng;; mremove_fact ng f; ng;;
(* Yields a list of all facts 'f' such that there is an edge n -> f. Yields (* Returns a new graph that contains the union of graph g1 and g2 *)
* an empty list if there are no such facts. *) let join_graph g1 g2 =
let facts_off g n = let ng = Graph.copy g1 in
if Graph.mem g n then mjoin_graph_left ng g1;
Graph.find g n |> mjoin_graph_left ng g2;
List.map (fun e -> {head = n; rel = e.label; tail = e.out}) ng;;
else [];;
(* Yields a list of all facts in the graph. *)
let all_facts g : fact list =
let aggregator k v a =
(List.map (fun e -> {head=k; rel=e.label; tail=e.out}) v) @ a in
Graph.fold aggregator g [];;
...@@ -108,6 +108,17 @@ let terminate (ic, oc) = ...@@ -108,6 +108,17 @@ let terminate (ic, oc) =
close_in_noerr ic; close_in_noerr ic;
close_out_noerr oc;; close_out_noerr oc;;
(* Run the function 'f' over the data-structure 'a' under the lock 'l'.
* It ensures that the code is always run under with a locked data-structure
* and that the structure is always unlocked after the function exits. *)
let sync f l a =
Mutex.lock l;
try
let out = f a in
Mutex.unlock l; out;
with
| x -> Mutex.unlock l; raise x;;
let handle_client (ic, oc, addr) = let handle_client (ic, oc, addr) =
let open Request in let open Request in
let handle_request request = let handle_request request =
...@@ -115,15 +126,12 @@ let handle_client (ic, oc, addr) = ...@@ -115,15 +126,12 @@ let handle_client (ic, oc, addr) =
| "/graph" -> | "/graph" ->
begin match request.meth with begin match request.meth with
| "GET" -> | "GET" ->
lock g; sync (fun _ -> json_for_graph !graph) g ()
let json = json_for_graph !graph in |> Response.make 200;
unlock g; Response.make 200 json;
| "POST" -> | "POST" ->
begin try graph_for_json request.body
let graph = graph_for_json request.body in |> sync (fun ug -> mjoin_graph_left !graph ug) g;
Response.make 200 ""; Response.make 200 "";
with Failure x -> Response.make 500 x;
end
| _ -> Response.make 405 "" | _ -> Response.make 405 ""
end; end;
| "/query" -> Response.make 200 "Query."; | "/query" -> Response.make 200 "Query.";
...@@ -150,8 +158,4 @@ let main port = ...@@ -150,8 +158,4 @@ let main port =
accept_loop () in accept_loop () in
accept_loop ();; accept_loop ();;
KG.madd_fact !graph {head="a"; rel="b"; tail="c"};;
KG.madd_fact !graph {head="c"; rel="b"; tail="a"};;
KG.madd_fact !graph {head="a"; rel="z"; tail="t"};;
main 8080;; main 8080;;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment