add graph with maps and create function

Author: jasonperry

src/.merlin

@@ -1,4 +1,4 @@
 EXCLUDE_QUERY_DIR
 B ../_build/default/src/.words.eobjs/byte
 S .
-FLG -w @[email protected]@30..39@[email protected]@[email protected] -strict-sequence -strict-formats -short-paths -keep-locs
+FLG -open Dune__exe -w @[email protected]@30..39@[email protected]@[email protected] -strict-sequence -strict-formats -short-paths -keep-locs

src/concept.ml

@@ -1,4 +1,4 @@
-
+(** A graph representation of a DL-like knowledge base. *)
 
 module StrMap = Map.Make(String)
 
@@ -8,10 +8,10 @@ let find_list s map =
   | Some l -> l
   | None -> []
 
-(* need separate types for role type and relation instance? 
- * or a role instance can just be a (role * concept) in the concept *)
+
 type concept = {
     cid: string;
+    (* Map from role name to list of role instances of that type. *)
     mutable roles: role_inst_concept list StrMap.t
   }
 and role = {         (* a role /type/. *)
@@ -69,20 +69,33 @@ let add_role c1 role c2 =
   )
 
 module ConceptGraph = struct
-  type t = concept list
+  type t = {
+      cmap: concept StrMap.t;
+      rmap: role StrMap.t;
+    }
+
+  let create clist rlist = {
+      cmap = List.fold_left
+               (fun map concept ->
+                 StrMap.add concept.cid concept map)
+               StrMap.empty
+               clist;
+      rmap = List.fold_left
+               (fun map role ->
+                 StrMap.add role.rid role map)
+               StrMap.empty
+               rlist;
+    }
+  (* Yay, now I can add inferences corresponding to questions. *)
   (* function to add concept, check for duplicate name *)
   (* function to add relation between concepts, check restrictions *)         
-  let add_concept (g: t) c =
-    c :: g
+  (* let add_concept (g: t) c =
+    c :: g *)
 end
 
-(* oh. it's meaningless to make restrictions on the subclass relation, 
- * because subclass itself is the terms in which restrictions are stated. *)
-
 (* need a concept-maker and a relation-adder that checks everything. 
  * ...and makes indexes of relations by type *)
 
-(* a concept is a node in a graph *)
 
 (* Can i encode in the type system that superclass/subclass relations are 
  * only allowed between node of same category? *)

src/ontoOne.ml renamed to src/upperOnto.ml

@@ -1,8 +1,10 @@
+(** Upper ontology
+  * These concepts and roles may be assumed in inference methods. *)
 
 open Concept
 
-(* start by specifying the root ontology in code.*)
 let universal_concept: concept = { cid="Concept"; roles=StrMap.empty }
+let entity: concept = { cid="Entity"; roles=StrMap.empty }
 let physical_object: concept = { cid="Physical_object"; roles=StrMap.empty }
 let abstract_object: concept = { cid="Abstract_object"; roles=StrMap.empty }
 let property: concept = { cid="Property"; roles=StrMap.empty }
