Finalize tengwar transcription

1 files changed, 170 insertions, 142 deletions

diff --git a/src/lib/repr/tengwar.ml b/src/lib/repr/tengwar.ml
index 1f34928..c913574 100644
--- a/src/lib/repr/tengwar.ml
+++ b/src/lib/repr/tengwar.ml
@@ -29,14 +29,85 @@ type consonant =
   ; primary : bool
   ; category : category }
 
-type application = (t -> t * t option)
+
+type glyph =
+  { tengwa : consonant option
+  (* The eventual Tehta above the tengwa *)
+  ; tehta_above : voyel option
+  (* And below *)
+  ; tehta_below : voyel option
+  }
+
+let empty_glyph =
+  { tengwa = None
+  ; tehta_above = None
+  ; tehta_below = None }
+
+let pair
+  : voyel -> consonant -> string
+  = fun voyel consonant ->
+    match voyel.position with
+    | `Above -> voyel.app (fst consonant.position)
+    | `Below -> voyel.app (snd consonant.position)
+
+let portant =
+  { position = Pos4, Lower1
+  ; muted = None
+  ; category = I
+  ; primary = false
+  ; repr = "`" }
+
+let repr_glyph
+  : glyph -> Buffer.t -> unit
+  = fun { tengwa; tehta_above; tehta_below } b ->
+    let () =  match tengwa with
+      | None -> Buffer.add_string b @@ portant.repr
+      | Some c ->Buffer.add_string b @@ c.repr in
+    let () = match tehta_above, tengwa with
+      | None, _ -> ()
+      | Some v, Some c ->  Buffer.add_string b @@ pair v c
+      | Some v, None ->    Buffer.add_string b @@ pair v portant in
+    let () = match tehta_below, tengwa with
+      | None, _ -> ()
+      | Some v, Some c ->  Buffer.add_string b @@ pair v c
+      | Some v, None ->    Buffer.add_string b @@ pair v portant in
+    ()
+
+let combine_glyph
+  : glyph -> glyph -> glyph option
+  = fun g1 g2 ->
+    let tengwa = match g1.tengwa, g2.tengwa with
+      | Some _, Some _ -> Error ()
+      | None, any -> Ok (any)
+      | any, None -> Ok (any) in
+    let above = match g1.tehta_above, g2.tehta_above with
+      | Some _, Some _ -> Error ()
+      | None, any -> Ok any
+      | any, None -> Ok any in
+    let below = match g1.tehta_below, g2.tehta_below with
+      | Some _, Some _ -> Error ()
+      | None, any -> Ok any
+      | any, None -> Ok any in
+    match tengwa, above, below with
+    | Ok tengwa, Ok tehta_above, Ok tehta_below ->
+      Some { tengwa; tehta_above; tehta_below}
+    | _, _, _ -> None
+
+let add_voyel_to_glyph
+  : glyph -> voyel -> glyph
+  = fun g v ->
+    match v.position with
+    | `Above -> { g with tehta_above = Some v }
+    | `Below -> { g with tehta_below = Some v }
+
+type application = (t -> t list)
 
 and t =
   | Consonant of consonant
   | Voyel of voyel
   | Nasal of application
-  | App of application
   | Repr of string
+  | Glyph of glyph
   | Nothing
 
 let none = Nothing
@@ -279,16 +350,9 @@ and semi_voyel_u = Consonant
     ; primary = false
     ; repr = "]" }
 
-let pair
-  : voyel -> consonant -> string
-  = fun voyel consonant ->
-    match voyel.position with
-    | `Above -> voyel.app (fst consonant.position)
-    | `Below -> voyel.app (snd consonant.position)
-
 let l =
   let default =
