diff options
| -rw-r--r-- | src/lib/repr/tengwar.ml | 312 |
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; |