\ / This software is distributed as is, NO WARRANTY.
V_______________________________________________________________ *)
-module F = Filename
-module U = NUri
-module C = Cps
-module H = Hierarchy
-module G = Options
-module E = Entity
-module N = Level
-module Q = Ccs
+module KF = Filename
+module KP = Printf
+
+module U = NUri
+module C = Cps
+module G = Options
+module H = Hierarchy
+module N = Layer
+module E = Entity
+
+IFDEF OBJECTS THEN
(* internal functions *******************************************************)
let ext = ".xml"
-let obj_root = "ENTITY"
-
-let ccs_name = "ccs.ldc"
-
-let ccs_root = "CCS"
+let obj_root = "CONSTANT"
let home = "http://lambdadelta.info/"
-let system = F.concat (F.concat home base) "ld.dtd"
+let system = KF.concat (KF.concat home base) "ld.dtd"
let xmlns = "xmlns", home
let path_of_uri xdir uri =
- let base = F.concat xdir base in
- F.concat base (Str.string_after (U.string_of_uri uri) 3)
+ let base = KF.concat xdir base in
+ KF.concat base (Str.string_after (U.string_of_uri uri) 3)
(* interface functions ******************************************************)
let position i =
"position", string_of_int i
+let depth i =
+ "depth", string_of_int i
+
let uri u =
"uri", U.string_of_uri u
let name a =
- let map f i n r s =
- let n = if r then n else "-" ^ n in
- let spc = if i then "" else " " in
- f (s ^ n ^ spc)
- in
- let f s = "name", s in
- E.names f map a ""
+ let err () = "name", "" in
+ let f n r = "name", if r then n else "-" ^ n in
+ E.name err f a
-let apix a =
- let err () = "age", "" in
- let f i = "age", string_of_int i in
- E.apix err f a
+let restricted r =
+ "restricted", KP.sprintf "%b" r
+
+let layer st n =
+ "layer", N.to_string st n
-let mark a =
- let err () = "mark", "" in
- let f i = "mark", string_of_int i in
- E.mark err f a
+let main (sort, degr) =
+ ["main-position", string_of_int sort;
+ "main-degree", string_of_int degr;
+ ]
-let level n =
- "level", N.to_string n
+let side (sort, degr) =
+ ["side-position", string_of_int sort;
+ "side-degree", string_of_int degr;
+ ]
+
+let apix a =
+ "level", string_of_int a.E.n_apix
let meta a =
let map = function
| E.Progress -> "Progress"
| E.Private -> "Private"
in
- let err () = "meta", "" in
- let f ms = "meta", String.concat " " (List.rev_map map ms) in
- E.meta err f a
-
-let arity l =
- "arity", string_of_int (List.length l)
+ "meta", String.concat " " (List.rev_map map a.E.r_meta)
(* TODO: the string tx must be quoted *)
let info a =
let f lg tx = ["lang", lg; "info", tx] in
E.info err f a
-let export_entity pp_term (a, u, b) =
+let export_entity pp_term (ra, na, u, b) =
let path = path_of_uri !G.xdir u in
- let _ = Sys.command (Printf.sprintf "mkdir -p %s" (F.dirname path)) in
+ let _ = Sys.command (Printf.sprintf "mkdir -p %s" (KF.dirname path)) in
let och = open_out (path ^ ext) in
let out = output_string och in
xml out "1.0" "UTF-8"; doctype out obj_root system;
- let a = E.Name (U.name_of_uri u, true) :: a in
- let attrs = uri u :: name a :: apix a :: meta a :: info a in
+ let ba = E.bind_attrs ~name:(U.name_of_uri u, true) () in
+ let attrs a = uri u :: name ba :: apix na :: meta ra :: info ra @ side a.E.e_side in
let contents = match b with
- | E.Abst (n, w) -> tag "GDec" (level n :: attrs) ~contents:(pp_term w)
- | E.Abbr v -> tag "GDef" attrs ~contents:(pp_term v)
- | E.Void -> assert false
+ | E.Abst (a, w) -> tag "GDec" (attrs a) ~contents:(pp_term w)
+ | E.Abbr (a, v) -> tag "GDef" (attrs a) ~contents:(pp_term v)
+ | E.Void -> assert false
in
let opts = if !G.si then "si" else "" in
let shp = H.string_of_graph () in
tag obj_root attrs ~contents out 0;
close_out och
-let prec_map (i, _) = string_of_int i
-
-let next_map (_, i) = string_of_int i
-
-let marks = function
- | [] -> "mark", ""
- | l -> "mark", String.concat " " (List.rev_map string_of_int l)
-
-let precs = function
- | [] -> "prec", ""
- | l -> "prec", String.concat " " (List.rev_map prec_map l)
-
-let nexts = function
- | [] -> "next", ""
- | l -> "next", String.concat " " (List.rev_map next_map l)
-
-let export_csys s =
- let path = path_of_uri !G.xdir s.Q.buri in
- let _ = Sys.command (Printf.sprintf "mkdir -p %s" path) in
- let name = F.concat path (ccs_name ^ ext) in
- let och = open_out name in
- let out = output_string och in
- xml out "1.0" "UTF-8"; doctype out ccs_root system;
- let attrs = [xmlns; uri s.Q.buri] in
- let contents out tab =
- tag "ToPositive" [arity s.Q.tp; marks s.Q.tp] out tab;
- tag "ToOne" [arity s.Q.t1; marks s.Q.t1] out tab;
- tag "ToNext" [arity s.Q.tn; precs s.Q.tn; nexts s.Q.tn] out tab
- in
- tag ccs_root attrs ~contents out 0;
- close_out och
+END
projects / helm.git / blobdiff