-    { position = Pos1, Lower1
+    { position = Pos1, Lower2
     ; muted = None
     ; category = II
     ; primary = false
@@ -300,33 +364,32 @@ let nasal letter =
     ( function
       | Consonant { category = II; _} as f ->
         let Consonant c = m [@@warning "-8"] in
-        let v = pair letter c in
-        let repr = c.repr ^ v in
-        Consonant {c with repr}, Some f
+        let g = Glyph
+            {empty_glyph with
+             tengwa = Some c
+           ; tehta_above = Some letter } in
+        g::f::[]
       | Consonant { category = III; _} as f ->
         let Consonant c = gn [@@warning "-8"] in
-        let v = pair letter c in
-        let repr = c.repr ^ v in
-        Consonant {c with repr}, Some f
+        let g = Glyph
+            {empty_glyph with
+             tengwa = Some c
+           ; tehta_above = Some letter } in
+        g::f::[]
+
       | f ->
         let Consonant c = n [@@warning "-8"] in
-        let v = pair letter c in
-        let repr = c.repr ^ v in
-        let default = Consonant { c with repr } in
-        default, Some f
+        let g = Glyph
+            {empty_glyph with
+             tengwa = Some c
+           ; tehta_above = Some letter } in
+        g::f::[]
     )
 let a_nasal = nasal a'
 and o_nasal = nasal o'
 and i_nasal = nasal i'
 and y_nasal = nasal y'
 
-and portant =
-  { position = Pos4, Lower1
-  ; muted = None
-  ; category = I
-  ; primary = false
-  ; repr = "`" }
-
 let muted
   : t -> t
   = fun t ->
@@ -341,57 +404,17 @@ let muted
 
 let diphtongue
   : t -> t -> t
-  = fun t1 t2 -> match t1, t2 with
-    | Consonant c, Voyel v ->
-
-      Nasal (fun t ->
-          match t with
-          | Nothing ->
-            let repr = c.repr in
-            Repr repr, (Some t2)
-          | Consonant c2 ->
-            let b = Buffer.create 4 in
-            Buffer.add_string b c.repr;
-            Buffer.add_string b c2.repr;
-            let v2 = pair v c2 in
-            Buffer.add_string b v2;
-            let repr = Buffer.contents b in
-            Repr repr, None
-          | Repr r ->
-            let v_repr = pair v portant in
-            Repr(c.repr ^ portant.repr ^ v_repr ^ r), None
-          | Voyel _
-          | Nasal _
-          | App _ ->
-            let b = Buffer.create 4 in
-            let v = pair v portant in
-            Buffer.add_string b c.repr;
-            Buffer.add_string b portant.repr;
-            Buffer.add_string b v;
-            let repr = Buffer.contents b in
-            ( Repr repr
-            , Some t)
-        )
-
-    | Consonant c, Nasal n
-    | Consonant c, App n
-      ->
-      begin match n none with
-        | Consonant c2, _ ->
-          Repr(c.repr ^ c2.repr)
-        | Repr r, _ ->
-          Repr(c.repr ^ r)
-        | Voyel v, _ ->
-          let v_repr = pair v c in
-          Repr(c.repr ^ v_repr)
-        | Nothing, _
-        | Nasal _, _
-        | App _, _ ->
-          t1
-      end
+  = fun t1 t2 ->
+    match t1 with
+
+    | Consonant c->
+      let semi_voyel =
+        Glyph
+          { empty_glyph with tengwa = Some c} in
+      Nasal (fun t -> semi_voyel::t2::t::[])
     | _ ->
       print_endline "Ignoring diphtongue";
-      none
+      Nothing
 
 let fold
   : t list -> string
@@ -399,81 +422,86 @@ let fold
     let buff = Buffer.create 16 in
 
     let rec _fold
+      : glyph option -> t list -> unit
       = fun init -> function
         | [] ->
           begin match init with
-            | None
-            | Some Nothing
-              -> ()
-            | Some Voyel ( {position = `Above; _ } as v) ->
-              Buffer.add_string buff ("`" ^ (pair v portant))
-            | Some Voyel ( {position = `Below; _ } as v) ->
-              Buffer.add_string buff (v.app Pos1)
-            | Some Nasal n
-            | Some App n ->
-              let result, next = (n Nothing) in
-              begin match next with
-                | None -> _fold (Some result) []
-                | Some v -> _fold (Some result) [v]
-              end
-            | Some Repr r ->
-              Buffer.add_string buff r
-            | Some Consonant c ->
-              Buffer.add_string buff (c.repr)
+            | None -> ()
+            | Some glyph ->
+              repr_glyph glyph buff
           end
         | hd::tl ->
           match init, hd with
-          | Some Nothing, _ -> _fold (Some hd) tl
-          | _, Nothing      -> _fold init tl
-          | Some Voyel ({position = `Above; _} as v), Consonant c ->
-            Buffer.add_string buff (c.repr ^ (pair v c));
-            _fold None tl
-          | Some Voyel ({position = `Below; _} as v), Consonant c ->
-            Buffer.add_string buff ((pair v c) ^ c.repr);
-            _fold None tl
-          | Some Voyel v, _ ->
-            Buffer.add_string buff ("`" ^ (pair v portant));
-            _fold (Some hd) tl
-          | Some Nasal n, Consonant _
-          | Some App n, Consonant _
-            ->
-            let result, next = n hd in
-            begin match next with
-              | None -> _fold (Some result) tl
-              | Some hd -> _fold (Some result) (hd::tl)
-            end
-          | Some Nasal n, Voyel v
-          | Some App n, Voyel v
-            ->
-            let result, next = (n hd) in
-            begin match next with
-              | None -> _fold (Some result) (tl)
-              | Some next -> _fold (Some result) (next::tl)
-            end
-          | Some Nasal n, _
-          | Some App n, _ ->
-            let result, next = (n (Consonant portant)) in
-            begin match next with
-              | None -> _fold (Some result) (hd::tl)
-              | Some next -> _fold (Some result) (next::hd::tl)
-            end
-          | Some Repr r, _ ->
-            Buffer.add_string buff r;
-            _fold (Some hd) tl
-          | Some Consonant c, _ ->
-            Buffer.add_string buff c.repr;
-            _fold (Some hd) tl
-
+          | any, Nothing -> _fold any tl
           | None, Consonant c ->
-            Buffer.add_string buff c.repr;
-            _fold None tl
+            _fold
+              (Some {empty_glyph with tengwa = Some c})
+              tl
+          | None, Voyel ({position = `Above; _} as v) ->
+            _fold
+              (Some {empty_glyph with tehta_above = Some v})
+              tl
+          | None, Voyel ({position = `Below; _} as v) ->
+            _fold
+              (Some {empty_glyph with tehta_below = Some v})
+              tl
           | None, Repr r ->
             Buffer.add_string buff r;
-            _fold None tl
-          | None, Voyel _
-          | None, Nasal _
-          | None, App _ ->
-            _fold (Some hd) tl
+            _fold
+              None tl
+          | any, Nasal n ->
+            let next, rest = match tl with
+              | [] -> Nothing, []
+              | other::ll -> other, ll in
+            let result = n next in
+            _fold any (result @ rest)
+
+          | Some t, Repr s ->
+            repr_glyph t buff;
+            Buffer.add_string buff s;
+            _fold
+              None
+              tl
+          | Some ({ tengwa = Some _ ; _} as t), Consonant c ->
+            repr_glyph t buff;
+            _fold
+              (Some {empty_glyph with tengwa = Some c})
+              tl
+          | Some ({ tehta_below = Some _ ; _} as t), Voyel ({position = `Below; _} as v) ->
+            repr_glyph t buff;
+            _fold
+              (Some {empty_glyph with tehta_below = Some v})
+              tl
+          | Some t, Voyel ({position = `Above; _} as v) ->
+            repr_glyph t buff;
+            _fold
+              (Some {empty_glyph with tehta_above = Some v})
+              tl
+          | Some t, Voyel v ->
+            _fold
+              (Some (add_voyel_to_glyph t v))
+              tl
+          | Some ({ tengwa = None ; _} as t), Consonant c ->
+            _fold
+              (Some {t with tengwa = Some c})
+              tl
+          | None, Glyph g ->
+            _fold
+              (Some g)
+              tl
+          | Some g1, Glyph g2 ->
+            begin match combine_glyph g1 g2 with
+              | Some _ as res ->
+                _fold
+                  res
+                  tl
+              | None ->
+                repr_glyph g1 buff;
+                _fold
+                  (Some g2)
+                  tl
+            end
+
 
     in
     _fold None elems;