### 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