diff options
Diffstat (limited to 'src/lib/repr/tengwar.ml')
| -rw-r--r-- | src/lib/repr/tengwar.ml | 384 |
1 files changed, 0 insertions, 384 deletions
diff --git a/src/lib/repr/tengwar.ml b/src/lib/repr/tengwar.ml deleted file mode 100644 index f9fde05..0000000 --- a/src/lib/repr/tengwar.ml +++ /dev/null @@ -1,384 +0,0 @@ -type position_type = - [ `Above - | `Below ] - -(** Consonant category *) -type category = - | I - | II - | III - -type 'a voyel = - { position : position_type - ; app : ('a -> string) } - -type 'a consonant = - { position : 'a - ; muted: string option - ; repr : string - ; primary : bool - ; category : category } - -type 'a glyph = - { tengwa : 'a consonant option - (* The eventual Tehta above the tengwa *) - ; tehta_above : 'a voyel option - (* And below *) - ; tehta_below : 'a voyel option - } - -let empty_glyph = - { tengwa = None - ; tehta_above = None - ; tehta_below = None } - -let pair - : 'a voyel -> 'a consonant -> string - = fun voyel consonant -> - voyel.app consonant.position - -let repr_glyph - : portant:'a consonant -> 'a glyph -> Buffer.t -> unit - = fun ~portant { 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 - : 'a glyph -> 'a glyph -> 'a 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 - (* Combine only if everything is ok *) - 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 - : 'a glyph -> 'a voyel -> 'a glyph - = fun g v -> - match v.position with - | `Above -> { g with tehta_above = Some v } - | `Below -> { g with tehta_below = Some v } - -type 'a t = - | Consonant of 'a consonant - | Voyel of 'a voyel - | Application of ('a t -> 'a t list) - | Repr of string - | Glyph of 'a glyph - | Nothing - -let none = Nothing - -let space s = Repr s - -let nasal m ng n letter = - Application - ( function - | Consonant { category = II; _} as f -> - let Consonant c = m [@@warning "-8"] in - let g = Glyph - {empty_glyph with - tengwa = Some c - ; tehta_above = Some letter } in - g::f::[] - | Consonant { category = III; _} as f -> - let Consonant c = ng [@@warning "-8"] in - 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 g = Glyph - {empty_glyph with - tengwa = Some c - ; tehta_above = Some letter } in - g::f::[] ) - -let diphtongue - : 'a t -> 'a t -> 'a t - = fun t1 t2 -> - match t1 with - - | Consonant c-> - let semi_voyel = - Glyph - { empty_glyph with tengwa = Some c} in - Application (fun t -> semi_voyel::t2::t::[]) - | _ -> - print_endline "Ignoring diphtongue"; - Nothing - -let fold - : portant:'a consonant -> 'a t list -> string - = fun ~portant elems -> - let buff = Buffer.create 16 in - - let rec _fold - : 'a glyph option -> 'a t list -> unit - = fun init -> function - | [] -> - begin match init with - | None -> () - | Some glyph -> - repr_glyph ~portant glyph buff - end - | hd::tl -> - match init, hd with - | any, Nothing -> _fold any tl - | None, Consonant c -> - _fold - (Some {empty_glyph with tengwa = Some c}) - tl - | None, Voyel v -> - _fold - (Some ( - add_voyel_to_glyph - {empty_glyph with tehta_above = Some v} - v) ) - tl - | None, Repr r -> - Buffer.add_string buff r; - _fold - None tl - | any, Application 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 ~portant t buff; - Buffer.add_string buff s; - _fold - None - tl - | Some ({ tengwa = Some _ ; _} as t), Consonant c -> - repr_glyph ~portant t buff; - _fold - (Some {empty_glyph with tengwa = Some c}) - tl - | Some ({ tehta_below = None ; _} as t), Voyel ({position = `Below; _} as v) -> - _fold - (Some {t with tehta_below = Some v}) - tl - | Some ({ tehta_below = Some _ ; _} as t), Voyel ({position = `Below; _} as v) -> - repr_glyph ~portant t buff; - _fold - (Some {empty_glyph with tehta_below = Some v}) - tl - | Some ({ tehta_below = Some _ ; _} as t), Consonant c -> - repr_glyph ~portant t buff; - _fold - (Some {empty_glyph with tengwa = Some c}) - tl - | Some t, Voyel ({position = `Above; _} as v) -> - repr_glyph ~portant t buff; - _fold - (Some {empty_glyph with tehta_above = Some 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 ~portant g1 buff; - _fold - (Some g2) - tl - end - in - _fold None elems; - Buffer.contents buff - -let p repr muted position = Consonant - { position - ; muted - ; category = II - ; primary = true - ; repr } - -and b repr muted position = Consonant - { position - ; muted - ; category = II - ; primary = true - ; repr } - -and t repr muted position = Consonant - { position - ; muted - ; category = I - ; primary = true - ; repr } - -and d repr muted position = Consonant - { position - ; muted - ; category = I - ; primary = true - ; repr } - -and k repr muted position = Consonant - { position - ; muted - ; category = III - ; primary = true - ; repr } - -and g repr muted position = Consonant - { position - ; muted - ; category = III - ; primary = true - ; repr } - -and f repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = true - ; repr } - -and v repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = true - ; repr } - -and ch repr position = Consonant - { position - ; muted = None - ; category = III - ; primary = true - ; repr } - -and j repr position = Consonant - { position - ; muted = None - ; category = III - ; primary = true - ; repr } - -and s repr muted position = Consonant - { position - ; muted - ; category = I - ; primary = true - ; repr } - -and z repr position = Consonant - { position - ; muted = None - ; category = I - ; primary = true - ; repr } - -and m repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = true - ; repr } - -and n repr position = Consonant - { position - ; muted = None - ; category = I - ; primary = true - ; repr } - -and gn repr position = Consonant - { position - ; muted = None - ; category = III - ; primary = false - ; repr } - -and ng repr position = Consonant - { position - ; muted = None - ; category = III - ; primary = true - ; repr } - -and r repr muted position = Consonant - { position - ; muted - ; category = I - ; primary = false - ; repr } - -and semi_voyel_w repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = false - ; repr } - -and semi_voyel_y repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = false - ; repr } - -and semi_voyel_u repr position = Consonant - { position - ; muted = None - ; category = II - ; primary = false - ; repr } - -let l repr position = - let default = - { position - ; muted = None - ; category = II - ; primary = false - ; repr } in - Consonant default - -let portant repr position = - { position - ; muted = None - ; category = I - ; primary = false - ; repr } - |