planned dehyphenation of lambdadelta eventually took place!

[helm.git] / helm / www / lambdadelta / bin / xhtbl / pass2.ml

diff --git a/helm/www/lambdadelta/bin/xhtbl/pass2.ml b/helm/www/lambdadelta/bin/xhtbl/pass2.ml
new file mode 100644 (file)
index 0000000..68cc7ba
--- /dev/null
+++ b/helm/www/lambdadelta/bin/xhtbl/pass2.ml
@@ -0,0 +1,139 @@
+module O = Options
+module T = Table
+module M = Matrix
+module F = Fold
+
+type status = {
+   ts: T.size;   (* current dimensions *)
+   tm: M.matrix; (* current matrix *)
+}
+
+let initial t m = {
+   ts = {t.T.ts with T.ri = 0; T.ci = 0};
+   tm = m;
+}
+
+let resize b sts tts = 
+   if b then begin (* parent is a row *) 
+      if tts.T.rf < sts.T.rf && tts.T.ri = 0 then
+         failwith "underful column";
+      {tts with T.rf = sts.T.rf; T.cf = tts.T.cf + sts.T.ci * tts.T.ci}
+   end else begin (* parent is a column *)
+      if tts.T.cf < sts.T.cf && tts.T.ci = 0 then
+         failwith "underful row";
+      {tts with T.cf = sts.T.cf; T.rf = tts.T.rf + sts.T.ri * tts.T.ri}
+   end
+
+let fill b sts tts =
+   if b then (* parent is a row *) 
+      {sts with T.ri = 
+         let rf, ri = sts.T.rf - tts.T.rf, tts.T.ri in
+        if ri = 0 then 0 else
+        if rf mod ri = 0 then rf / ri else
+        failwith "fracted column"
+      }
+   else (* parent is a column *)
+      {sts with T.ci = 
+         let cf, ci = sts.T.cf - tts.T.cf, tts.T.ci in
+        if ci = 0 then 0 else
+        if cf mod ci = 0 then cf / ci else
+        failwith "fracted row"
+      }
+
+let place b sts tts =
+   if b then (* parent is a row *)
+      {sts with T.x = sts.T.x + tts.T.cf}
+   else (* parent is a column *)
+      {sts with T.y = sts.T.y + tts.T.rf}
+
+let set_key st t = match t.T.te with
+   | T.Key (T.Text sl) -> M.set_key st.tm t.T.ts.T.y t.T.ts.T.x sl  
+   | _                 -> ()
+
+let set_css st t =
+   let rec aux y x =
+      if y >= t.T.ts.T.rf then () else
+      if x >= t.T.ts.T.cf then aux (succ y) 0 else begin
+        M.set_css st.tm (t.T.ts.T.y + y) (t.T.ts.T.x + x) t.T.tc;
+         aux y (succ x)
+      end
+   in
+   match t.T.te with 
+      | T.Key _ -> aux 0 0 
+      | _       -> ()
+
+let set_borders st t =
+   let rec aux_we y =
+      if y >= t.T.ts.T.rf then () else begin
+        M.set_west st.tm (t.T.ts.T.y + y) t.T.ts.T.x t.T.tb;
+        if t.T.ts.T.cf > 0 then 
+           M.set_east st.tm (t.T.ts.T.y + y) (t.T.ts.T.x + pred t.T.ts.T.cf) t.T.tb;
+         aux_we (succ y)
+      end      
+   in
+   let rec aux_ns x =
+      if x >= t.T.ts.T.cf then () else begin
+        M.set_north st.tm t.T.ts.T.y (t.T.ts.T.x + x) t.T.tb;
+        if t.T.ts.T.rf > 0 then 
+           M.set_south st.tm (t.T.ts.T.y + pred t.T.ts.T.rf) (t.T.ts.T.x + x) t.T.tb;
+         aux_ns (succ x)
+      end      
+   in
+   match t.T.te with 
+      | T.Line (true, _) -> aux_we 0; aux_ns 0
+      | _                -> ()
+
+let print st t = 
+   if !O.e2 then
+      Printf.printf "#%u: (%u+%u, %u+%u) - (%u+%u, %u+%u)\n"
+         t.T.ti 
+         t.T.ts.T.rf t.T.ts.T.ri 
+         t.T.ts.T.cf t.T.ts.T.ci
+         st.ts.T.rf st.ts.T.ri
+         st.ts.T.cf st.ts.T.ci
+
+(****************************************************************************)
+
+let open_table st t =
+   print st t;
+   let ts = match t.T.ts.T.p with
+      | None   ->
+         let ts = fill false st.ts t.T.ts in
+         let ts = fill true ts t.T.ts in
+        t.T.ts <- resize false st.ts t.T.ts;
+         t.T.ts <- resize true st.ts t.T.ts;
+        ts
+      | Some b ->
+         let ts = fill b st.ts t.T.ts in
+        t.T.ts <- resize b st.ts t.T.ts;
+        ts
+   in
+   t.T.ts <- {t.T.ts with T.ri = 0; T.ci = 0; T.x = st.ts.T.x; T.y = st.ts.T.y};
+   let ts = {ts with T.rf = t.T.ts.T.rf; T.cf = t.T.ts.T.cf} in
+   let st = {st with ts = ts} in 
+   print st t; st
+
+let close_table st t =
+   set_key st t; set_css st t; set_borders st t; st
+
+let map_key st k = st
+
+let open_line b st = st
+
+let open_entry b st = st
+
+let close_entry b st sst =
+   let ts = place b st.ts sst.ts in
+   {st with ts = ts}
+
+let close_line b st = st
+
+let cb = {
+   F.open_table = open_table; F.close_table = close_table;   
+   F.open_line = open_line; F.close_line = close_line;
+   F.open_entry = open_entry; F.close_entry = close_entry;
+   F.map_key = map_key;
+}
+
+let process t m =
+   let _ = F.fold_table cb (initial t m) t in ()