@@ -21,22 +23,37 @@ and superclass: role = {
     range = universal_concept;
     transitive = true;
     inverse = Some subclass
-  } 
+  }
 
 let rec disjoint_with: role = {
-    rid = "disjoint_with";
+    rid = "disjointWith";
     domain = universal_concept;
     range = universal_concept;
     transitive = false;
     inverse = Some disjoint_with  (* it's own inverse! Yeah! *)
   }
 
-let () = add_role universal_concept superclass physical_object
-let () = add_role physical_object subclass universal_concept
+let has_property: role = {
+    rid = "hasProperty";
+    domain = entity;
+    range = property;
+    transitive = false;
+    inverse = None
+  }
+
+(* entity <-> universal *)
+let () = add_role universal_concept superclass entity
+let () = add_role entity subclass universal_concept
 
-let () = add_role universal_concept superclass abstract_object
-let () = add_role abstract_object subclass universal_concept
+(* physical <-> entity *)
+let () = add_role entity superclass physical_object
+let () = add_role physical_object subclass entity
 
+(* abstract <-> entity *)
+let () = add_role entity superclass abstract_object
+let () = add_role abstract_object subclass entity
+
+(* property <-> universal *)
 let () = add_role universal_concept superclass property
 let () = add_role property subclass universal_concept
 
@@ -49,3 +66,18 @@ let () = add_role physical_object disjoint_with property
 
 let () = add_role property disjoint_with abstract_object
 let () = add_role abstract_object disjoint_with property
+
+let upper_ontology =
+  ConceptGraph.create
+    [ universal_concept;
+      entity;
+      physical_object;
+      abstract_object;
+      property
+    ]
+    [ superclass;
+      subclass;
+      disjoint_with;
+      has_property
+    ]
+

src/vocab.ml

@@ -1,8 +1,41 @@
 
 open Words
 
-let st = StringyString.of_string
-   
-let walk = StrWord.create ~baseform:(st "walk") ~posdata:[
-      Vb {tag="VB"; vbs=S; prespart=Ing; past=Ed; pastpart=Ed}
-    ]
+let st = StringEx.of_string
+
+let person = StrWord.create ~baseform:(st "person") ~lexdata:[
+                 Nn {countable=true; plural=Irreg(st "people")}
+               ]
+
+let walk = StrWord.create ~baseform:(st "walk") ~lexdata:[
+               Vb {vbs=S; prespart=Ing; past=Ed; pastpart=Ed};
+               Nn {countable=true; plural=S}
+             ]
+
+let ride = StrWord.create ~baseform:(st "ride") ~lexdata:[
+               Vb {vbs=S; prespart=Eing;
+                   past=Irreg (st "rode"); pastpart=Edden};
+               Nn {countable=true; plural=S}
+             ]
+
+let hide = StrWord.create ~baseform:(st "hide") ~lexdata:[
+               Vb {vbs=S; prespart=Eing;
+                   past=Irreg (st "hid"); pastpart=Edden};
+               Nn {countable=true; plural=S}
+             ]
+
+let have = StrWord.create ~baseform:(st "have") ~lexdata:[
+               Vb {vbs=Irreg (st "has"); prespart=Eing;
+                   past=Irreg (st "had"); pastpart=Irreg (st "had")}
+             ]
+
+(* maybe add a "fullconj" option, but for terminological knowledge, 
+ * we can do without first and second person for now. *)
+let be = StrWord.create ~baseform:(st "be") ~lexdata:[
+             Vb {vbs=Irreg (st "is"); prespart=Ing;
+                 past=Irreg (st "was"); pastpart=Irreg (st "been")}
+           ]
+
+let all_words = [ person; walk; ride; hide; have; be ]
+
+module VocabMap = Map.Make(StringEx) 

src/words.ml

@@ -10,14 +10,15 @@ type 's pluralform =
 
 type 's pastform =
   | Ed
-  | Dded (* consonant doubling *)
-  | Yied
+  | Dded (* consonant doubling: "clapped" *)
+  | Yied (* change y to i *)
+  | Edden (* for the past participle "ridden" *)
   | Irreg of 's
 
 type 's ingform =
   | Ing
-  | Dding
-  | Eing  (* what was this for? *)
+  | Dding (* consonant doubling *)
+  | Eing  (* drop the e *)
   | Irreg of 's
 
 (* Need to store noun and verb /types/ also: transitive/intransitive,
@@ -33,24 +34,26 @@ type 's ingform =
 (* Just put the tag string in the record, and when I make the map, I just
  * pull it out and add the tag separately. That's how a map works anyway. *)
 
-type 's nouninfo = { tag: string;
-                     countable: bool;
+type 's nouninfo = { countable: bool;
                      plural: 's pluralform } (* Gerund? Infinitive? *)
 
 (* thinking that different forms of a verb can be in one record. *)
-type 's verbinfo = { tag: string;
-                     vbs: 's pluralform;
+type 's verbinfo = { vbs: 's pluralform;
                      prespart: 's ingform;
                      past: 's pastform;
                      pastpart: 's pastform }
 
 (* Still need a dictionary to POS lookup of a word *)
 (* Actually, a datatype for a word with specific POS *)
-type 's posinfo =
+type 's lexinfo =
   | Nn of 's nouninfo
   | Vb of 's verbinfo
   | Jj
   | Rb
+  | Prep
+  | Pron
+  | Conj
+  | Det
 
 (* idea: word module parameterized by a module that has a 
  * "string" type that supports character indexing. This way we can support 
@@ -65,7 +68,9 @@ module type STRINGY = sig
   val length : t -> int
   val sub : t -> int -> int -> t
   val of_string : string -> t
+  val show : t -> string
   val append : t -> t -> t
+  val append_r : t -> t -> t
   val compare : t -> t -> int
 end
 
@@ -76,39 +81,97 @@ module Word = functor (St: STRINGY) -> struct
   module StSet = Set.Make(St)
   type t = {
       baseform: St.t;
-      posdata: St.t posinfo list;
-      posdict: St.t posinfo PosMap.t;
-      allforms: StSet.t
+      lexdata: St.t lexinfo list;
+      (* posdict: St.t lexinfo PosMap.t; (* gen_entry takes care... *)
+      allforms: StSet.t *)
     }
   type sentence = (St.t * t) list
-  let create ~baseform ~posdata = {
-      baseform; posdata;
-      posdict = PosMap.empty;
-      allforms = StSet.empty
+  let create ~baseform ~lexdata = {
+      baseform;
+      lexdata;
+      (* posdict = PosMap.empty;
+      allforms = StSet.empty *)
     }
   (* Parse from JSON/Xml? *)
   let rtrim s n = St.sub s 0 (St.length s - n)
-  let to_string w = w.baseform  (* maybe not actual string *)
-  (* let add_plural w pl = match pl with
-    | S -> { w with plural = St.append w.baseform (St.of_string "s") }
-    | Es -> { w with plural = St.append w.baseform (St.of_string "es") }
-    | Yies -> { w with
-                plural = St.append (rtrim w.baseform 1) (St.of_string "ies") }
-    | Irreg s -> { w with plural = s } *)
+  let to_string w = w.baseform  (* just a hack to print the base form *)
+  let pluralize baseform pltype = match pltype with
+    | S -> St.append baseform (St.of_string "s")
+    | Es -> St.append baseform (St.of_string "es")
+    | Yies -> St.append (rtrim baseform 1) (St.of_string "ies")
+    | Irreg s -> s
+  let add_ing baseform ingtype = match ingtype with
+    | Ing -> St.append baseform (St.of_string "ing")
+    | Dding ->
+       let dcons = St.sub baseform (St.length baseform - 1) 1
+       in
+       St.append baseform dcons
+       |> St.append_r (St.of_string "ing")
+    | Eing -> St.append (rtrim baseform 1) (St.of_string "ing")
+    | Irreg s -> s
+  let add_past baseform pastform = match pastform with
+    | Ed -> St.append baseform (St.of_string "ed")
+    | Dded ->
+       let dcons = St.sub baseform (St.length baseform - 1) 1
+       in
+       St.append baseform dcons
+       |> St.append_r (St.of_string "ed")
+    | Yied -> rtrim baseform 1
+              |> St.append_r (St.of_string "ied")
+    | Edden ->
+       let len = St.length baseform in
+       let dcons = St.sub baseform (len-2) 1
+       in
+       St.append (rtrim baseform 1) dcons
+       |> St.append_r (St.of_string "en")
+    | Irreg s -> s
+  (* Generate all lexicon entries from string to (string, POS, t) triples 
+   * (originally just lexinfo, but t has the base in it too, so good) *)
+  let gen_entry w =
+    w.lexdata
+    |> List.map (function
+           | Nn { countable; plural } ->
+              if countable then [
+                  (w.baseform, "NN-S", w);
+                  (pluralize w.baseform plural, "NN-P", w)
+                ]
+              else []
+           | Vb { vbs; prespart; past; pastpart } -> [
+               (w.baseform, "VP-S", w);
+               (pluralize w.baseform vbs, "VB-P", w);
+               (add_ing w.baseform prespart, "VB-G", w);
+               (add_past w.baseform past, "VB-D", w);
+               (add_past w.baseform pastpart, "VB-N", w)
+             ]
+           | Jj -> [ (w.baseform, "JJ-S", w) ]
+           | Rb -> [ (w.baseform, "RB-S", w) ]
+           | Conj -> [ (w.baseform, "CJ", w) ]
+           | Det -> [ (w.baseform, "DT", w) ]
+           | Prep -> [ (w.baseform, "IN", w) ]
+           | Pron -> [ (w.baseform, "PN", w) ]
+         )
+    |> List.concat
 end
 
 (* String-specific module implementations start here. *)
 
-module StringyString : STRINGY = struct
+module StringEx : STRINGY = struct
   include String
   type c = char
   let of_string s = s
+  let show s = s
   let append s1 s2 = s1 ^ s2
+  let append_r s1 s2 = s2 ^ s1
 end
 
+(* For the toplevel pretty-printer *)
+let format_stringex fmt ss =
+  Format.fprintf fmt "\"%s\"" (StringEx.show ss)
+
+                               
 (* Eventually want to parameterize by the language too...or,
  * Just have a different Word module of same signature *)
-module StrWord = Word(StringyString)
+module StrWord = Word(StringEx)
 
 (* Assumes word also includes punctuation. *)
 type sentence = (string * StrWord.t) list