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/js/tengwar.ml | 109 +++++++------- src/lib/repr/rousseau.ml | 384 +++++++++++++++++++++++++++++++++++++++++++++++ src/lib/repr/tengwar.ml | 384 ----------------------------------------------- 3 files changed, 436 insertions(+), 441 deletions(-) create mode 100644 src/lib/repr/rousseau.ml delete mode 100644 src/lib/repr/tengwar.ml (limited to 'src') diff --git a/src/js/tengwar.ml b/src/js/tengwar.ml index 31eb1ed..4c02eeb 100644 --- a/src/js/tengwar.ml +++ b/src/js/tengwar.ml @@ -13,7 +13,7 @@ let (let=?) : 'a option -> ('a -> unit) -> unit type state = { text : (Sounds.t list, string) result - ; font : [`Telcontar | `Annatar ]} + ; font : [`Telcontar | `Annatar ] } module App = Application.Make(struct type t = state end) @@ -49,62 +49,57 @@ let init = } let main id phon tengwar font = - match (Jv.is_none id) with - | true -> Console.(error [str "No element with id '%s' found"; id]) - | false -> - - let=? source = get_element_by_id id in - let=? phon = get_element_by_id phon in - let=? tengwar = get_element_by_id tengwar in - let=? font = get_element_by_id font in - - let text_event = - Evr.on_el - Ev.input - (fun _ -> - App.E ( El.prop El.Prop.value source - , (module SetText: App.Event with type t = SetText.t )) - ) source in - - let font_event = - Evr.on_el - Ev.input - (fun _ -> - let value = El.prop El.Prop.value font in - let str = Jstr.to_string value in - App.E ( (str, tengwar) - , (module SetFont: App.Event with type t = SetFont.t )) - ) font in - - let ev = App.run - init - (E.select - [ text_event - ; font_event ] - ) in - - let log state = - let transcription = state.text in - let res1 = Result.map - (fun t-> Sounds.repr (module Repr.Default) t) - transcription in - let () = match res1 with - | Ok response -> - El.set_prop El.Prop.value (Jstr.of_string response) phon - | Error _err -> () in - let res2 = Result.map - (fun t-> - match state.font with - | `Annatar -> Sounds.repr (module Repr.Anatar) t - | `Telcontar -> Sounds.repr (module Repr.Telcontar) t) - transcription in - let () = match res2 with - | Ok response -> - El.set_prop El.Prop.value (Jstr.of_string response) tengwar - | Error _err -> () in - () - in - Logr.hold (S.log ev log) + let=? source = get_element_by_id id in + let=? phon = get_element_by_id phon in + let=? tengwar = get_element_by_id tengwar in + let=? font = get_element_by_id font in + + let text_event = + Evr.on_el + Ev.input + (fun _ -> + App.E ( El.prop El.Prop.value source + , (module SetText: App.Event with type t = SetText.t ))) + source in + + let font_event = + Evr.on_el + Ev.input + (fun _ -> + let value = El.prop El.Prop.value font in + let str = Jstr.to_string value in + App.E ( (str, tengwar) + , (module SetFont: App.Event with type t = SetFont.t ))) + font in + + let ev = App.run + init + (E.select + [ text_event + ; font_event ]) in + + let log state = + let transcription = state.text in + let res1 = Result.map + (fun t-> Sounds.repr (module Repr.Ipa) t) + transcription in + let () = match res1 with + | Ok response -> + El.set_prop El.Prop.value (Jstr.of_string response) phon + | Error _err -> () in + let res2 = Result.map + (fun t-> + match state.font with + | `Annatar -> Sounds.repr (module Repr.Anatar) t + | `Telcontar -> Sounds.repr (module Repr.Telcontar) t) + transcription in + let () = match res2 with + | Ok response -> + El.set_prop El.Prop.value (Jstr.of_string response) tengwar + | Error _err -> () in + () + in + Logr.hold (S.log ev log) let () = 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