From cdbf2fd0587131c1b9427bbf040e3f3f7405fa72 Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Mon, 24 Apr 2023 17:16:14 +0200 Subject: Review the main script --- src/lib/repr/rousseau.ml | 384 +++++++++++++++++++++++++++++++++++++++++++++++ src/lib/repr/tengwar.ml | 384 ----------------------------------------------- 2 files changed, 384 insertions(+), 384 deletions(-) create mode 100644 src/lib/repr/rousseau.ml delete mode 100644 src/lib/repr/tengwar.ml (limited to 'src/lib/repr') diff --git a/src/lib/repr/rousseau.ml b/src/lib/repr/rousseau.ml new file mode 100644 index 0000000..f9fde05 --- /dev/null +++ b/src/lib/repr/rousseau.ml @@ -0,0 +1,384 @@ +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 } + 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 } - -- cgit v1.2.3