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};;
(* Yields a new empty graph *)
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. *)
let madd_fact g f =
let e = {out = f.tail; label = f.rel} in
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
Graph.replace g f.head [e];;
(** Remove the first fact that matches 'f' from the given graph. This function
* has no effect if f is not in g. *)
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
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 -> ();;
(* 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 ng = (Graph.copy g) in
let ng = Graph.copy g in
madd_fact ng f; ng;;
(* Returns a new graph that contains all facts in 'g' except 'f' *)
let remove_fact g f =
let ng = (Graph.copy g) in
let ng = Graph.copy g in
mremove_fact ng f; ng;;
(* 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 [];;
(* Returns a new graph that contains the union of graph g1 and g2 *)
let join_graph g1 g2 =
let ng = Graph.copy g1 in
mjoin_graph_left ng g1;
mjoin_graph_left ng g2;
ng;;
......@@ -108,6 +108,17 @@ let terminate (ic, oc) =
close_in_noerr ic;
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 open Request in
let handle_request request =
......@@ -115,15 +126,12 @@ let handle_client (ic, oc, addr) =
| "/graph" ->
begin match request.meth with
| "GET" ->
lock g;
let json = json_for_graph !graph in
unlock g; Response.make 200 json;
sync (fun _ -> json_for_graph !graph) g ()
|> Response.make 200;
| "POST" ->
begin try
let graph = graph_for_json request.body in
graph_for_json request.body
|> sync (fun ug -> mjoin_graph_left !graph ug) g;
Response.make 200 "";
with Failure x -> Response.make 500 x;
end
| _ -> Response.make 405 ""
end;
| "/query" -> Response.make 200 "Query.";
......@@ -150,8 +158,4 @@ let main port =
accept_loop () in
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;;
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