summaryrefslogtreecommitdiff
path: root/src/lib/repr/rousseau.ml
diff options
context:
space:
mode:
Diffstat (limited to 'src/lib/repr/rousseau.ml')
-rw-r--r--src/lib/repr/rousseau.ml384
1 files changed, 384 insertions, 0 deletions
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 }
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-19 20:41:08 +0000