From b3521abca5a2214742c4c3488f898e7d90be6174 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 19:44:59 +0900 Subject: [PATCH 01/78] refactor 'fontFormat{.ml,.mli}' --- src/backend/fontFormat.ml | 114 ++++++++----------------------------- src/backend/fontFormat.mli | 13 ----- src/frontend/fontInfo.ml | 50 ++++++++-------- 3 files changed, 48 insertions(+), 129 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index faa73f301..76dc49579 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -17,10 +17,6 @@ type metrics = per_mille * per_mille * per_mille type indirect = int -(* -let gid x = x (* for debug *) -*) - exception FailToLoadFontOwingToSize of file_path exception FailToLoadFontOwingToSystem of file_path * string exception BrokenFont of file_path * string @@ -69,9 +65,7 @@ type cid_system_info = { supplement : int; } -(* -let adobe_japan1 = { registry = "Adobe"; ordering = "Japan1" ; supplement = 6; } -*) + let adobe_identity = { registry = "Adobe"; ordering = "Identity"; supplement = 0; } @@ -93,7 +87,7 @@ let extract_registration d = begin match cffinfo.Otfm.cid_info with | None -> - (* -- if not a CID-keyed font -- *) + (* -- if not a CID-keyed font -- *) return adobe_identity | Some(cidinfo) -> @@ -173,9 +167,6 @@ module SubsetMap val create : int -> t val create_dummy : unit -> t val intern : original_glyph_id -> t -> subset_glyph_id -(* - val find_rev_opt : glyph_id -> t -> original_glyph_id option -*) val to_list : t -> (original_glyph_id list) option end = struct @@ -217,11 +208,6 @@ module SubsetMap gidsub end -(* - let find_rev_opt (SubsetGlyphID(_, gidsub)) (_, _, _, revht) = - GHt.find_opt revht gidsub -*) - let to_list submap = match submap with | Subset(_, _, store, _) -> Some(Alist.to_list (!store)) @@ -547,9 +533,6 @@ let get_kerning_table (d : Otfm.decoder) = in match res with | Ok() -> -(* - let () = PrintForDebug.kernE "'GPOS' exists" in (* for debug *) -*) kerntbl | Error(e) -> @@ -649,16 +632,9 @@ type font_descriptor = { descent : per_mille; stemv : float; font_data : (Otfm.decoder resource) ref; - (* temporary; should contain more fields *) + (* temporary; should contain more fields *) } -(* -let to_base85_pdf_bytes (d : Otfm.decoder) : string * Pdfio.bytes = - match Otfm.decoder_src d with - | `String(s) -> - let s85 = Base85.encode s in - ("/ASCII85Decode", Pdfio.bytes_of_string s85) -*) let to_flate_pdf_bytes (data : string) : string * Pdfio.bytes = let src_offset_ref = ref 0 in @@ -711,7 +687,7 @@ let pdfstream_of_decoder (pdf : Pdf.t) (dcdr : decoder) (subtypeopt : string opt | Ok(s) -> s end in - let (filter, bt) = (* to_base85_pdf_bytes d *) to_flate_pdf_bytes data in + let (filter, bt) = to_flate_pdf_bytes data in let len = Pdfio.bytes_size bt in let contents = [ ("/Length", Pdf.Integer(len)); @@ -744,7 +720,7 @@ let get_glyph_id_main srcpath (cmapsubtbl : Otfm.cmap_subtable) (uch : Uchar.t) ) None in match cmapres with - | Error(e) -> raise_err srcpath e (Printf.sprintf "get_glyph_id_main (cp = %d)" cp) + | Error(e) -> raise_err srcpath e (Printf.sprintf "get_glyph_id_main (cp = U+%04X)" cp) | Ok(opt) -> opt @@ -878,20 +854,6 @@ let get_glyph_advance_width (dcdr : decoder) (gidorgkey : original_glyph_id) : p | Ok(Some((adv, lsb))) -> per_mille dcdr adv - -(* -let get_truetype_widths_list (dcdr : decoder) (firstchar : int) (lastchar : int) : int list = - let rec range acc m n = - if m > n then List.rev acc else - range (m :: acc) (m + 1) n - in - (range [] firstchar lastchar) |> List.map (fun charcode -> - get_glyph_id_main dcdr.file_path dcdr.cmap_subtable (Uchar.of_int charcode) |> function - | None -> 0 - | Some(gid) -> get_glyph_advance_width dcdr gid - ) -*) - let of_per_mille = function | PerMille(x) -> Pdf.Integer(x) @@ -933,7 +895,7 @@ let font_descriptor_of_decoder (dcdr : decoder) (font_name : string) = descent = per_mille dcdr rcdhhea.Otfm.hhea_descender; stemv = 0.; (* temporary; should be gotten from decoder *) font_data = ref (Data(d)); - (* temporary; should contain more fields *) + (* temporary; should contain more fields *) } @@ -950,6 +912,7 @@ type embedding = | FontFile2 | FontFile3 of string + let font_file_info_of_embedding embedding = match embedding with | FontFile -> ("/FontFile", None) @@ -1062,7 +1025,7 @@ module CIDFontType0 font_descriptor : font_descriptor; dw : design_units option; (* represented by units defined by head.unitsPerEm *) dw2 : (int * int) option; - (* temporary; should contain more fields; /W2 *) + (* temporary; should contain more fields; /W2 *) } (* -- Doesn't have to contain information about /W entry; @@ -1082,10 +1045,12 @@ module CIDFontType0 } end + type cid_to_gid_map = | CIDToGIDIdentity | CIDToGIDStream of (string resource) ref (* temporary *) + module CIDFontType2 = struct type font = { @@ -1096,7 +1061,7 @@ module CIDFontType2 dw2 : (int * int) option; cid_to_gid_map : cid_to_gid_map; is_pure_truetype : bool; - (* temporary; should contain more fields; /W2 *) + (* temporary; should contain more fields; /W2 *) } (* -- Doesn't have to contain information about /W entry; @@ -1118,6 +1083,7 @@ module CIDFontType2 } end + type cid_font = | CIDFontType0 of CIDFontType0.font | CIDFontType2 of CIDFontType2.font @@ -1174,9 +1140,6 @@ module ToUnicodeCMap Printf.bprintf buf "%d beginbfchar" num; GHt.iter (fun gid uchlst -> let dst = (InternalText.to_utf16be_hex (InternalText.of_uchar_list uchlst)) in -(* - Format.printf "FontFormat> GID %04X -> %s\n" gid dst; (* for debug *) -*) Printf.bprintf buf "<%04X><%s>" gid dst ) ht; Printf.bprintf buf "endbfchar "; @@ -1184,13 +1147,8 @@ module ToUnicodeCMap ) touccmap; let strmain = Buffer.contents buf in let res = prefix ^ strmain ^ postfix in -(* - Format.printf "FontFormat> result:\n"; (* for debug *) - Format.printf "%s" res; (* for debug *) -*) res - end @@ -1203,7 +1161,7 @@ module Type0 } - let of_cid_font cidfont fontname cmap toucopt = + let of_cid_font cidfont fontname cmap = { base_font = fontname; encoding = cmap; @@ -1220,7 +1178,7 @@ module Type0 ("/Type" , Pdf.Name("/FontDescriptor")); ("/FontName" , Pdf.Name("/" ^ base_font)); ("/Flags" , Pdf.Integer(4)); (* temporary; should be variable *) - ("/FontBBox" , pdfobject_of_bbox fontdescr.font_bbox); (* temporary; should be variable *) + ("/FontBBox" , pdfobject_of_bbox fontdescr.font_bbox); ("/ItalicAngle", Pdf.Real(fontdescr.italic_angle)); ("/Ascent" , of_per_mille fontdescr.ascent); ("/Descent" , of_per_mille fontdescr.descent); @@ -1318,7 +1276,7 @@ module Type0 ("/DW" , of_per_mille_opt pmoptdw); ("/W" , objwarr); ("/DW2" , of_per_mille_pair_opt pmpairoptdw2); - (* temporary; should add more; /W2 *) + (* temporary; should add more; /W2 *) ] in let irdescend = Pdf.addobj pdf objdescend in @@ -1400,19 +1358,13 @@ type font = (* | TrueType of TrueType.font *) | Type0 of Type0.font -(* -let type1 ty1font = Type1(ty1font) - -let true_type trtyfont = TrueType(trtyfont) -*) let cid_font_type_0 cidty0font fontname cmap = - let toucopt = None in (* temporary; /ToUnicode; maybe should be variable *) - Type0(Type0.of_cid_font (CIDFontType0(cidty0font)) fontname cmap toucopt) + Type0(Type0.of_cid_font (CIDFontType0(cidty0font)) fontname cmap) + let cid_font_type_2 cidty2font fontname cmap = - let toucopt = None in (* temporary; /ToUnicode; maybe should be variable *) - Type0(Type0.of_cid_font (CIDFontType2(cidty2font)) fontname cmap toucopt) + Type0(Type0.of_cid_font (CIDFontType2(cidty2font)) fontname cmap) let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = @@ -1426,7 +1378,7 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = in let ligtbl = get_ligature_table submap d in let gidtbl = GlyphIDTable.create submap 256 in (* temporary; initial size of hash tables *) - let bboxtbl = GlyphBBoxTable.create 256 in (* temporary; initial size of hash tables *) + let bboxtbl = GlyphBBoxTable.create 256 in (* temporary; initial size of hash tables *) let (rcdhhea, ascent, descent) = match Otfm.hhea d with | Ok(rcdhhea) -> (rcdhhea, rcdhhea.Otfm.hhea_ascender, rcdhhea.Otfm.hhea_descender) @@ -1455,8 +1407,8 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = glyph_bbox_table = bboxtbl; charstring_info = csinfo; units_per_em = units_per_em; - default_ascent = per_mille_raw units_per_em ascent; (* -- by the unit defined in the font -- *) - default_descent = per_mille_raw units_per_em descent; (* -- by the unit defined in the font -- *) + default_ascent = per_mille_raw units_per_em ascent; + default_descent = per_mille_raw units_per_em descent; } @@ -1682,14 +1634,6 @@ let get_math_decoder (srcpath : file_path) : (math_decoder * font_registration) mathraw.Otfm.math_variants.Otfm.horiz_glyph_assoc |> assoc_to_map (fun mgconstr -> mgconstr.Otfm.math_glyph_variant_record_list) in -(* - let mbboxtbl = MathBBoxTable.create 256 (* temporary *) in - let csinfo = - match Otfm.cff d with - | Error(_) -> None - | Ok(cffinfo) -> Some(cffinfo.Otfm.charstring_info) - in -*) let sstyopt = let ( >>= ) = result_bind in let res = @@ -1712,10 +1656,6 @@ let get_math_decoder (srcpath : file_path) : (math_decoder * font_registration) math_vertical_variants = mvertvarmap; math_horizontal_variants = mhorzvarmap; math_kern_info = mkimap; -(* - math_bbox_table = mbboxtbl; - math_charstring_info = csinfo; -*) script_style_info = sstyopt; } in @@ -1725,9 +1665,7 @@ let get_math_decoder (srcpath : file_path) : (math_decoder * font_registration) let get_script_style_id (md : math_decoder) (gid : glyph_id) : glyph_id = match md.script_style_info with | None -> -(* - Format.printf "FontFormat> no ssty table\n"; (* for debug *) -*) + (* -- if the font does NOT have 'ssty' feature table -- *) gid | Some(feature_ssty) -> @@ -1757,9 +1695,8 @@ let get_math_glyph_id (md : math_decoder) (uch : Uchar.t) : glyph_id = let dcdr = md.as_normal_font in match get_glyph_id dcdr uch with | None -> -(* - let () = Format.printf "FontFormat> no glyph for U+%04x\n" (Uchar.to_int uch) in (* for debug *) -*) + Format.printf "FontFormat> no glyph for U+%04x\n" (Uchar.to_int uch); + (* temporary; should emit a warning in a more sophisticated manner *) SubsetGlyphID(0, 0) | Some(gid) -> gid @@ -1767,9 +1704,6 @@ let get_math_glyph_id (md : math_decoder) (uch : Uchar.t) : glyph_id = let get_math_script_variant (md : math_decoder) (gid : glyph_id) = let gidssty = get_script_style_id md gid in -(* - Format.printf "FontFormat> ssty %d ---> %d\n" gidorg gidssty; (* for debug *) -*) gidssty diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index 85dea4afb..d6a9c6f9f 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -8,10 +8,6 @@ type per_mille = type metrics = per_mille * per_mille * per_mille -(* -val gid : glyph_id -> int (* for debug *) -*) - val hex_of_glyph_id : glyph_id -> string type decoder @@ -81,21 +77,12 @@ type font = *) | Type0 of Type0.font -(* -val type1 : Type1.font -> font -val true_type : TrueType.font -> font -*) val cid_font_type_0 : CIDFontType0.font -> string -> cmap -> font val cid_font_type_2 : CIDFontType2.font -> string -> cmap -> font val get_glyph_metrics : decoder -> glyph_id -> metrics val get_glyph_id : decoder -> Uchar.t -> glyph_id option -(* -val adobe_japan1 : cid_system_info -*) -val adobe_identity : cid_system_info - val convert_to_ligatures : decoder -> glyph_id list -> glyph_id list val find_kerning : decoder -> glyph_id -> glyph_id -> per_mille option diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index dce419bbd..b0c3513a8 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -33,15 +33,17 @@ let get_latin1_width_list (dcdr : FontFormat.decoder) = widlst -let get_font dcdr fontreg fontname = +let get_font (dcdr : FontFormat.decoder) (fontreg : FontFormat.font_registration) (fontname : string) : FontFormat.font = let cmap = FontFormat.PredefinedCMap("Identity-H") in match fontreg with | FontFormat.CIDFontType0Registration(cidsysinfo, embedW) -> let cidty0font = FontFormat.CIDFontType0.of_decoder dcdr cidsysinfo in (FontFormat.cid_font_type_0 cidty0font fontname cmap) + | FontFormat.CIDFontType2TTRegistration(cidsysinfo, embedW) -> let cidty2font = FontFormat.CIDFontType2.of_decoder dcdr cidsysinfo true in (FontFormat.cid_font_type_2 cidty2font fontname cmap) + | FontFormat.CIDFontType2OTRegistration(cidsysinfo, embedW) -> let cidty2font = FontFormat.CIDFontType2.of_decoder dcdr cidsysinfo true (* temporary *) in (FontFormat.cid_font_type_2 cidty2font fontname cmap) @@ -97,33 +99,29 @@ module FontAbbrevHashTable ) abbrev_to_definition_hash_table init let find_opt (abbrev : font_abbrev) = - match Ht.find_opt abbrev_to_definition_hash_table abbrev with - | None -> - None - - | Some(storeref) -> - let store = !storeref in - begin - match store with - | Unused(srcpath) -> - let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in - (* -- if this is the first access to the font -- *) - begin - match FontFormat.get_decoder_single srcpath with - | None -> - raise (NotASingleFont(abbrev, srcpath)) + let open OptionMonad in + Ht.find_opt abbrev_to_definition_hash_table abbrev >>= fun storeref -> + match !storeref with + | Unused(srcpath) -> + (* -- if this is the first access to the font -- *) + let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + begin + match FontFormat.get_decoder_single srcpath with + | None -> + raise (NotASingleFont(abbrev, srcpath)) + + | Some((dcdr, fontreg)) -> + let font = get_font dcdr fontreg (abbrev ^ "-Composite") (* temporary *) in + let tag = generate_tag () in + let dfn = (tag, font, dcdr) in + let store = Loaded(dfn) in + storeref := store; + return dfn + end - | Some((dcdr, fontreg)) -> - let font = get_font dcdr fontreg (abbrev ^ "-Composite") (* temporary *) in - let tag = generate_tag () in - let dfn = (tag, font, dcdr) in - let store = Loaded(dfn) in - storeref := store; - Some(dfn) - end + | Loaded(dfn) -> + return dfn - | Loaded(dfn) -> Some(dfn) - end end From 5045266a71adf82a1dc380507a157245f6c56d63 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 20:00:48 +0900 Subject: [PATCH 02/78] refactor 'fontInfo.ml' --- src/frontend/fontInfo.ml | 108 ++++++++++++++++----------------------- 1 file changed, 45 insertions(+), 63 deletions(-) diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index b0c3513a8..475bc6bab 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -6,6 +6,7 @@ open HorzBox open Types open Config + exception InvalidFontAbbrev of font_abbrev exception InvalidMathFontAbbrev of math_font_abbrev exception NotASingleFont of font_abbrev * file_path @@ -14,25 +15,6 @@ exception NotASingleMathFont of font_abbrev * file_path type tag = string -let get_latin1_width_list (dcdr : FontFormat.decoder) = - - let rec range acc firstchar lastchar = - if firstchar > lastchar then List.rev acc else - range (firstchar :: acc) (firstchar + 1) lastchar - in - - let ucharlst = (range [] 0 255) |> List.map Uchar.of_int in - let gidoptlst = ucharlst |> List.map (FontFormat.get_glyph_id dcdr) in - let gidlst = gidoptlst |> list_some in - let widlst = - gidlst |> List.map (fun gid -> - let (w, _, _) = FontFormat.get_glyph_metrics dcdr gid in - (gid, w) - ) - in - widlst - - let get_font (dcdr : FontFormat.decoder) (fontreg : FontFormat.font_registration) (fontname : string) : FontFormat.font = let cmap = FontFormat.PredefinedCMap("Identity-H") in match fontreg with @@ -76,21 +58,21 @@ module FontAbbrevHashTable let current_tag_number = ref 0 + let initialize () = - begin - Ht.clear abbrev_to_definition_hash_table; - current_tag_number := 0; - end + Ht.clear abbrev_to_definition_hash_table; + current_tag_number := 0 + let generate_tag () = - begin - incr current_tag_number; - "/F" ^ (string_of_int !current_tag_number) - end + incr current_tag_number; + "/F" ^ (string_of_int !current_tag_number) + let add abbrev srcpath = Ht.add abbrev_to_definition_hash_table abbrev (ref (Unused(srcpath))) + let fold (f : font_abbrev -> tag * FontFormat.font * FontFormat.decoder -> 'a -> 'a) init = Ht.fold (fun abbrev storeref acc -> match !storeref with @@ -98,7 +80,8 @@ module FontAbbrevHashTable | Loaded(dfn) -> f abbrev dfn acc ) abbrev_to_definition_hash_table init - let find_opt (abbrev : font_abbrev) = + + let find_opt (abbrev : font_abbrev) : font_definition option = let open OptionMonad in Ht.find_opt abbrev_to_definition_hash_table abbrev >>= fun storeref -> match !storeref with @@ -108,6 +91,7 @@ module FontAbbrevHashTable begin match FontFormat.get_decoder_single srcpath with | None -> + (* -- if the font file is a TrueTypeCollection -- *) raise (NotASingleFont(abbrev, srcpath)) | Some((dcdr, fontreg)) -> @@ -214,21 +198,21 @@ module MathFontAbbrevHashTable let current_tag_number = ref 0 + let initialize () = - begin - Ht.clear abbrev_to_definition_hash_table; - current_tag_number := 0; - end + Ht.clear abbrev_to_definition_hash_table; + current_tag_number := 0 + let generate_tag () = - begin - incr current_tag_number; - "/M" ^ (string_of_int !current_tag_number) - end + incr current_tag_number; + "/M" ^ (string_of_int !current_tag_number) + let add mfabbrev srcpath = Ht.add abbrev_to_definition_hash_table mfabbrev (ref (UnusedMath(srcpath))) + let fold f init = Ht.fold (fun mfabbrev storeref acc -> match !storeref with @@ -236,33 +220,31 @@ module MathFontAbbrevHashTable | LoadedMath(mfdfn) -> f mfabbrev mfdfn acc ) abbrev_to_definition_hash_table init - let find_opt (mfabbrev : math_font_abbrev) = - match Ht.find_opt abbrev_to_definition_hash_table mfabbrev with - | None -> - None - - | Some(storeref) -> - begin - match !storeref with - | UnusedMath(srcpath) -> - (* -- if this is the first access to the math font -- *) - let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in - begin - match FontFormat.get_math_decoder srcpath with - | None -> - raise (NotASingleMathFont(mfabbrev, srcpath)) - - | Some((md, fontreg)) -> - let font = get_font (FontFormat.math_base_font md) fontreg (mfabbrev ^ "-Composite-Math") (* temporary *) in - let tag = generate_tag () in - let mfdfn = (tag, font, md) in - storeref := LoadedMath(mfdfn); - Some(mfdfn) - end - - | LoadedMath(mfdfn) -> - Some(mfdfn) - end + + let find_opt (mfabbrev : math_font_abbrev) : math_font_definition option = + let open OptionMonad in + Ht.find_opt abbrev_to_definition_hash_table mfabbrev >>= fun storeref -> + match !storeref with + | UnusedMath(srcpath) -> + (* -- if this is the first access to the math font -- *) + let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + begin + match FontFormat.get_math_decoder srcpath with + | None -> + (* -- if the font file is a TrueTypeCollection -- *) + raise (NotASingleMathFont(mfabbrev, srcpath)) + + | Some((md, fontreg)) -> + let font = get_font (FontFormat.math_base_font md) fontreg (mfabbrev ^ "-Composite-Math") (* temporary *) in + let tag = generate_tag () in + let mfdfn = (tag, font, md) in + storeref := LoadedMath(mfdfn); + return mfdfn + end + + | LoadedMath(mfdfn) -> + return mfdfn + end From b0969178122f93094499b223aeacebfb3cb869b9 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 20:12:49 +0900 Subject: [PATCH 03/78] refactor 'fontInfo.ml' as to 'font_definition' etc. --- src/frontend/fontInfo.ml | 63 +++++++++++++++++++++++++--------------- 1 file changed, 40 insertions(+), 23 deletions(-) diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 475bc6bab..51852474a 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -31,7 +31,11 @@ let get_font (dcdr : FontFormat.decoder) (fontreg : FontFormat.font_registration (FontFormat.cid_font_type_2 cidty2font fontname cmap) -type font_definition = tag * FontFormat.font * FontFormat.decoder +type font_definition = { + font_tag : tag; + font : FontFormat.font; + decoder : FontFormat.decoder; +} type font_store = | Unused of file_path @@ -73,7 +77,7 @@ module FontAbbrevHashTable Ht.add abbrev_to_definition_hash_table abbrev (ref (Unused(srcpath))) - let fold (f : font_abbrev -> tag * FontFormat.font * FontFormat.decoder -> 'a -> 'a) init = + let fold (f : font_abbrev -> font_definition -> 'a -> 'a) init = Ht.fold (fun abbrev storeref acc -> match !storeref with | Unused(_) -> acc (* -- ignores unused fonts -- *) @@ -97,7 +101,7 @@ module FontAbbrevHashTable | Some((dcdr, fontreg)) -> let font = get_font dcdr fontreg (abbrev ^ "-Composite") (* temporary *) in let tag = generate_tag () in - let dfn = (tag, font, dcdr) in + let dfn = { font_tag = tag; font = font; decoder = dcdr; } in let store = Loaded(dfn) in storeref := store; return dfn @@ -111,8 +115,8 @@ module FontAbbrevHashTable let get_font_tag (abbrev : font_abbrev) : tag = match FontAbbrevHashTable.find_opt abbrev with - | None -> raise (InvalidFontAbbrev(abbrev)) - | Some((tag, _, _)) -> tag + | None -> raise (InvalidFontAbbrev(abbrev)) + | Some(dfn) -> dfn.font_tag let raw_length_to_skip_length (fontsize : length) (FontFormat.PerMille(rawlen) : FontFormat.per_mille) = @@ -158,8 +162,11 @@ let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : Ou let font_abbrev = hsinfo.font_abbrev in let f_skip = raw_length_to_skip_length hsinfo.text_font_size in match FontAbbrevHashTable.find_opt font_abbrev with - | None -> raise (InvalidFontAbbrev(font_abbrev)) - | Some((_, _, dcdr)) -> + | None -> + raise (InvalidFontAbbrev(font_abbrev)) + + | Some(dfn) -> + let dcdr = dfn.decoder in let gidoptlst = uchlst |> List.map (FontFormat.get_glyph_id dcdr) in let gidlst = list_some gidoptlst in (* needs reconsideration; maybe should return GID 0 for code points which is not covered by the font *) @@ -171,7 +178,11 @@ let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : Ou (otxt, wid, Length.max (hgtsub +% rising) Length.zero, Length.min (dptsub +% rising) Length.zero) -type math_font_definition = tag * FontFormat.font * FontFormat.math_decoder +type math_font_definition = { + math_font_tag : tag; + math_font : FontFormat.font; + math_decoder : FontFormat.math_decoder; +} type math_font_store = | UnusedMath of file_path @@ -237,7 +248,7 @@ module MathFontAbbrevHashTable | Some((md, fontreg)) -> let font = get_font (FontFormat.math_base_font md) fontreg (mfabbrev ^ "-Composite-Math") (* temporary *) in let tag = generate_tag () in - let mfdfn = (tag, font, md) in + let mfdfn = { math_font_tag = tag; math_font = font; math_decoder = md; } in storeref := LoadedMath(mfdfn); return mfdfn end @@ -250,8 +261,8 @@ module MathFontAbbrevHashTable let find_math_decoder_exn mfabbrev = match MathFontAbbrevHashTable.find_opt mfabbrev with - | None -> raise (InvalidMathFontAbbrev(mfabbrev)) - | Some((_, _, md)) -> md + | None -> raise (InvalidMathFontAbbrev(mfabbrev)) + | Some(mfdfn) -> mfdfn.math_decoder let actual_math_font_size mathctx = @@ -268,8 +279,8 @@ let get_math_string_info mathctx : math_string_info = let get_math_tag mfabbrev = match MathFontAbbrevHashTable.find_opt mfabbrev with - | None -> raise (InvalidMathFontAbbrev(mfabbrev)) - | Some((tag, _, _)) -> tag + | None -> raise (InvalidMathFontAbbrev(mfabbrev)) + | Some(mfdfn) -> mfdfn.math_font_tag let get_math_constants mathctx = @@ -296,8 +307,8 @@ let get_axis_height (mfabbrev : math_font_abbrev) (fontsize : length) : length = | None -> raise (InvalidMathFontAbbrev(mfabbrev)) - | Some((_, _, md)) -> - let ratio = FontFormat.get_axis_height_ratio md in + | Some(mfdfn) -> + let ratio = FontFormat.get_axis_height_ratio mfdfn.math_decoder in fontsize *% ratio (* -- @@ -312,7 +323,8 @@ let get_math_kern (mathctx : math_context) (mkern : math_kern_scheme) (corrhgt : | None -> raise (InvalidMathFontAbbrev(mfabbrev)) - | Some((_, _, md)) -> + | Some(mfdfn) -> + let md = mfdfn.math_decoder in begin match mkern with | NoMathKern -> Length.zero @@ -327,7 +339,8 @@ let get_math_char_info (mathctx : math_context) (is_in_display : bool) (is_big : | None -> raise (InvalidFontAbbrev(mfabbrev)) - | Some((_, _, md)) -> + | Some(mfdfn) -> + let md = mfdfn.math_decoder in let gidlst = uchlst |> List.map (fun uch -> let gidraw = FontFormat.get_math_glyph_id md uch in @@ -381,13 +394,17 @@ let make_dictionary (pdf : Pdf.t) (fontdfn : FontFormat.font) (dcdr : FontFormat let get_font_dictionary (pdf : Pdf.t) : Pdf.pdfobject = let keyval = - [] |> FontAbbrevHashTable.fold (fun _ tuple acc -> - let (tag, fontdfn, dcdr) = tuple in - let obj = make_dictionary pdf fontdfn dcdr in + [] |> FontAbbrevHashTable.fold (fun _ dfn acc -> + let tag = dfn.font_tag in + let font = dfn.font in + let dcdr = dfn.decoder in + let obj = make_dictionary pdf font dcdr in (tag, obj) :: acc - ) |> MathFontAbbrevHashTable.fold (fun _ mftuple acc -> - let (tag, fontdfn, md) = mftuple in - let obj = make_dictionary pdf fontdfn (FontFormat.math_base_font md) in + ) |> MathFontAbbrevHashTable.fold (fun _ mfdfn acc -> + let tag = mfdfn.math_font_tag in + let font = mfdfn.math_font in + let md = mfdfn.math_decoder in + let obj = make_dictionary pdf font (FontFormat.math_base_font md) in (tag, obj) :: acc ) in From b47a297700dcc4cb8bbdb63635ddd06cf5f140b5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 20:36:28 +0900 Subject: [PATCH 04/78] refactor 'fontInfo.ml' and 'fontFormat.ml' --- src/backend/fontFormat.ml | 26 +++++++++++++--- src/backend/fontFormat.mli | 15 +++++---- src/frontend/fontInfo.ml | 62 +++++++++----------------------------- 3 files changed, 44 insertions(+), 59 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 76dc49579..b0101fa64 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -1412,11 +1412,27 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = } -let get_decoder_single (srcpath : file_path) : (decoder * font_registration) option = +let get_font (dcdr : decoder) (fontreg : font_registration) (fontname : string) : font = + let cmap = PredefinedCMap("Identity-H") in + match fontreg with + | CIDFontType0Registration(cidsysinfo, embedW) -> + let cidty0font = CIDFontType0.of_decoder dcdr cidsysinfo in + (cid_font_type_0 cidty0font fontname cmap) + + | CIDFontType2TTRegistration(cidsysinfo, embedW) -> + let cidty2font = CIDFontType2.of_decoder dcdr cidsysinfo true in + (cid_font_type_2 cidty2font fontname cmap) + + | CIDFontType2OTRegistration(cidsysinfo, embedW) -> + let cidty2font = CIDFontType2.of_decoder dcdr cidsysinfo true (* temporary *) in + (cid_font_type_2 cidty2font fontname cmap) + + +let get_decoder_single (fontname : string) (srcpath : file_path) : (decoder * font) option = match get_main_decoder_single srcpath with | Error(oerr) -> raise_err srcpath oerr "get_decoder_single" | Ok(None) -> None - | Ok(Some((d, fontreg))) -> Some((make_decoder srcpath d, fontreg)) + | Ok(Some((d, fontreg))) -> let dcdr = make_decoder srcpath d in Some((dcdr, get_font dcdr fontreg fontname)) let get_decoder_ttc (srcpath :file_path) (i : int) : (decoder * font_registration) option = @@ -1609,9 +1625,9 @@ let assoc_to_map f gidassoc = ) MathInfoMap.empty -let get_math_decoder (srcpath : file_path) : (math_decoder * font_registration) option = +let get_math_decoder (fontname : string) (srcpath : file_path) : (math_decoder * font) option = let open OptionMonad in - (get_decoder_single srcpath) >>= fun (dcdr, fontreg) -> + get_decoder_single fontname srcpath >>= fun (dcdr, font) -> let d = dcdr.main in match Otfm.math d with | Error(oerr) -> @@ -1659,7 +1675,7 @@ let get_math_decoder (srcpath : file_path) : (math_decoder * font_registration) script_style_info = sstyopt; } in - Some((md, fontreg)) + Some((md, font)) let get_script_style_id (md : math_decoder) (gid : glyph_id) : glyph_id = diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index d6a9c6f9f..df5b327a5 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -17,6 +17,7 @@ exception FailToLoadFontOwingToSystem of file_path * string exception BrokenFont of file_path * string exception CannotFindUnicodeCmap of file_path +(* type cid_system_info type font_registration = @@ -26,9 +27,7 @@ type font_registration = (* -- last boolean: true iff it should embed /W information -- *) | CIDFontType2TTRegistration of cid_system_info * bool (* -- last boolean: true iff it should embed /W information -- *) - -val get_decoder_single : file_path -> (decoder * font_registration) option - +*) type 'a resource = | Data of 'a | EmbeddedStream of int @@ -51,11 +50,13 @@ module TrueType : sig val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject end *) + module Type0 : sig type font val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject end +(* module CIDFontType0 : sig type font val of_decoder : decoder -> cid_system_info -> font @@ -69,7 +70,7 @@ end type cid_font = | CIDFontType0 of CIDFontType0.font | CIDFontType2 of CIDFontType2.font - +*) type font = (* | Type1 of Type1.font @@ -77,9 +78,11 @@ type font = *) | Type0 of Type0.font +val get_decoder_single : string -> file_path -> (decoder * font) option +(* val cid_font_type_0 : CIDFontType0.font -> string -> cmap -> font val cid_font_type_2 : CIDFontType2.font -> string -> cmap -> font - +*) val get_glyph_metrics : decoder -> glyph_id -> metrics val get_glyph_id : decoder -> Uchar.t -> glyph_id option @@ -99,7 +102,7 @@ type math_kern_info = type math_decoder -val get_math_decoder : file_path -> (math_decoder * font_registration) option +val get_math_decoder : string -> file_path -> (math_decoder * font) option val math_base_font : math_decoder -> decoder diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 51852474a..bebccc489 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -15,22 +15,6 @@ exception NotASingleMathFont of font_abbrev * file_path type tag = string -let get_font (dcdr : FontFormat.decoder) (fontreg : FontFormat.font_registration) (fontname : string) : FontFormat.font = - let cmap = FontFormat.PredefinedCMap("Identity-H") in - match fontreg with - | FontFormat.CIDFontType0Registration(cidsysinfo, embedW) -> - let cidty0font = FontFormat.CIDFontType0.of_decoder dcdr cidsysinfo in - (FontFormat.cid_font_type_0 cidty0font fontname cmap) - - | FontFormat.CIDFontType2TTRegistration(cidsysinfo, embedW) -> - let cidty2font = FontFormat.CIDFontType2.of_decoder dcdr cidsysinfo true in - (FontFormat.cid_font_type_2 cidty2font fontname cmap) - - | FontFormat.CIDFontType2OTRegistration(cidsysinfo, embedW) -> - let cidty2font = FontFormat.CIDFontType2.of_decoder dcdr cidsysinfo true (* temporary *) in - (FontFormat.cid_font_type_2 cidty2font fontname cmap) - - type font_definition = { font_tag : tag; font : FontFormat.font; @@ -93,13 +77,12 @@ module FontAbbrevHashTable (* -- if this is the first access to the font -- *) let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in begin - match FontFormat.get_decoder_single srcpath with + match FontFormat.get_decoder_single (abbrev ^ "-Composite") (* temporary *) srcpath with | None -> (* -- if the font file is a TrueTypeCollection -- *) raise (NotASingleFont(abbrev, srcpath)) - | Some((dcdr, fontreg)) -> - let font = get_font dcdr fontreg (abbrev ^ "-Composite") (* temporary *) in + | Some((dcdr, font)) -> let tag = generate_tag () in let dfn = { font_tag = tag; font = font; decoder = dcdr; } in let store = Loaded(dfn) in @@ -240,13 +223,12 @@ module MathFontAbbrevHashTable (* -- if this is the first access to the math font -- *) let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in begin - match FontFormat.get_math_decoder srcpath with + match FontFormat.get_math_decoder (mfabbrev ^ "-Composite-Math") (* temporary *) srcpath with | None -> (* -- if the font file is a TrueTypeCollection -- *) raise (NotASingleMathFont(mfabbrev, srcpath)) - | Some((md, fontreg)) -> - let font = get_font (FontFormat.math_base_font md) fontreg (mfabbrev ^ "-Composite-Math") (* temporary *) in + | Some((md, font)) -> let tag = generate_tag () in let mfdfn = { math_font_tag = tag; math_font = font; math_decoder = md; } in storeref := LoadedMath(mfdfn); @@ -412,32 +394,16 @@ let get_font_dictionary (pdf : Pdf.t) : Pdf.pdfobject = let initialize () = - - begin - FontAbbrevHashTable.initialize (); - MathFontAbbrevHashTable.initialize (); -(* - PrintForDebug.initfontE "!!ScriptDataMap"; -*) - let filename_S = resolve_dist_path "dist/unidata/Scripts.txt" in - let filename_EAW = resolve_dist_path "dist/unidata/EastAsianWidth.txt" in - ScriptDataMap.set_from_file filename_S filename_EAW; -(* - PrintForDebug.initfontE "!!LineBreakDataMap"; -*) - LineBreakDataMap.set_from_file (resolve_dist_path "dist/unidata/LineBreak.txt"); -(* - PrintForDebug.initfontE "!!begin initialize"; (* for debug *) -*) - let font_hash = LoadFont.main "fonts.satysfi-hash" in - List.iter (fun (abbrev, srcpath) -> FontAbbrevHashTable.add abbrev srcpath) font_hash; - - let math_font_hash = LoadFont.main "mathfonts.satysfi-hash" in - List.iter (fun (mfabbrev, srcfile) -> MathFontAbbrevHashTable.add mfabbrev srcfile) math_font_hash; -(* - PrintForDebug.initfontE "!!end initialize" (* for debug *) -*) - end + FontAbbrevHashTable.initialize (); + MathFontAbbrevHashTable.initialize (); + let filename_S = resolve_dist_path "dist/unidata/Scripts.txt" in + let filename_EAW = resolve_dist_path "dist/unidata/EastAsianWidth.txt" in + ScriptDataMap.set_from_file filename_S filename_EAW; + LineBreakDataMap.set_from_file (resolve_dist_path "dist/unidata/LineBreak.txt"); + let font_hash = LoadFont.main "fonts.satysfi-hash" in + List.iter (fun (abbrev, srcpath) -> FontAbbrevHashTable.add abbrev srcpath) font_hash; + let math_font_hash = LoadFont.main "mathfonts.satysfi-hash" in + List.iter (fun (mfabbrev, srcfile) -> MathFontAbbrevHashTable.add mfabbrev srcfile) math_font_hash; (* -- following are operations about handling glyphs -- *) From 9fdd47b66c217c663b3d60ea4b7bb57b222f4d1e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 20:38:35 +0900 Subject: [PATCH 05/78] omit unnecessary declaration from interface 'fontFormat.mli' --- src/backend/fontFormat.mli | 49 ++------------------------------------ src/frontend/fontInfo.ml | 4 ++-- 2 files changed, 4 insertions(+), 49 deletions(-) diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index df5b327a5..1fcaace6e 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -17,17 +17,6 @@ exception FailToLoadFontOwingToSystem of file_path * string exception BrokenFont of file_path * string exception CannotFindUnicodeCmap of file_path -(* -type cid_system_info - -type font_registration = - | CIDFontType0Registration of cid_system_info * bool - (* -- last boolean: true iff it should embed /W information -- *) - | CIDFontType2OTRegistration of cid_system_info * bool - (* -- last boolean: true iff it should embed /W information -- *) - | CIDFontType2TTRegistration of cid_system_info * bool - (* -- last boolean: true iff it should embed /W information -- *) -*) type 'a resource = | Data of 'a | EmbeddedStream of int @@ -37,53 +26,19 @@ type cmap = (* | CMapFile of (string resource) ref (* temporary;*) *) -(* -module Type1 : sig - type font - val of_decoder : decoder -> int -> int -> font - val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject -end - -module TrueType : sig - type font - val of_decoder : decoder -> int -> int -> font - val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject -end -*) module Type0 : sig type font val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject end -(* -module CIDFontType0 : sig - type font - val of_decoder : decoder -> cid_system_info -> font -end - -module CIDFontType2 : sig - type font - val of_decoder : decoder -> cid_system_info -> bool -> font -end - -type cid_font = - | CIDFontType0 of CIDFontType0.font - | CIDFontType2 of CIDFontType2.font -*) type font = -(* - | Type1 of Type1.font - | TrueType of TrueType.font -*) | Type0 of Type0.font val get_decoder_single : string -> file_path -> (decoder * font) option -(* -val cid_font_type_0 : CIDFontType0.font -> string -> cmap -> font -val cid_font_type_2 : CIDFontType2.font -> string -> cmap -> font -*) + val get_glyph_metrics : decoder -> glyph_id -> metrics + val get_glyph_id : decoder -> Uchar.t -> glyph_id option val convert_to_ligatures : decoder -> glyph_id list -> glyph_id list diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index bebccc489..3e7b22df8 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -365,8 +365,8 @@ let get_math_char_info (mathctx : math_context) (is_in_display : bool) (is_big : (otxt, f_skip rawwid, f_skip rawhgt, f_skip rawdpt, mic, rawmkiopt) -let make_dictionary (pdf : Pdf.t) (fontdfn : FontFormat.font) (dcdr : FontFormat.decoder) : Pdf.pdfobject = - match fontdfn with +let make_dictionary (pdf : Pdf.t) (font : FontFormat.font) (dcdr : FontFormat.decoder) : Pdf.pdfobject = + match font with (* | FontFormat.Type1(ty1font) -> FontFormat.Type1.to_pdfdict pdf ty1font dcdr | FontFormat.TrueType(trtyfont) -> FontFormat.TrueType.to_pdfdict pdf trtyfont dcdr From 0abb2bc9eef0a00a7acfeaa5a07c57dcdeb83ed3 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 10 Aug 2018 21:22:46 +0900 Subject: [PATCH 06/78] add 'FontFormat.get_decoder_ttc' --- src/backend/fontFormat.ml | 76 ++++++++++++++++++++++---------------- src/backend/fontFormat.mli | 10 ++--- src/frontend/fontInfo.ml | 13 +------ 3 files changed, 51 insertions(+), 48 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index b0101fa64..7f4e9e62b 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -82,29 +82,27 @@ let extract_registration d = let open ResultMonad in Otfm.flavour d >>= function | Otfm.CFF -> - begin - Otfm.cff d >>= fun cffinfo -> - begin - match cffinfo.Otfm.cid_info with - | None -> - (* -- if not a CID-keyed font -- *) - return adobe_identity - - | Some(cidinfo) -> - return { - registry = cidinfo.Otfm.registry; - ordering = cidinfo.Otfm.ordering; - supplement = cidinfo.Otfm.supplement; - } - end >>= fun cidsysinfo -> - return (Some((d, CIDFontType0Registration(cidsysinfo, true)))) - end + Otfm.cff d >>= fun cffinfo -> + let cidsysinfo = + match cffinfo.Otfm.cid_info with + | None -> + (* -- if not a CID-keyed font -- *) + adobe_identity + + | Some(cidinfo) -> + { + registry = cidinfo.Otfm.registry; + ordering = cidinfo.Otfm.ordering; + supplement = cidinfo.Otfm.supplement; + } + in + return (d, CIDFontType0Registration(cidsysinfo, true)) | Otfm.TTF_OT -> - return (Some((d, CIDFontType2OTRegistration(adobe_identity, true)))) + return (d, CIDFontType2OTRegistration(adobe_identity, true)) | Otfm.TTF_true -> - return (Some((d, CIDFontType2TTRegistration(adobe_identity, true)))) + return (d, CIDFontType2TTRegistration(adobe_identity, true)) let get_main_decoder_single (src : file_path) : ((Otfm.decoder * font_registration) option) ok = @@ -112,7 +110,7 @@ let get_main_decoder_single (src : file_path) : ((Otfm.decoder * font_registrati let open ResultMonad in Otfm.decoder (`String(s)) >>= function | Otfm.TrueTypeCollection(_) -> return None - | Otfm.SingleDecoder(d) -> extract_registration d + | Otfm.SingleDecoder(d) -> extract_registration d >>= fun pair -> return (Some(pair)) let get_main_decoder_ttc (src : file_path) (i : int) : ((Otfm.decoder * font_registration) option) ok = @@ -123,9 +121,16 @@ let get_main_decoder_ttc (src : file_path) (i : int) : ((Otfm.decoder * font_reg return None | Otfm.TrueTypeCollection(ttc) -> - let ttcelem = List.nth ttc i in - Otfm.decoder_of_ttc_element ttcelem >>= fun d -> - extract_registration d + begin + match List.nth_opt ttc i with + | None -> + return None + + | Some(ttcelem) -> + Otfm.decoder_of_ttc_element ttcelem >>= fun d -> + extract_registration d >>= fun pair -> + return (Some(pair)) + end module UHt = Hashtbl.Make @@ -1359,12 +1364,13 @@ type font = | Type0 of Type0.font -let cid_font_type_0 cidty0font fontname cmap = - Type0(Type0.of_cid_font (CIDFontType0(cidty0font)) fontname cmap) - - -let cid_font_type_2 cidty2font fontname cmap = - Type0(Type0.of_cid_font (CIDFontType2(cidty2font)) fontname cmap) +let make_dictionary (pdf : Pdf.t) (font : font) (dcdr : decoder) : Pdf.pdfobject = + match font with +(* + | FontFormat.Type1(ty1font) -> FontFormat.Type1.to_pdfdict pdf ty1font dcdr + | FontFormat.TrueType(trtyfont) -> FontFormat.TrueType.to_pdfdict pdf trtyfont dcdr +*) + | Type0(ty0font) -> Type0.to_pdfdict pdf ty0font dcdr let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = @@ -1412,6 +1418,14 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = } +let cid_font_type_0 cidty0font fontname cmap = + Type0(Type0.of_cid_font (CIDFontType0(cidty0font)) fontname cmap) + + +let cid_font_type_2 cidty2font fontname cmap = + Type0(Type0.of_cid_font (CIDFontType2(cidty2font)) fontname cmap) + + let get_font (dcdr : decoder) (fontreg : font_registration) (fontname : string) : font = let cmap = PredefinedCMap("Identity-H") in match fontreg with @@ -1435,11 +1449,11 @@ let get_decoder_single (fontname : string) (srcpath : file_path) : (decoder * fo | Ok(Some((d, fontreg))) -> let dcdr = make_decoder srcpath d in Some((dcdr, get_font dcdr fontreg fontname)) -let get_decoder_ttc (srcpath :file_path) (i : int) : (decoder * font_registration) option = +let get_decoder_ttc (fontname : string) (srcpath :file_path) (i : int) : (decoder * font) option = match get_main_decoder_ttc srcpath i with | Error(oerr) -> raise_err srcpath oerr "get_decoder_ttc" | Ok(None) -> None - | Ok(Some((d, fontreg))) -> Some((make_decoder srcpath d, fontreg)) + | Ok(Some((d, fontreg))) -> let dcdr = make_decoder srcpath d in Some((dcdr, get_font dcdr fontreg fontname)) let convert_to_ligatures (dcdr : decoder) (gidlst : glyph_id list) : glyph_id list = diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index 1fcaace6e..ae47a80a3 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -27,16 +27,14 @@ type cmap = | CMapFile of (string resource) ref (* temporary;*) *) -module Type0 : sig - type font - val to_pdfdict : Pdf.t -> font -> decoder -> Pdf.pdfobject -end +type font -type font = - | Type0 of Type0.font +val make_dictionary : Pdf.t -> font -> decoder -> Pdf.pdfobject val get_decoder_single : string -> file_path -> (decoder * font) option +val get_decoder_ttc : string -> file_path -> int -> (decoder * font) option + val get_glyph_metrics : decoder -> glyph_id -> metrics val get_glyph_id : decoder -> Uchar.t -> glyph_id option diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 3e7b22df8..affe85400 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -365,28 +365,19 @@ let get_math_char_info (mathctx : math_context) (is_in_display : bool) (is_big : (otxt, f_skip rawwid, f_skip rawhgt, f_skip rawdpt, mic, rawmkiopt) -let make_dictionary (pdf : Pdf.t) (font : FontFormat.font) (dcdr : FontFormat.decoder) : Pdf.pdfobject = - match font with -(* - | FontFormat.Type1(ty1font) -> FontFormat.Type1.to_pdfdict pdf ty1font dcdr - | FontFormat.TrueType(trtyfont) -> FontFormat.TrueType.to_pdfdict pdf trtyfont dcdr -*) - | FontFormat.Type0(ty0font) -> FontFormat.Type0.to_pdfdict pdf ty0font dcdr - - let get_font_dictionary (pdf : Pdf.t) : Pdf.pdfobject = let keyval = [] |> FontAbbrevHashTable.fold (fun _ dfn acc -> let tag = dfn.font_tag in let font = dfn.font in let dcdr = dfn.decoder in - let obj = make_dictionary pdf font dcdr in + let obj = FontFormat.make_dictionary pdf font dcdr in (tag, obj) :: acc ) |> MathFontAbbrevHashTable.fold (fun _ mfdfn acc -> let tag = mfdfn.math_font_tag in let font = mfdfn.math_font in let md = mfdfn.math_decoder in - let obj = make_dictionary pdf font (FontFormat.math_base_font md) in + let obj = FontFormat.make_dictionary pdf font (FontFormat.math_base_font md) in (tag, obj) :: acc ) in From a304d5c6411e9f4ff0f91c52aed4ed0d6671da8e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 11 Aug 2018 04:06:39 +0900 Subject: [PATCH 07/78] support TrueTypeCollection that has TrueType outlines --- src/backend/loadFont.ml | 64 ++++++++++++++++++++++++++++++++++------ src/backend/loadFont.mli | 6 +++- src/frontend/fontInfo.ml | 54 ++++++++++++++++++++++++++------- 3 files changed, 103 insertions(+), 21 deletions(-) diff --git a/src/backend/loadFont.ml b/src/backend/loadFont.ml index e34d72480..1b5526c9a 100644 --- a/src/backend/loadFont.ml +++ b/src/backend/loadFont.ml @@ -1,4 +1,5 @@ open Config +open MyUtil type file_path = string type dir_path = string @@ -13,14 +14,19 @@ exception UnexpectedYOJSONValue of file_path * font_abbrev * string * exception MissingRequiredYOJSONKey of file_path * font_abbrev * string +type data = + | Single of string + | Collection of string * int + + let read_assoc_single (srcpath : file_path) (abbrev : font_abbrev) assoc = let opt = assoc |> List.fold_left (fun opt pair -> match pair with - | ("src-dist", `String(data)) -> + | ("src-dist", `String(path)) -> begin match opt with - | None -> Some(data) + | None -> Some(path) | Some(_) -> raise (MultipleDesignation(srcpath, abbrev, "src-dist")) end @@ -29,11 +35,47 @@ let read_assoc_single (srcpath : file_path) (abbrev : font_abbrev) assoc = | (keyerr, _) -> raise (UnexpectedYOJSONKey(srcpath, abbrev, keyerr)) + ) None in match opt with | None -> raise (MissingRequiredYOJSONKey(srcpath, abbrev, "src-dist")) - | Some(data) -> data + | Some(path) -> Single(path) + + +let read_assoc_ttc (srcpath : file_path) (abbrev : font_abbrev) assoc = + let opts = + assoc |> List.fold_left (fun (pathopt, iopt) pair -> + match pair with + | ("src-dist", `String(path)) -> + begin + match pathopt with + | None -> (Some(path), iopt) + | Some(_) -> raise (MultipleDesignation(srcpath, abbrev, "src-dist")) + end + + | ("src-dist", jsonerr) -> + raise (UnexpectedYOJSONValue(srcpath, abbrev, "src-dist", Yojson.Safe.to_string jsonerr)) + + | ("index", `Int(i)) -> + begin + match iopt with + | None -> (pathopt, Some(i)) + | Some(_) -> raise (MultipleDesignation(srcpath, abbrev, "index")) + end + + | ("index", jsonerr) -> + raise (UnexpectedYOJSONValue(srcpath, abbrev, "index", Yojson.Safe.to_string jsonerr)) + + | (keyerr, _) -> + raise (UnexpectedYOJSONKey(srcpath, abbrev, keyerr)) + + ) (None, None) + in + match opts with + | (Some(path), Some(i)) -> Collection(path, i) + | (None, _) -> raise (MissingRequiredYOJSONKey(srcpath, abbrev, "src-dist")) + | (Some(_), _) -> raise (MissingRequiredYOJSONKey(srcpath, abbrev, "index")) let read_assoc (srcpath : file_path) assoc = @@ -43,8 +85,12 @@ let read_assoc (srcpath : file_path) assoc = let data = read_assoc_single srcpath abbrev assocsingle in Alist.extend acc (abbrev, data) - | json_other -> - raise (FontHashElementOtherThanVariant(srcpath, abbrev, Yojson.Safe.to_string json_other)) + | `Variant("Collection", Some(`Assoc(assocttc))) -> + let data = read_assoc_ttc srcpath abbrev assocttc in + Alist.extend acc (abbrev, data) + + | _ -> + raise (FontHashElementOtherThanVariant(srcpath, abbrev, Yojson.Safe.to_string json)) ) Alist.empty |> Alist.to_list @@ -56,8 +102,8 @@ let main (filename : file_path) = try let json = Yojson.Safe.from_file srcpath in (* -- may raise 'Sys_error', or 'Yojson.Json_error' -- *) - match json with - | `Assoc(assoc) -> read_assoc srcpath assoc - | json_other -> raise (FontHashOtherThanDictionary(srcpath)) + let assoc = Yojson.Safe.Util.to_assoc json in + read_assoc srcpath assoc with - | Yojson.Json_error(msg) -> raise (InvalidYOJSON(srcpath, msg)) + | Yojson.Json_error(msg) -> raise (InvalidYOJSON(srcpath, msg)) + | Yojson.Safe.Util.Type_error(msg, json) -> raise (InvalidYOJSON(srcpath, msg)) diff --git a/src/backend/loadFont.mli b/src/backend/loadFont.mli index 6402155fc..b14bd8336 100644 --- a/src/backend/loadFont.mli +++ b/src/backend/loadFont.mli @@ -11,4 +11,8 @@ exception UnexpectedYOJSONKey of file_path * font_abbrev * string exception UnexpectedYOJSONValue of file_path * font_abbrev * string * string exception MissingRequiredYOJSONKey of file_path * font_abbrev * string -val main : file_path -> (font_abbrev * file_path) list +type data = + | Single of file_path + | Collection of file_path * int + +val main : file_path -> (font_abbrev * data) list diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index affe85400..ac534065c 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -10,6 +10,7 @@ open Config exception InvalidFontAbbrev of font_abbrev exception InvalidMathFontAbbrev of math_font_abbrev exception NotASingleFont of font_abbrev * file_path +exception NotATTCElement of font_abbrev * file_path * int exception NotASingleMathFont of font_abbrev * file_path type tag = string @@ -22,14 +23,16 @@ type font_definition = { } type font_store = - | Unused of file_path - | Loaded of font_definition + | UnusedSingle of file_path + | UnusedTTC of file_path * int + | Loaded of font_definition module FontAbbrevHashTable : sig val initialize : unit -> unit - val add : font_abbrev -> file_path -> unit + val add_single : font_abbrev -> file_path -> unit + val add_ttc : font_abbrev -> file_path -> int -> unit val fold : (font_abbrev -> font_definition -> 'a -> 'a) -> 'a -> 'a val find_opt : font_abbrev -> font_definition option end @@ -57,15 +60,20 @@ module FontAbbrevHashTable "/F" ^ (string_of_int !current_tag_number) - let add abbrev srcpath = - Ht.add abbrev_to_definition_hash_table abbrev (ref (Unused(srcpath))) + let add_single abbrev srcpath = + Ht.add abbrev_to_definition_hash_table abbrev (ref (UnusedSingle(srcpath))) + + + let add_ttc abbrev srcpath i = + Ht.add abbrev_to_definition_hash_table abbrev (ref (UnusedTTC(srcpath, i))) let fold (f : font_abbrev -> font_definition -> 'a -> 'a) init = Ht.fold (fun abbrev storeref acc -> match !storeref with - | Unused(_) -> acc (* -- ignores unused fonts -- *) - | Loaded(dfn) -> f abbrev dfn acc + | UnusedSingle(_) -> acc (* -- ignores unused fonts -- *) + | UnusedTTC(_, _) -> acc + | Loaded(dfn) -> f abbrev dfn acc ) abbrev_to_definition_hash_table init @@ -73,8 +81,8 @@ module FontAbbrevHashTable let open OptionMonad in Ht.find_opt abbrev_to_definition_hash_table abbrev >>= fun storeref -> match !storeref with - | Unused(srcpath) -> - (* -- if this is the first access to the font -- *) + | UnusedSingle(srcpath) -> + (* -- if this is the first access to the single font -- *) let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in begin match FontFormat.get_decoder_single (abbrev ^ "-Composite") (* temporary *) srcpath with @@ -90,6 +98,22 @@ module FontAbbrevHashTable return dfn end + | UnusedTTC(srcpath, i) -> + (* -- if this is the first access to the TrueTypeCollection -- *) + let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + begin + match FontFormat.get_decoder_ttc (abbrev ^ "-Composite") (* temporary *) srcpath i with + | None -> + raise (NotATTCElement(abbrev, srcpath, i)) + + | Some((dcdr, font)) -> + let tag = generate_tag () in + let dfn = { font_tag = tag; font = font; decoder = dcdr; } in + let store = Loaded(dfn) in + storeref := store; + return dfn + end + | Loaded(dfn) -> return dfn @@ -392,9 +416,17 @@ let initialize () = ScriptDataMap.set_from_file filename_S filename_EAW; LineBreakDataMap.set_from_file (resolve_dist_path "dist/unidata/LineBreak.txt"); let font_hash = LoadFont.main "fonts.satysfi-hash" in - List.iter (fun (abbrev, srcpath) -> FontAbbrevHashTable.add abbrev srcpath) font_hash; + font_hash |> List.iter (fun (abbrev, data) -> + match data with + | LoadFont.Single(srcpath) -> FontAbbrevHashTable.add_single abbrev srcpath + | LoadFont.Collection(srcpath, i) -> FontAbbrevHashTable.add_ttc abbrev srcpath i + ); let math_font_hash = LoadFont.main "mathfonts.satysfi-hash" in - List.iter (fun (mfabbrev, srcfile) -> MathFontAbbrevHashTable.add mfabbrev srcfile) math_font_hash; + math_font_hash |> List.iter (fun (mfabbrev, data) -> + match data with + | LoadFont.Single(srcpath) -> MathFontAbbrevHashTable.add mfabbrev srcpath + | LoadFont.Collection(srcpath, i) -> failwith "TTC math font; remains to be implemented." + ); (* -- following are operations about handling glyphs -- *) From 15d436c12d71a6020293056647f45e4b1b9a8243 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 11 Aug 2018 04:23:54 +0900 Subject: [PATCH 08/78] refactor 'LigatureTable' --- src/backend/fontFormat.ml | 43 ++++++++++++++++++++++++++++++--------- 1 file changed, 33 insertions(+), 10 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 7f4e9e62b..f6214f0c3 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -313,30 +313,45 @@ type ligature_matching = module LigatureTable : sig + type single = { + tail : original_glyph_id list; + ligature : original_glyph_id; + } type t val create : subset_map -> int -> t - val add : original_glyph_id -> (original_glyph_id list * original_glyph_id) list -> t -> unit + val add : original_glyph_id -> single list -> t -> unit val fold_rev : (original_glyph_id -> original_glyph_id list -> 'a -> 'a) -> 'a -> t -> 'a val match_prefix : original_glyph_id list -> t -> ligature_matching end = struct - type entry = (original_glyph_id list * original_glyph_id) list - (* -- pairs of the tail GID array and the GID of the resulting ligature -- *) + type single = { + tail : original_glyph_id list; + ligature : original_glyph_id; + } + (* -- pair of the tail GID array and the GID of the resulting ligature -- *) - type t = subset_map * entry GHt.t * (original_glyph_id list) GHt.t + type t = { + subset_map : subset_map; + entry_table : (single list) GHt.t; + rev_table : (original_glyph_id list) GHt.t; + } let create submap n = let htmain = GHt.create n in let htrev = GHt.create n in - (submap, htmain, htrev) + { subset_map = submap; entry_table = htmain; rev_table = htrev; } - let add gidorg liginfolst (submap, htmain, htrev) = + let add gidorg liginfolst ligtbl = + let htmain = ligtbl.entry_table in + let htrev = ligtbl.rev_table in begin GHt.add htmain gidorg liginfolst; - liginfolst |> List.iter (fun (gidorgtail, gidorglig) -> + liginfolst |> List.iter (fun single -> + let gidorgtail = single.tail in + let gidorglig = single.ligature in match GHt.find_opt htrev gidorglig with | None -> GHt.add htrev gidorglig (gidorg :: gidorgtail) @@ -350,7 +365,8 @@ module LigatureTable end - let fold_rev f init (_, _, htrev) = + let fold_rev f init ligtbl = + let htrev = ligtbl.rev_table in GHt.fold (fun gidorg gidorglst acc -> f gidorg gidorglst acc) htrev init @@ -360,18 +376,22 @@ module LigatureTable | (head1 :: tail1, head2 :: tail2) when head1 = head2 -> prefix tail1 tail2 | _ -> None + let rec lookup liginfolst gidorglst = match liginfolst with | [] -> NoMatch - | (gidorgtail, gidorglig) :: liginfotail -> + | single :: liginfotail -> + let gidorgtail = single.tail in + let gidorglig = single.ligature in match prefix gidorgtail gidorglst with | None -> lookup liginfotail gidorglst | Some(gidorgrest) -> MatchExactly(gidorglig, gidorgrest) - let match_prefix gidorglst (_, mainht, _) = + let match_prefix gidorglst ligtbl = + let mainht = ligtbl.entry_table in match gidorglst with | [] -> NoMatch @@ -406,6 +426,9 @@ let get_ligature_table (submap : subset_map) (d : Otfm.decoder) : LigatureTable. Otfm.gsub_feature langsys >>= fun (_, featurelst) -> pickup featurelst (fun gf -> Otfm.gsub_feature_tag gf = "liga") `Missing_feature >>= fun feature -> () |> Otfm.gsub feature (fun () _ -> ()) (fun () _ -> ()) (fun () (gid, liginfolst) -> + let liginfolst = + liginfolst |> List.map (fun (tail, ligature) -> LigatureTable.{ tail; ligature; }) + in ligtbl |> LigatureTable.add gid liginfolst) >>= fun () -> Ok() in From 122960801d46e9667c236259028dd922788c12b2 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 11 Aug 2018 05:04:48 +0900 Subject: [PATCH 09/78] update 'otfm' and add 'MarkTable' to 'FontFormat' --- satysfi.opam | 2 +- src/backend/fontFormat.ml | 111 ++++++++++++++++++++++++++++++++------ 2 files changed, 96 insertions(+), 17 deletions(-) diff --git a/satysfi.opam b/satysfi.opam index 4f66432b1..799ab906d 100644 --- a/satysfi.opam +++ b/satysfi.opam @@ -30,7 +30,7 @@ depends: [ "dune" {build} "menhir" "ocamlfind" {build} - "otfm" {= "0.3.0+satysfi"} + "otfm" {= "0.3.1+satysfi"} "ppx_deriving" "uutf" "yojson" diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index f6214f0c3..2db359792 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -425,7 +425,7 @@ let get_ligature_table (submap : subset_map) (d : Otfm.decoder) : LigatureTable. (* temporary; should depend on the current language system *) Otfm.gsub_feature langsys >>= fun (_, featurelst) -> pickup featurelst (fun gf -> Otfm.gsub_feature_tag gf = "liga") `Missing_feature >>= fun feature -> - () |> Otfm.gsub feature (fun () _ -> ()) (fun () _ -> ()) (fun () (gid, liginfolst) -> + () |> Otfm.gsub feature ~lig:(fun () (gid, liginfolst) -> let liginfolst = liginfolst |> List.map (fun (tail, ligature) -> LigatureTable.{ tail; ligature; }) in @@ -548,16 +548,17 @@ let get_kerning_table (d : Otfm.decoder) = (* temporary; should depend on the current language system *) Otfm.gpos_feature langsys >>= fun (_, featurelst) -> pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "kern") `Missing_feature >>= fun feature -> - () |> Otfm.gpos feature (fun () (gid1, pairposlst) -> - pairposlst |> List.iter (fun (gid2, valrcd1, valrcd2) -> - match valrcd1.Otfm.x_advance with - | None -> () - | Some(xa1) -> kerntbl |> KerningTable.add gid1 gid2 xa1 + () |> Otfm.gpos feature + ~pair1:(fun () (gid1, pairposlst) -> + pairposlst |> List.iter (fun (gid2, valrcd1, valrcd2) -> + match valrcd1.Otfm.x_advance with + | None -> () + | Some(xa1) -> kerntbl |> KerningTable.add gid1 gid2 xa1 + ) ) - ) - (fun clsdeflst1 clsdeflst2 () sublst -> - kerntbl |> KerningTable.add_by_class clsdeflst1 clsdeflst2 sublst; - ) >>= fun () -> Ok() + ~pair2:(fun clsdeflst1 clsdeflst2 () sublst -> + kerntbl |> KerningTable.add_by_class clsdeflst1 clsdeflst2 sublst; + ) >>= fun () -> Ok() in match res with | Ok() -> @@ -574,6 +575,89 @@ let get_kerning_table (d : Otfm.decoder) = | _ -> (* raise_err e *) kerntbl (* temporary *) +let per_mille_raw (units_per_em : int) (w : design_units) : per_mille = + PerMille(int_of_float ((float_of_int (w * 1000)) /. (float_of_int units_per_em))) + + +module GSet = Set.Make + (struct + type t = original_glyph_id + let compare = Pervasives.compare + end) + + +module GMap = Map.Make + (struct + type t = original_glyph_id + let compare = Pervasives.compare + end) + + +type mark_class = int + +type anchor_point = per_mille * per_mille + + +module MarkTable +: sig + type t + val create : unit -> t + val add : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit + val find_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + end += struct + + type mark_to_base_entry = { + class_count : int; + mark_map : (mark_class * anchor_point) GMap.t; + base_map : (anchor_point array) GMap.t; + } + + type t = { + mutable mark_to_base_table : mark_to_base_entry list; + } + + + let create () = + { mark_to_base_table = []; } + + + let add units_per_em class_count markassoc baseassoc mktbl = + let pmf = per_mille_raw units_per_em in + let mark_map = + markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> + map |> GMap.add gidmark (i, (pmf x, pmf y)) + ) GMap.empty + in + let base_map = + baseassoc |> List.fold_left (fun map (gidbase, arr) -> + map |> GMap.add gidbase (arr |> Array.map (fun (x, y, _) -> (pmf x, pmf y))) + ) GMap.empty + in + let entry = { class_count; mark_map; base_map; } in + mktbl.mark_to_base_table <- entry :: mktbl.mark_to_base_table + + + let find_opt (gidbase, gidmark) mktbl = + let rec aux lst = + match lst with + | [] -> + None + + | entry :: tail -> + let baseopt = entry.base_map |> GMap.find_opt gidbase in + let markopt = entry.mark_map |> GMap.find_opt gidmark in + begin + match (baseopt, markopt) with + | (None, _) | (_, None) -> aux tail + | (Some(arr), Some(i, ptmark)) -> Some((arr.(i), ptmark)) + end + in + aux mktbl.mark_to_base_table + + end + + type decoder = { file_path : file_path; main : Otfm.decoder; @@ -831,10 +915,6 @@ let get_glyph_id (dcdr : decoder) (uch : Uchar.t) : glyph_id option = return gid -let per_mille_raw (units_per_em : int) (w : design_units) : per_mille = - PerMille(int_of_float ((float_of_int (w * 1000)) /. (float_of_int units_per_em))) - - let per_mille (dcdr : decoder) (w : design_units) : per_mille = per_mille_raw dcdr.units_per_em w @@ -1735,8 +1815,7 @@ let get_script_style_id (md : math_decoder) (gid : glyph_id) : glyph_id = | (None, []) -> opt | (None, gidorgto :: _) -> if gidorgfrom = gidorg then Some(gidorgto) else opt in - let skip opt _ = opt in - let res = Otfm.gsub feature_ssty f_single f_alt skip None in + let res = Otfm.gsub feature_ssty ~single:f_single ~alt:f_alt None in match res with | Error(oerr) -> gid (* temporary; maybe should emit an error *) | Ok(None) -> gid From 4b410b37220015d0eab9526edc9ccfc77efc6e2a Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 15:40:00 +0900 Subject: [PATCH 10/78] add a TTC font to 'fonts.satysfi-hash' --- lib-satysfi/dist/hash/fonts.satysfi-hash | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib-satysfi/dist/hash/fonts.satysfi-hash b/lib-satysfi/dist/hash/fonts.satysfi-hash index 5bd8e9195..66882d309 100644 --- a/lib-satysfi/dist/hash/fonts.satysfi-hash +++ b/lib-satysfi/dist/hash/fonts.satysfi-hash @@ -12,5 +12,6 @@ "Junicode-b": , "Junicode-it": , "HiraKakuProN-W2": , - "HiraKakuProN-W5": + "HiraKakuProN-W5": , + "Menlo": } From e81827d8a017da5d7926776dd116b8ffee688bb5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 16:23:52 +0900 Subject: [PATCH 11/78] add 'mark_table' to 'decoder' --- src/backend/fontFormat.ml | 71 +++++++++++++++++++++++++++++---------- 1 file changed, 53 insertions(+), 18 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 2db359792..8ed2a1a02 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -159,6 +159,11 @@ type glyph_id_pair = { type glyph_id = | SubsetGlyphID of original_glyph_id * subset_glyph_id +type glyph_segment = { + base : glyph_id; + marks : glyph_id list; +} + let hex_of_glyph_id ((SubsetGlyphID(_, gidsub)) : glyph_id) = let b0 = gidsub / 256 in @@ -414,7 +419,7 @@ let result_bind x f = | Error(e) -> Error(e :> error) -let get_ligature_table (submap : subset_map) (d : Otfm.decoder) : LigatureTable.t = +let get_ligature_table srcpath (submap : subset_map) (d : Otfm.decoder) : LigatureTable.t = let ligtbl = LigatureTable.create submap 32 (* temporary; size of the hash table *) in let res = let (>>=) = result_bind in @@ -433,12 +438,18 @@ let get_ligature_table (submap : subset_map) (d : Otfm.decoder) : LigatureTable. Ok() in match res with - | Ok(()) -> ligtbl + | Ok(()) -> + ligtbl + | Error(e) -> - match e with - | `Missing_required_table(tag) - when tag = Otfm.Tag.gsub -> ligtbl - | _ -> (* raise_err e *) ligtbl (* temporary *) + begin + match e with + | `Missing_required_table(tag) + when tag = Otfm.Tag.gsub -> ligtbl + | `Missing_script -> ligtbl + | `Missing_feature -> ligtbl + | #Otfm.error as oerr -> raise_err srcpath oerr "get_ligature_table" + end module KerningTable @@ -528,7 +539,7 @@ module KerningTable end -let get_kerning_table (d : Otfm.decoder) = +let get_kerning_table srcpath (d : Otfm.decoder) = let kerntbl = KerningTable.create 32 (* temporary; size of the hash table *) in let _ = () |> Otfm.kern d (fun () kinfo -> @@ -561,18 +572,18 @@ let get_kerning_table (d : Otfm.decoder) = ) >>= fun () -> Ok() in match res with - | Ok() -> + | Ok(()) -> kerntbl | Error(e) -> - match e with - | `Missing_required_table(t) - when t = Otfm.Tag.gpos -> -(* - let () = PrintForDebug.kernE "'GPOS' missing" in (* for debug *) -*) - kerntbl - | _ -> (* raise_err e *) kerntbl (* temporary *) + begin + match e with + | `Missing_required_table(t) + when t = Otfm.Tag.gpos -> kerntbl + | `Missing_script -> kerntbl + | `Missing_feature -> kerntbl + | #Otfm.error as oerr -> raise_err srcpath oerr "get_kerning_table" + end let per_mille_raw (units_per_em : int) (w : design_units) : per_mille = @@ -658,6 +669,27 @@ module MarkTable end +let get_mark_table srcpath units_per_em d = + let mktbl = MarkTable.create () in + let res = + let (>>=) = result_bind in + Otfm.gpos_script d >>= fun scriptlst -> + pickup scriptlst (fun gs -> Otfm.gpos_script_tag gs = "latn") `Missing_script >>= fun script -> + (* temporary; should depend on the script *) + Otfm.gpos_langsys script >>= fun (langsys, _) -> + (* temporary; should depend on the current language system *) + Otfm.gpos_feature langsys >>= fun (_, featurelst) -> + pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature -> + () |> Otfm.gpos feature ~markbase1:(fun clscnt () markassoc baseassoc -> + MarkTable.add units_per_em clscnt markassoc baseassoc mktbl + ) >>= fun () -> + Ok() + in + match res with + | Error(#Otfm.error as oerr) -> raise_err srcpath oerr "get_mark_table" + | _ -> mktbl + + type decoder = { file_path : file_path; main : Otfm.decoder; @@ -669,6 +701,7 @@ type decoder = { glyph_bbox_table : GlyphBBoxTable.t; kerning_table : KerningTable.t; ligature_table : LigatureTable.t; + mark_table : MarkTable.t; charstring_info : Otfm.charstring_info option; units_per_em : int; default_ascent : per_mille; @@ -1478,14 +1511,12 @@ let make_dictionary (pdf : Pdf.t) (font : font) (dcdr : decoder) : Pdf.pdfobject let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = let cmapsubtbl = get_cmap_subtable srcpath d in - let kerntbl = get_kerning_table d in let submap = match Otfm.flavour d with | Error(e) -> raise_err srcpath e "make_decoder" | Ok(Otfm.TTF_true | Otfm.TTF_OT) -> SubsetMap.create 32 (* temporary; initial size of hash tables *) | Ok(Otfm.CFF) -> SubsetMap.create_dummy () in - let ligtbl = get_ligature_table submap d in let gidtbl = GlyphIDTable.create submap 256 in (* temporary; initial size of hash tables *) let bboxtbl = GlyphBBoxTable.create 256 in (* temporary; initial size of hash tables *) let (rcdhhea, ascent, descent) = @@ -1498,6 +1529,9 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = | Ok(rcdhead) -> (rcdhead, rcdhead.Otfm.head_units_per_em) | Error(e) -> raise_err srcpath e "make_decoder (head)" in + let kerntbl = get_kerning_table srcpath d in + let ligtbl = get_ligature_table srcpath submap d in + let mktbl = get_mark_table srcpath units_per_em d in let csinfo = match Otfm.cff d with | Error(_) -> None @@ -1511,6 +1545,7 @@ let make_decoder (srcpath : file_path) (d : Otfm.decoder) : decoder = hhea_record = rcdhhea; kerning_table = kerntbl; ligature_table = ligtbl; + mark_table = mktbl; subset_map = submap; glyph_id_table = gidtbl; glyph_bbox_table = bboxtbl; From d9e813a467404fa71a02a16ec652bdcac3bd6606 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 18:04:40 +0900 Subject: [PATCH 12/78] extend 'glyph_id' to 'glyph_segment' in order to handle diacritical marks --- src/backend/fontFormat.ml | 74 ++++++++++++++++++++++---------------- src/backend/fontFormat.mli | 4 ++- src/frontend/fontInfo.ml | 7 ++-- 3 files changed, 51 insertions(+), 34 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 8ed2a1a02..2686790b3 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -159,10 +159,9 @@ type glyph_id_pair = { type glyph_id = | SubsetGlyphID of original_glyph_id * subset_glyph_id -type glyph_segment = { - base : glyph_id; - marks : glyph_id list; -} +type original_glyph_segment = original_glyph_id * original_glyph_id list + +type glyph_segment = glyph_id * glyph_id list let hex_of_glyph_id ((SubsetGlyphID(_, gidsub)) : glyph_id) = @@ -312,7 +311,7 @@ module GlyphBBoxTable type ligature_matching = - | MatchExactly of original_glyph_id * original_glyph_id list + | MatchExactly of original_glyph_id * original_glyph_segment list | NoMatch @@ -326,7 +325,7 @@ module LigatureTable val create : subset_map -> int -> t val add : original_glyph_id -> single list -> t -> unit val fold_rev : (original_glyph_id -> original_glyph_id list -> 'a -> 'a) -> 'a -> t -> 'a - val match_prefix : original_glyph_id list -> t -> ligature_matching + val match_prefix : original_glyph_segment list -> t -> ligature_matching end = struct @@ -375,14 +374,15 @@ module LigatureTable GHt.fold (fun gidorg gidorglst acc -> f gidorg gidorglst acc) htrev init - let rec prefix lst1 lst2 = - match (lst1, lst2) with - | ([], _) -> Some(lst2) - | (head1 :: tail1, head2 :: tail2) when head1 = head2 -> prefix tail1 tail2 - | _ -> None + let rec prefix (lst1 : original_glyph_id list) (seglst2 : original_glyph_segment list) = + match (lst1, seglst2) with + | ([], _) -> Some(seglst2) + | (head1 :: tail1, (head2, []) :: tail2) when head1 = head2 -> prefix tail1 tail2 + (* temporary; should refer to MarkToLig attachment table *) + | _ -> None - let rec lookup liginfolst gidorglst = + let rec lookup liginfolst (segorglst : original_glyph_segment list) = match liginfolst with | [] -> NoMatch @@ -390,22 +390,32 @@ module LigatureTable | single :: liginfotail -> let gidorgtail = single.tail in let gidorglig = single.ligature in - match prefix gidorgtail gidorglst with - | None -> lookup liginfotail gidorglst - | Some(gidorgrest) -> MatchExactly(gidorglig, gidorgrest) + begin + match prefix gidorgtail segorglst with + | None -> lookup liginfotail segorglst + | Some(orgsegrest) -> MatchExactly(gidorglig, orgsegrest) + end - let match_prefix gidorglst ligtbl = + let match_prefix (segorglst : original_glyph_segment list) ligtbl = let mainht = ligtbl.entry_table in - match gidorglst with + match segorglst with | [] -> NoMatch - | gidorgfst :: gidorgtail -> + | (gidorgfst, gomarks) :: segorgtail -> begin - match GHt.find_opt mainht gidorgfst with - | Some(liginfolst) -> lookup liginfolst gidorgtail - | None -> NoMatch + match gomarks with + | _ :: _ -> + NoMatch + (* temporary; should refer to MarkToLig table *) + + | [] -> + begin + match GHt.find_opt mainht gidorgfst with + | Some(liginfolst) -> lookup liginfolst segorgtail + | None -> NoMatch + end end end @@ -1594,23 +1604,27 @@ let get_decoder_ttc (fontname : string) (srcpath :file_path) (i : int) : (decode | Ok(Some((d, fontreg))) -> let dcdr = make_decoder srcpath d in Some((dcdr, get_font dcdr fontreg fontname)) -let convert_to_ligatures (dcdr : decoder) (gidlst : glyph_id list) : glyph_id list = +let convert_to_ligatures (dcdr : decoder) (seglst : glyph_segment list) : glyph_segment list = let ligtbl = dcdr.ligature_table in let intf = intern_gid dcdr in - let rec aux acc gidorglst = - match gidorglst with + let intsegf (gobase, gomarks) = (intf gobase, List.map intf gomarks) in + let orgf = get_original_gid dcdr in + let orgsegf (base, marks) = (orgf base, List.map orgf marks) in + + let rec aux acc segorglst = + match segorglst with | [] -> Alist.to_list acc - | go :: gos -> + | so :: sos -> begin - match ligtbl |> LigatureTable.match_prefix gidorglst with - | NoMatch -> aux (Alist.extend acc (intf go)) gos - | MatchExactly(gidorglig, gidorgrest) -> aux (Alist.extend acc (intf gidorglig)) gidorgrest + match ligtbl |> LigatureTable.match_prefix segorglst with + | NoMatch -> aux (Alist.extend acc (intsegf so)) sos + | MatchExactly(gidorglig, segorgrest) -> aux (Alist.extend acc (intf gidorglig, [])) segorgrest end in - let gidorglst = gidlst |> List.map (get_original_gid dcdr) in - aux Alist.empty gidorglst + let segorglst = seglst |> List.map orgsegf in + aux Alist.empty segorglst let find_kerning (dcdr : decoder) (gidprev : glyph_id) (gid : glyph_id) : per_mille option = diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index ae47a80a3..60a731aa5 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -3,6 +3,8 @@ type file_path = string type glyph_id +type glyph_segment = glyph_id * glyph_id list + type per_mille = | PerMille of int @@ -39,7 +41,7 @@ val get_glyph_metrics : decoder -> glyph_id -> metrics val get_glyph_id : decoder -> Uchar.t -> glyph_id option -val convert_to_ligatures : decoder -> glyph_id list -> glyph_id list +val convert_to_ligatures : decoder -> glyph_segment list -> glyph_segment list val find_kerning : decoder -> glyph_id -> glyph_id -> per_mille option diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index ac534065c..619cc3d7d 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -135,10 +135,11 @@ let ( @*> ) = OutputText.append_kern let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcdr : FontFormat.decoder) (gidlst : FontFormat.glyph_id list) : FontFormat.glyph_id list * OutputText.t * FontFormat.metrics = - let gidligedlst = FontFormat.convert_to_ligatures dcdr gidlst in + + let seglst = FontFormat.convert_to_ligatures dcdr (gidlst |> List.map (fun gid -> (gid, []))) (* temporary *) in let (_, otxt, rawwid, rawhgt, rawdpt) = - gidligedlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) gid -> + seglst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) (gid, _) -> let (FontFormat.PerMille(w), FontFormat.PerMille(h), FontFormat.PerMille(d)) = metricsf gid in let (tjsaccnew, waccnew) = match gidprevopt with @@ -162,7 +163,7 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd (Some(gid), tjsaccnew, waccnew, max hacc h, min dacc d) ) (None, OutputText.empty_hex_style, 0, 0, 0) in - (gidligedlst, otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) + (seglst |> List.map (fun (gid, _) -> gid) (* temporary *), otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : OutputText.t * length * length * length = From c2a351791308adc00aa7b72851ee22823a0b992b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 19:06:26 +0900 Subject: [PATCH 13/78] add 'mark_info' and 'glyph_synthesis' --- src/backend/fontFormat.ml | 301 ++++++++++++++++++++----------------- src/backend/fontFormat.mli | 7 +- src/frontend/fontInfo.ml | 6 +- 3 files changed, 174 insertions(+), 140 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 2686790b3..df37c0751 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -310,9 +310,133 @@ module GlyphBBoxTable end +let per_mille_raw (units_per_em : int) (w : design_units) : per_mille = + PerMille(int_of_float ((float_of_int (w * 1000)) /. (float_of_int units_per_em))) + + +module GSet = Set.Make + (struct + type t = original_glyph_id + let compare = Pervasives.compare + end) + + +module GMap = Map.Make + (struct + type t = original_glyph_id + let compare = Pervasives.compare + end) + + +type mark_class = int + +type anchor_point = per_mille * per_mille + + +module MarkTable +: sig + type t + val create : unit -> t + val add : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit + val find_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + end += struct + + type mark_to_base_entry = { + class_count : int; + mark_map : (mark_class * anchor_point) GMap.t; + base_map : (anchor_point array) GMap.t; + } + + type t = { + mutable mark_to_base_table : mark_to_base_entry list; + } + + + let create () = + { mark_to_base_table = []; } + + + let add units_per_em class_count markassoc baseassoc mktbl = + let pmf = per_mille_raw units_per_em in + let mark_map = + markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> + map |> GMap.add gidmark (i, (pmf x, pmf y)) + ) GMap.empty + in + let base_map = + baseassoc |> List.fold_left (fun map (gidbase, arr) -> + map |> GMap.add gidbase (arr |> Array.map (fun (x, y, _) -> (pmf x, pmf y))) + ) GMap.empty + in + let entry = { class_count; mark_map; base_map; } in + mktbl.mark_to_base_table <- entry :: mktbl.mark_to_base_table + + + let find_opt (gidbase, gidmark) mktbl = + let rec aux lst = + match lst with + | [] -> + None + + | entry :: tail -> + let baseopt = entry.base_map |> GMap.find_opt gidbase in + let markopt = entry.mark_map |> GMap.find_opt gidmark in + begin + match (baseopt, markopt) with + | (None, _) | (_, None) -> aux tail + | (Some(arr), Some(i, ptmark)) -> Some((arr.(i), ptmark)) + end + in + aux mktbl.mark_to_base_table + + end + + +type error = [ Otfm.error | `Missing_script | `Missing_feature ] + + +let result_bind x f = + match x with + | Ok(v) -> f v + | Error(e) -> Error(e :> error) + + +let get_mark_table srcpath units_per_em d = + let mktbl = MarkTable.create () in + let res = + let (>>=) = result_bind in + Otfm.gpos_script d >>= fun scriptlst -> + pickup scriptlst (fun gs -> Otfm.gpos_script_tag gs = "latn") `Missing_script >>= fun script -> + (* temporary; should depend on the script *) + Otfm.gpos_langsys script >>= fun (langsys, _) -> + (* temporary; should depend on the current language system *) + Otfm.gpos_feature langsys >>= fun (_, featurelst) -> + pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature -> + () |> Otfm.gpos feature ~markbase1:(fun clscnt () markassoc baseassoc -> + MarkTable.add units_per_em clscnt markassoc baseassoc mktbl + ) >>= fun () -> + Ok() + in + match res with + | Error(#Otfm.error as oerr) -> raise_err srcpath oerr "get_mark_table" + | _ -> mktbl + + +let ( -@ ) (PerMille(x1), PerMille(y1)) (PerMille(x2), PerMille(y2)) = + (PerMille(x1 - x2), PerMille(y1 - y2)) + + +type per_mille_vector = per_mille * per_mille + +type mark_info = + | Mark of glyph_id * per_mille_vector + +type glyph_synthesis = glyph_id * mark_info list + type ligature_matching = - | MatchExactly of original_glyph_id * original_glyph_segment list - | NoMatch + | Match of original_glyph_id * (original_glyph_id * per_mille_vector) list * original_glyph_segment list + | ReachEnd module LigatureTable @@ -325,7 +449,7 @@ module LigatureTable val create : subset_map -> int -> t val add : original_glyph_id -> single list -> t -> unit val fold_rev : (original_glyph_id -> original_glyph_id list -> 'a -> 'a) -> 'a -> t -> 'a - val match_prefix : original_glyph_segment list -> t -> ligature_matching + val match_prefix : original_glyph_segment list -> MarkTable.t -> t -> ligature_matching end = struct @@ -385,7 +509,7 @@ module LigatureTable let rec lookup liginfolst (segorglst : original_glyph_segment list) = match liginfolst with | [] -> - NoMatch + None | single :: liginfotail -> let gidorgtail = single.tail in @@ -393,42 +517,49 @@ module LigatureTable begin match prefix gidorgtail segorglst with | None -> lookup liginfotail segorglst - | Some(orgsegrest) -> MatchExactly(gidorglig, orgsegrest) + | Some(orgsegrest) -> Some((gidorglig), orgsegrest) end - let match_prefix (segorglst : original_glyph_segment list) ligtbl = + let match_prefix (segorglst : original_glyph_segment list) (mktbl : MarkTable.t) (ligtbl : t) = let mainht = ligtbl.entry_table in match segorglst with | [] -> - NoMatch + ReachEnd - | (gidorgfst, gomarks) :: segorgtail -> + | (gobase, gomarks) :: segorgtail -> begin match gomarks with - | _ :: _ -> - NoMatch - (* temporary; should refer to MarkToLig table *) + | gomark :: _ -> + (* temporary; should refer to MarkToMark table + in order to handle diacritical marks after the first one *) + begin + match mktbl |> MarkTable.find_opt (gobase, gomark) with + | None -> + (* if the diacritical mark cannot attach to the base *) + Match(gobase, [], segorgtail) + + | Some(vB, vM) -> + Match(gobase, [(gomark, vM -@ vB)], segorgtail) + end | [] -> begin - match GHt.find_opt mainht gidorgfst with - | Some(liginfolst) -> lookup liginfolst segorgtail - | None -> NoMatch + match GHt.find_opt mainht gobase with + | None -> + Match(gobase, [], segorgtail) + + | Some(liginfolst) -> + begin + match lookup liginfolst segorgtail with + | None -> Match(gobase, [], segorgtail) + | Some((golig, segorgrest)) -> Match(golig, [], segorgrest) (* temporary *) + end end end end -type error = [ Otfm.error | `Missing_script | `Missing_feature ] - - -let result_bind x f = - match x with - | Ok(v) -> f v - | Error(e) -> Error(e :> error) - - let get_ligature_table srcpath (submap : subset_map) (d : Otfm.decoder) : LigatureTable.t = let ligtbl = LigatureTable.create submap 32 (* temporary; size of the hash table *) in let res = @@ -596,110 +727,6 @@ let get_kerning_table srcpath (d : Otfm.decoder) = end -let per_mille_raw (units_per_em : int) (w : design_units) : per_mille = - PerMille(int_of_float ((float_of_int (w * 1000)) /. (float_of_int units_per_em))) - - -module GSet = Set.Make - (struct - type t = original_glyph_id - let compare = Pervasives.compare - end) - - -module GMap = Map.Make - (struct - type t = original_glyph_id - let compare = Pervasives.compare - end) - - -type mark_class = int - -type anchor_point = per_mille * per_mille - - -module MarkTable -: sig - type t - val create : unit -> t - val add : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit - val find_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option - end -= struct - - type mark_to_base_entry = { - class_count : int; - mark_map : (mark_class * anchor_point) GMap.t; - base_map : (anchor_point array) GMap.t; - } - - type t = { - mutable mark_to_base_table : mark_to_base_entry list; - } - - - let create () = - { mark_to_base_table = []; } - - - let add units_per_em class_count markassoc baseassoc mktbl = - let pmf = per_mille_raw units_per_em in - let mark_map = - markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> - map |> GMap.add gidmark (i, (pmf x, pmf y)) - ) GMap.empty - in - let base_map = - baseassoc |> List.fold_left (fun map (gidbase, arr) -> - map |> GMap.add gidbase (arr |> Array.map (fun (x, y, _) -> (pmf x, pmf y))) - ) GMap.empty - in - let entry = { class_count; mark_map; base_map; } in - mktbl.mark_to_base_table <- entry :: mktbl.mark_to_base_table - - - let find_opt (gidbase, gidmark) mktbl = - let rec aux lst = - match lst with - | [] -> - None - - | entry :: tail -> - let baseopt = entry.base_map |> GMap.find_opt gidbase in - let markopt = entry.mark_map |> GMap.find_opt gidmark in - begin - match (baseopt, markopt) with - | (None, _) | (_, None) -> aux tail - | (Some(arr), Some(i, ptmark)) -> Some((arr.(i), ptmark)) - end - in - aux mktbl.mark_to_base_table - - end - - -let get_mark_table srcpath units_per_em d = - let mktbl = MarkTable.create () in - let res = - let (>>=) = result_bind in - Otfm.gpos_script d >>= fun scriptlst -> - pickup scriptlst (fun gs -> Otfm.gpos_script_tag gs = "latn") `Missing_script >>= fun script -> - (* temporary; should depend on the script *) - Otfm.gpos_langsys script >>= fun (langsys, _) -> - (* temporary; should depend on the current language system *) - Otfm.gpos_feature langsys >>= fun (_, featurelst) -> - pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature -> - () |> Otfm.gpos feature ~markbase1:(fun clscnt () markassoc baseassoc -> - MarkTable.add units_per_em clscnt markassoc baseassoc mktbl - ) >>= fun () -> - Ok() - in - match res with - | Error(#Otfm.error as oerr) -> raise_err srcpath oerr "get_mark_table" - | _ -> mktbl - - type decoder = { file_path : file_path; main : Otfm.decoder; @@ -1604,24 +1631,26 @@ let get_decoder_ttc (fontname : string) (srcpath :file_path) (i : int) : (decode | Ok(Some((d, fontreg))) -> let dcdr = make_decoder srcpath d in Some((dcdr, get_font dcdr fontreg fontname)) -let convert_to_ligatures (dcdr : decoder) (seglst : glyph_segment list) : glyph_segment list = +let convert_to_ligatures (dcdr : decoder) (seglst : glyph_segment list) : glyph_synthesis list = let ligtbl = dcdr.ligature_table in + let mktbl = dcdr.mark_table in let intf = intern_gid dcdr in +(* let intsegf (gobase, gomarks) = (intf gobase, List.map intf gomarks) in +*) let orgf = get_original_gid dcdr in let orgsegf (base, marks) = (orgf base, List.map orgf marks) in let rec aux acc segorglst = - match segorglst with - | [] -> + match ligtbl |> LigatureTable.match_prefix segorglst mktbl with + | ReachEnd -> Alist.to_list acc - | so :: sos -> - begin - match ligtbl |> LigatureTable.match_prefix segorglst with - | NoMatch -> aux (Alist.extend acc (intsegf so)) sos - | MatchExactly(gidorglig, segorgrest) -> aux (Alist.extend acc (intf gidorglig, [])) segorgrest - end + | Match(gidorglig, markorginfolst, segorgrest) -> + let markinfolst = + markorginfolst |> List.map (fun (gidorg, v) -> (Mark(intf gidorg, v))) + in + aux (Alist.extend acc (intf gidorglig, markinfolst)) segorgrest in let segorglst = seglst |> List.map orgsegf in aux Alist.empty segorglst diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index 60a731aa5..0737c05a6 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -8,6 +8,11 @@ type glyph_segment = glyph_id * glyph_id list type per_mille = | PerMille of int +type mark_info = + | Mark of glyph_id * (per_mille * per_mille) + +type glyph_synthesis = glyph_id * mark_info list + type metrics = per_mille * per_mille * per_mille val hex_of_glyph_id : glyph_id -> string @@ -41,7 +46,7 @@ val get_glyph_metrics : decoder -> glyph_id -> metrics val get_glyph_id : decoder -> Uchar.t -> glyph_id option -val convert_to_ligatures : decoder -> glyph_segment list -> glyph_segment list +val convert_to_ligatures : decoder -> glyph_segment list -> glyph_synthesis list val find_kerning : decoder -> glyph_id -> glyph_id -> per_mille option diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 619cc3d7d..ae71751a6 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -136,10 +136,10 @@ let ( @*> ) = OutputText.append_kern let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcdr : FontFormat.decoder) (gidlst : FontFormat.glyph_id list) : FontFormat.glyph_id list * OutputText.t * FontFormat.metrics = - let seglst = FontFormat.convert_to_ligatures dcdr (gidlst |> List.map (fun gid -> (gid, []))) (* temporary *) in + let gsynlst = FontFormat.convert_to_ligatures dcdr (gidlst |> List.map (fun gid -> (gid, []))) (* temporary *) in let (_, otxt, rawwid, rawhgt, rawdpt) = - seglst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) (gid, _) -> + gsynlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) (gid, markinfolst) -> let (FontFormat.PerMille(w), FontFormat.PerMille(h), FontFormat.PerMille(d)) = metricsf gid in let (tjsaccnew, waccnew) = match gidprevopt with @@ -163,7 +163,7 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd (Some(gid), tjsaccnew, waccnew, max hacc h, min dacc d) ) (None, OutputText.empty_hex_style, 0, 0, 0) in - (seglst |> List.map (fun (gid, _) -> gid) (* temporary *), otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) + (gsynlst |> List.map (fun (gid, _) -> gid) (* temporary *), otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : OutputText.t * length * length * length = From 82e192703b3f8f80f099d1d528818b3d3bca2fbe Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 19:22:15 +0900 Subject: [PATCH 14/78] extend 'OutputText' for 'glyph_synthesis' --- src/backend/outputText.ml | 26 ++++++-------------------- src/backend/outputText.mli | 2 +- src/frontend/fontInfo.ml | 11 ++++++----- 3 files changed, 13 insertions(+), 26 deletions(-) diff --git a/src/backend/outputText.ml b/src/backend/outputText.ml index b9244831e..52454fcaa 100644 --- a/src/backend/outputText.ml +++ b/src/backend/outputText.ml @@ -9,35 +9,21 @@ type style = | Hex [@@deriving show] -type t = style * element list - [@@deriving show] +type t = style * element Alist.t let pp fmt _ = Format.fprintf fmt "" -(* -let empty_literal_style = (Literal, []) - - -let append_uchar (sty, otxtmain) uch = - let data = - match sty with - | Literal -> InternalText.to_utf8 (InternalText.of_uchar uch) - | Hex -> InternalText.to_utf16be_hex (InternalText.of_uchar uch) - in - (* temporary; inefficient conversion *) - (sty, Data(data) :: otxtmain) -*) -let empty_hex_style = (Hex, []) +let empty_hex_style = (Hex, Alist.empty) let append_kern (sty, otxtmain) rawwid = - (sty, Kern(rawwid) :: otxtmain) + (sty, Alist.extend otxtmain (Kern(rawwid))) -let append_glyph_id (sty, otxtmain) gid = +let append_glyph_synthesis (sty, otxtmain) (gid, markinfolst) = let data = FontFormat.hex_of_glyph_id gid in - (sty, Data(data) :: otxtmain) + (sty, Alist.extend otxtmain (Data(data))) let to_TJ_argument (sty, otxtmain) = @@ -47,7 +33,7 @@ let to_TJ_argument (sty, otxtmain) = | Hex -> (fun x -> Pdf.StringHex(x)) in let lst = - otxtmain |> List.rev |> List.map (function + otxtmain |> Alist.to_list |> List.map (function | Data(data) -> pdfstr data | Kern(rawwid) -> Pdf.Integer(-rawwid) ) diff --git a/src/backend/outputText.mli b/src/backend/outputText.mli index 54e5aaa0e..bf413da44 100644 --- a/src/backend/outputText.mli +++ b/src/backend/outputText.mli @@ -5,7 +5,7 @@ val empty_hex_style : t val append_kern : t -> int -> t -val append_glyph_id : t -> FontFormat.glyph_id -> t +val append_glyph_synthesis : t -> FontFormat.glyph_synthesis -> t val to_TJ_argument : t -> Pdf.pdfobject diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index ae71751a6..d10cb6769 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -130,7 +130,7 @@ let raw_length_to_skip_length (fontsize : length) (FontFormat.PerMille(rawlen) : fontsize *% ((float_of_int rawlen) /. 1000.) -let ( @>> ) = OutputText.append_glyph_id +let ( @>> ) = OutputText.append_glyph_synthesis let ( @*> ) = OutputText.append_kern @@ -139,24 +139,25 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd let gsynlst = FontFormat.convert_to_ligatures dcdr (gidlst |> List.map (fun gid -> (gid, []))) (* temporary *) in let (_, otxt, rawwid, rawhgt, rawdpt) = - gsynlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) (gid, markinfolst) -> + gsynlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) gsyn -> + let (gid, _) = gsyn in let (FontFormat.PerMille(w), FontFormat.PerMille(h), FontFormat.PerMille(d)) = metricsf gid in let (tjsaccnew, waccnew) = match gidprevopt with | None -> - (otxtacc @>> gid, wacc + w) + (otxtacc @>> gsyn, wacc + w) | Some(gidprev) -> begin match FontFormat.find_kerning dcdr gidprev gid with | None -> - (otxtacc @>> gid, wacc + w) + (otxtacc @>> gsyn, wacc + w) | Some(FontFormat.PerMille(wkern)) -> (* PrintForDebug.kernE (Printf.sprintf "Use KERN (%d, %d) = %d" (FontFormat.gid gidprev) (FontFormat.gid gid) wkern); (* for debug *) *) - ((otxtacc @*> wkern) @>> gid, wacc + w + wkern) + ((otxtacc @*> wkern) @>> gsyn, wacc + w + wkern) (* -- kerning value is negative if two characters are supposed to be closer -- *) end in From 808dcc054d293d3ceb2e2220201a93578a3e4208 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 20:49:51 +0900 Subject: [PATCH 15/78] extend PDF-outputting operations to handle diacritical marks --- src/backend/fontFormat.ml | 234 +++++++++++++++++++------------------ src/backend/fontFormat.mli | 2 +- src/backend/graphicD.ml | 39 +++++-- src/backend/outputText.ml | 83 +++++++++---- src/backend/outputText.mli | 4 +- src/frontend/fontInfo.ml | 11 +- 6 files changed, 214 insertions(+), 159 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index df37c0751..48696d0d1 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -430,7 +430,7 @@ let ( -@ ) (PerMille(x1), PerMille(y1)) (PerMille(x2), PerMille(y2)) = type per_mille_vector = per_mille * per_mille type mark_info = - | Mark of glyph_id * per_mille_vector + | Mark of glyph_id * per_mille * per_mille_vector type glyph_synthesis = glyph_id * mark_info list @@ -745,6 +745,120 @@ type decoder = { default_descent : per_mille; } + +let per_mille (dcdr : decoder) (w : design_units) : per_mille = + per_mille_raw dcdr.units_per_em w + + +let get_original_gid (dcdr : decoder) (gid : glyph_id) : original_glyph_id = +(* + match dcdr.subset_map |> SubsetMap.find_rev_opt gid with + | None -> assert false + | Some(gidorg) -> gidorg +*) + let SubsetGlyphID(gidorg, _) = gid in + gidorg + + +let get_glyph_raw_bbox (dcdr : decoder) (gidorg : original_glyph_id) + : ((design_units * design_units * design_units * design_units) option) ok = + let d = dcdr.main in + let open ResultMonad in + Otfm.loca d gidorg >>= function + | None -> + return None + + | Some(gloc) -> + Otfm.glyf d gloc >>= fun (_, rawbbox) -> + return (Some(rawbbox)) + + +let bbox_zero = + (PerMille(0), PerMille(0), PerMille(0), PerMille(0)) + + +let get_ttf_bbox (dcdr : decoder) (gidorg : original_glyph_id) : bbox = + let f = per_mille dcdr in + match get_glyph_raw_bbox dcdr gidorg with +(* + | Error(`Missing_required_table(t)) + when t = Otfm.Tag.loca -> +*) + | Error(e) -> + raise_err dcdr.file_path e (Printf.sprintf "get_ttf_bbox (gid = %d)" gidorg) + + | Ok(None) -> + bbox_zero + + | Ok(Some(bbox_raw)) -> + let (xmin_raw, ymin_raw, xmax_raw, ymax_raw) = bbox_raw in + (f xmin_raw, f ymin_raw, f xmax_raw, f ymax_raw) + + +let get_glyph_advance_width (dcdr : decoder) (gidorgkey : original_glyph_id) : per_mille = + let d = dcdr.main in + let hmtxres = + None |> Otfm.hmtx d (fun accopt gidorg adv lsb -> + match accopt with + | Some(_) -> accopt + | None -> if gidorg = gidorgkey then Some((adv, lsb)) else None + ) + in + match hmtxres with + | Error(e) -> raise_err dcdr.file_path e (Printf.sprintf "get_glyph_advance_width (gid = %d)" gidorgkey) + | Ok(None) -> PerMille(0) + | Ok(Some((adv, lsb))) -> per_mille dcdr adv + + +let get_bbox (dcdr : decoder) (gidorg : original_glyph_id) : bbox = + match dcdr.charstring_info with + | None -> + (* -- if the font is TrueType OT -- *) + get_ttf_bbox dcdr gidorg + + | Some(csinfo) -> + (* -- if the font is CFF OT -- *) + begin + match Otfm.charstring_absolute csinfo gidorg with + | Error(oerr) -> raise_err dcdr.file_path oerr (Printf.sprintf "get_bbox (gid = %d)" gidorg) + | Ok(None) -> bbox_zero (* needs reconsideration; maybe should emit an error *) + | Ok(Some(pathlst)) -> + begin + match Otfm.charstring_bbox pathlst with + | None -> + bbox_zero + + | Some(bbox_raw) -> + let (xmin_raw, ymin_raw, xmax_raw, ymax_raw) = bbox_raw in + let f = per_mille dcdr in + (f xmin_raw, f ymin_raw, f xmax_raw, f ymax_raw) + end + end + + +(* PUBLIC *) +let get_glyph_metrics (dcdr : decoder) (gid : glyph_id) : metrics = + let bboxtbl = dcdr.glyph_bbox_table in + let gidorg = get_original_gid dcdr gid in + let (wid, (_, ymin, _, ymax)) = + match bboxtbl |> GlyphBBoxTable.find_opt gidorg with + | Some(pair) -> + pair + + | None -> + let wid = get_glyph_advance_width dcdr gidorg in + let bbox = get_bbox dcdr gidorg in + let pair = (wid, bbox) in + begin + bboxtbl |> GlyphBBoxTable.add gidorg pair; + pair + end + in + let hgt = ymax in + let dpt = ymin in + (wid, hgt, dpt) + + type 'a resource = | Data of 'a | EmbeddedStream of int @@ -775,16 +889,6 @@ type font_stretch = | SemiExpandedStretch | ExpandedStretch | ExtraExpandedStretch | UltraExpandedStretch -let get_original_gid (dcdr : decoder) (gid : glyph_id) : original_glyph_id = -(* - match dcdr.subset_map |> SubsetMap.find_rev_opt gid with - | None -> assert false - | Some(gidorg) -> gidorg -*) - let SubsetGlyphID(gidorg, _) = gid in - gidorg - - let intern_gid (dcdr : decoder) (gidorg : original_glyph_id) : glyph_id = SubsetGlyphID(gidorg, dcdr.subset_map |> SubsetMap.intern gidorg) @@ -985,9 +1089,6 @@ let get_glyph_id (dcdr : decoder) (uch : Uchar.t) : glyph_id option = return gid -let per_mille (dcdr : decoder) (w : design_units) : per_mille = - per_mille_raw dcdr.units_per_em w - (* let get_glyph_raw_contour_list_and_bounding_box (dcdr : decoder) (gidorg : original_glyph_id) : ((((bool * design_units * design_units) list) list * (design_units * design_units * design_units * design_units)) option) ok = @@ -1004,34 +1105,6 @@ let get_glyph_raw_contour_list_and_bounding_box (dcdr : decoder) (gidorg : origi | (`Simple(precntrlst), bbox) -> return (Some((precntrlst, bbox))) *) -let get_glyph_raw_bbox (dcdr : decoder) (gidorg : original_glyph_id) - : ((design_units * design_units * design_units * design_units) option) ok = - let d = dcdr.main in - let open ResultMonad in - Otfm.loca d gidorg >>= function - | None -> - return None - - | Some(gloc) -> - Otfm.glyf d gloc >>= fun (_, rawbbox) -> - return (Some(rawbbox)) - - -let get_glyph_advance_width (dcdr : decoder) (gidorgkey : original_glyph_id) : per_mille = - let d = dcdr.main in - let hmtxres = - None |> Otfm.hmtx d (fun accopt gidorg adv lsb -> - match accopt with - | Some(_) -> accopt - | None -> if gidorg = gidorgkey then Some((adv, lsb)) else None - ) - in - match hmtxres with - | Error(e) -> raise_err dcdr.file_path e (Printf.sprintf "get_glyph_advance_width (gid = %d)" gidorgkey) - | Ok(None) -> PerMille(0) - | Ok(Some((adv, lsb))) -> per_mille dcdr adv - - let of_per_mille = function | PerMille(x) -> Pdf.Integer(x) @@ -1648,7 +1721,10 @@ let convert_to_ligatures (dcdr : decoder) (seglst : glyph_segment list) : glyph_ | Match(gidorglig, markorginfolst, segorgrest) -> let markinfolst = - markorginfolst |> List.map (fun (gidorg, v) -> (Mark(intf gidorg, v))) + markorginfolst |> List.map (fun (gidorg, v) -> + let (w, _, _) = get_glyph_metrics dcdr (intf gidorg) in + Mark(intf gidorg, w, v) + ) in aux (Alist.extend acc (intf gidorglig, markinfolst)) segorgrest in @@ -1698,78 +1774,6 @@ type math_decoder = } -let bbox_zero = - (PerMille(0), PerMille(0), PerMille(0), PerMille(0)) - - -let get_ttf_bbox (dcdr : decoder) (gidorg : original_glyph_id) : bbox = - let f = per_mille dcdr in - match get_glyph_raw_bbox dcdr gidorg with -(* - | Error(`Missing_required_table(t)) - when t = Otfm.Tag.loca -> -*) - | Error(e) -> - raise_err dcdr.file_path e (Printf.sprintf "get_ttf_bbox (gid = %d)" gidorg) - - | Ok(None) -> - bbox_zero - - | Ok(Some(bbox_raw)) -> - let (xmin_raw, ymin_raw, xmax_raw, ymax_raw) = bbox_raw in - (f xmin_raw, f ymin_raw, f xmax_raw, f ymax_raw) - - - -let get_bbox (dcdr : decoder) (gidorg : original_glyph_id) : bbox = - match dcdr.charstring_info with - | None -> - (* -- if the font is TrueType OT -- *) - get_ttf_bbox dcdr gidorg - - | Some(csinfo) -> - (* -- if the font is CFF OT -- *) - begin - match Otfm.charstring_absolute csinfo gidorg with - | Error(oerr) -> raise_err dcdr.file_path oerr (Printf.sprintf "get_bbox (gid = %d)" gidorg) - | Ok(None) -> bbox_zero (* needs reconsideration; maybe should emit an error *) - | Ok(Some(pathlst)) -> - begin - match Otfm.charstring_bbox pathlst with - | None -> - bbox_zero - - | Some(bbox_raw) -> - let (xmin_raw, ymin_raw, xmax_raw, ymax_raw) = bbox_raw in - let f = per_mille dcdr in - (f xmin_raw, f ymin_raw, f xmax_raw, f ymax_raw) - end - end - - -(* PUBLIC *) -let get_glyph_metrics (dcdr : decoder) (gid : glyph_id) : metrics = - let bboxtbl = dcdr.glyph_bbox_table in - let gidorg = get_original_gid dcdr gid in - let (wid, (_, ymin, _, ymax)) = - match bboxtbl |> GlyphBBoxTable.find_opt gidorg with - | Some(pair) -> - pair - - | None -> - let wid = get_glyph_advance_width dcdr gidorg in - let bbox = get_bbox dcdr gidorg in - let pair = (wid, bbox) in - begin - bboxtbl |> GlyphBBoxTable.add gidorg pair; - pair - end - in - let hgt = ymax in - let dpt = ymin in - (wid, hgt, dpt) - - let math_base_font (md : math_decoder) : decoder = md.as_normal_font diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index 0737c05a6..2e83fed3f 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -9,7 +9,7 @@ type per_mille = | PerMille of int type mark_info = - | Mark of glyph_id * (per_mille * per_mille) + | Mark of glyph_id * per_mille * (per_mille * per_mille) type glyph_synthesis = glyph_id * mark_info list diff --git a/src/backend/graphicD.ml b/src/backend/graphicD.ml index b454de223..50ad9e7cc 100644 --- a/src/backend/graphicD.ml +++ b/src/backend/graphicD.ml @@ -196,17 +196,34 @@ let pdfops_of_fill (fill_color : color) (pathlst : path list) : Pdfops.t list = let pdfops_of_text (pt : point) (rising : length) (tag : string) (fontsize : length) (color : color) (otxt : OutputText.t) = - [ - op_cm_translate (Length.zero, Length.zero); - op_q; - pdfop_of_text_color color; - op_BT; - op_Tm_translate pt; - op_Tf tag fontsize; - op_Ts rising; - op_TJ (OutputText.to_TJ_argument otxt); - op_ET; - op_Q; + let pdfopstxt = + (OutputText.to_TJ_arguments otxt) |> List.fold_left (fun acc (hopt, pdfobjs) -> + let optxt = op_TJ (Pdf.Array(pdfobjs)) in + match hopt with + | None -> + Alist.extend acc optxt + + | Some(FontFormat.PerMille(h)) -> + let r = fontsize *% (float_of_int h *. 0.001) in + Alist.append acc [op_Ts (rising +% r); optxt] + + ) Alist.empty |> Alist.to_list + in + List.concat [ + [ + op_cm_translate (Length.zero, Length.zero); + op_q; + pdfop_of_text_color color; + op_BT; + op_Tm_translate pt; + op_Tf tag fontsize; + op_Ts rising; + ]; + pdfopstxt; + [ + op_ET; + op_Q; + ]; ] diff --git a/src/backend/outputText.ml b/src/backend/outputText.ml index 52454fcaa..a3180da1d 100644 --- a/src/backend/outputText.ml +++ b/src/backend/outputText.ml @@ -1,41 +1,74 @@ type element = - | Data of string - | Kern of int - [@@deriving show] + | Data of string + | Kern of int (* -- negative if two characters are closer -- *) + | Raise of (int * int) * int * string -type style = - | Literal - | Hex - [@@deriving show] +type t = element Alist.t -type t = style * element Alist.t let pp fmt _ = Format.fprintf fmt "" -let empty_hex_style = (Hex, Alist.empty) +let empty_hex_style = Alist.empty -let append_kern (sty, otxtmain) rawwid = - (sty, Alist.extend otxtmain (Kern(rawwid))) +let append_kern otxt rawwid = + Alist.extend otxt (Kern(rawwid)) -let append_glyph_synthesis (sty, otxtmain) (gid, markinfolst) = + +let append_glyph_synthesis otxt (FontFormat.PerMille(w)) (gid, markinfolst) = let data = FontFormat.hex_of_glyph_id gid in - (sty, Alist.extend otxtmain (Data(data))) + let otxt = Alist.extend otxt (Data(data)) in + match markinfolst with + | [] -> + otxt + | _ :: _ -> + let otxt = Alist.extend otxt (Kern(w)) in + let otxt = + markinfolst |> List.fold_left (fun otxt (FontFormat.Mark(gidmark, FontFormat.PerMille(wmark), v)) -> + let (FontFormat.PerMille(x), FontFormat.PerMille(y)) = v in + let data = FontFormat.hex_of_glyph_id gidmark in + Alist.extend otxt (Raise((x, y), wmark, data)) + ) otxt + in + let otxt = Alist.extend otxt (Kern(-w)) in + otxt -let to_TJ_argument (sty, otxtmain) = - let pdfstr = - match sty with - | Literal -> (fun x -> Pdf.String(x)) - | Hex -> (fun x -> Pdf.StringHex(x)) - in - let lst = - otxtmain |> Alist.to_list |> List.map (function - | Data(data) -> pdfstr data - | Kern(rawwid) -> Pdf.Integer(-rawwid) - ) + +let backward rawwid = + Pdf.Integer(rawwid) + + +let forward rawwid = + backward (-rawwid) + + +let to_TJ_arguments otxt : (FontFormat.per_mille option * Pdf.pdfobject list) list = + let (tjargacc, acc) = + otxt |> Alist.to_list |> List.fold_left (fun (tjargacc, acc) elem -> + match elem with + | Data(data) -> + (tjargacc, Alist.extend acc (Pdf.StringHex(data))) + + | Kern(rawwid) -> + (tjargacc, Alist.extend acc (forward rawwid)) + + | Raise((x, y), w, data) -> + let tjarg = + (Some(FontFormat.PerMille(y)), [forward x; Pdf.StringHex(data); backward (x + w)]) + in + let tjargaccnew = + match Alist.to_list acc with + | [] -> Alist.extend tjargacc tjarg + | _ :: _ -> Alist.extend (Alist.extend tjargacc (None, Alist.to_list acc)) tjarg + in + (tjargaccnew, Alist.empty) + + ) (Alist.empty, Alist.empty) in - Pdf.Array(lst) + match Alist.to_list acc with + | [] -> Alist.to_list tjargacc + | _ :: _ -> Alist.to_list (Alist.extend tjargacc (None, Alist.to_list acc)) diff --git a/src/backend/outputText.mli b/src/backend/outputText.mli index bf413da44..1c41f8ab8 100644 --- a/src/backend/outputText.mli +++ b/src/backend/outputText.mli @@ -5,8 +5,8 @@ val empty_hex_style : t val append_kern : t -> int -> t -val append_glyph_synthesis : t -> FontFormat.glyph_synthesis -> t +val append_glyph_synthesis : t -> FontFormat.per_mille -> FontFormat.glyph_synthesis -> t -val to_TJ_argument : t -> Pdf.pdfobject +val to_TJ_arguments : t -> (FontFormat.per_mille option * Pdf.pdfobject list) list val pp : Format.formatter -> t -> unit diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index d10cb6769..cc5e17e3d 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -130,7 +130,7 @@ let raw_length_to_skip_length (fontsize : length) (FontFormat.PerMille(rawlen) : fontsize *% ((float_of_int rawlen) /. 1000.) -let ( @>> ) = OutputText.append_glyph_synthesis +let ( @>> ) otxt (wpm, gsyn) = OutputText.append_glyph_synthesis otxt wpm gsyn let ( @*> ) = OutputText.append_kern @@ -141,23 +141,24 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd let (_, otxt, rawwid, rawhgt, rawdpt) = gsynlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) gsyn -> let (gid, _) = gsyn in - let (FontFormat.PerMille(w), FontFormat.PerMille(h), FontFormat.PerMille(d)) = metricsf gid in + let (wpm, FontFormat.PerMille(h), FontFormat.PerMille(d)) = metricsf gid in + let FontFormat.PerMille(w) = wpm in let (tjsaccnew, waccnew) = match gidprevopt with | None -> - (otxtacc @>> gsyn, wacc + w) + (otxtacc @>> (wpm, gsyn), wacc + w) | Some(gidprev) -> begin match FontFormat.find_kerning dcdr gidprev gid with | None -> - (otxtacc @>> gsyn, wacc + w) + (otxtacc @>> (wpm, gsyn), wacc + w) | Some(FontFormat.PerMille(wkern)) -> (* PrintForDebug.kernE (Printf.sprintf "Use KERN (%d, %d) = %d" (FontFormat.gid gidprev) (FontFormat.gid gid) wkern); (* for debug *) *) - ((otxtacc @*> wkern) @>> gsyn, wacc + w + wkern) + ((otxtacc @*> wkern) @>> (wpm, gsyn), wacc + w + wkern) (* -- kerning value is negative if two characters are supposed to be closer -- *) end in From c7e32955ed58134c55d1c940288275bd9aeb03c5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 21:30:33 +0900 Subject: [PATCH 16/78] extend 'FontInfo' to handle diacritical marks --- src/backend/fontFormat.ml | 3 +++ src/backend/fontFormat.mli | 2 ++ src/chardecoder/convertText.ml | 6 ++++-- src/frontend/fontInfo.ml | 36 ++++++++++++++++++++++++++-------- src/frontend/fontInfo.mli | 4 +++- 5 files changed, 40 insertions(+), 11 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 48696d0d1..846702221 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -164,6 +164,9 @@ type original_glyph_segment = original_glyph_id * original_glyph_id list type glyph_segment = glyph_id * glyph_id list +let notdef = SubsetGlyphID(0, 0) + + let hex_of_glyph_id ((SubsetGlyphID(_, gidsub)) : glyph_id) = let b0 = gidsub / 256 in let b1 = gidsub mod 256 in diff --git a/src/backend/fontFormat.mli b/src/backend/fontFormat.mli index 2e83fed3f..a5d09c494 100644 --- a/src/backend/fontFormat.mli +++ b/src/backend/fontFormat.mli @@ -3,6 +3,8 @@ type file_path = string type glyph_id +val notdef : glyph_id + type glyph_segment = glyph_id * glyph_id list type per_mille = diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index 3819d069d..b1ab75d61 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -142,7 +142,8 @@ let unbreakable_space ctx : lb_box = let inner_string_pure (ctx : context_main) (script : script) (uchlst : Uchar.t list) : lb_pure_box = let hsinfo = get_string_info ctx script in - let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchlst in + let uchseglst = uchlst |> List.map (fun uch -> (uch, [])) in (* temporary; empty marks *) + let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) (* @@ -170,7 +171,8 @@ let generate_separation_list (uchlstlst : (Uchar.t list) list) : (Uchar.t list * let make_string_atom (hsinfo : horz_string_info) (uchlst : Uchar.t list) : lb_pure_box = - let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchlst in + let uchseglst = uchlst |> List.map (fun uch -> (uch, [])) in (* temporary; empty marks *) + let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index cc5e17e3d..aec317663 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -134,9 +134,7 @@ let ( @>> ) otxt (wpm, gsyn) = OutputText.append_glyph_synthesis otxt wpm gsyn let ( @*> ) = OutputText.append_kern -let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcdr : FontFormat.decoder) (gidlst : FontFormat.glyph_id list) : FontFormat.glyph_id list * OutputText.t * FontFormat.metrics = - - let gsynlst = FontFormat.convert_to_ligatures dcdr (gidlst |> List.map (fun gid -> (gid, []))) (* temporary *) in +let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcdr : FontFormat.decoder) (gsynlst : FontFormat.glyph_synthesis list) : FontFormat.glyph_id list * OutputText.t * FontFormat.metrics = let (_, otxt, rawwid, rawhgt, rawdpt) = gsynlst |> List.fold_left (fun (gidprevopt, otxtacc, wacc, hacc, dacc) gsyn -> @@ -168,7 +166,21 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd (gsynlst |> List.map (fun (gid, _) -> gid) (* temporary *), otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) -let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : OutputText.t * length * length * length = +type uchar_segment = Uchar.t * Uchar.t list + + +let get_glyph_id dcdr uch = + match FontFormat.get_glyph_id dcdr uch with + | None -> + Format.printf "FontFormat> No glyph is associated with U+%04X.\n" (Uchar.to_int uch); + (* temporary; should emit a warning in a more sophisticated manner *) + FontFormat.notdef + + | Some(gid) -> + gid + + +let get_metrics_of_word (hsinfo : horz_string_info) (uchseglst : uchar_segment list) : OutputText.t * length * length * length = let font_abbrev = hsinfo.font_abbrev in let f_skip = raw_length_to_skip_length hsinfo.text_font_size in match FontAbbrevHashTable.find_opt font_abbrev with @@ -177,10 +189,15 @@ let get_metrics_of_word (hsinfo : horz_string_info) (uchlst : Uchar.t list) : Ou | Some(dfn) -> let dcdr = dfn.decoder in - let gidoptlst = uchlst |> List.map (FontFormat.get_glyph_id dcdr) in - let gidlst = list_some gidoptlst in - (* needs reconsideration; maybe should return GID 0 for code points which is not covered by the font *) - let (_, otxt, (rawwid, rawhgt, rawdpt)) = convert_gid_list (FontFormat.get_glyph_metrics dcdr) dcdr gidlst in + let gseglst = + uchseglst |> List.map (fun (ubase, umarks) -> + let gbase = get_glyph_id dcdr ubase in + let gmarks = List.map (get_glyph_id dcdr) umarks in + (gbase, gmarks) + ) + in + let gsynlst = FontFormat.convert_to_ligatures dcdr gseglst in + let (_, otxt, (rawwid, rawhgt, rawdpt)) = convert_gid_list (FontFormat.get_glyph_metrics dcdr) dcdr gsynlst in let wid = f_skip rawwid in let hgtsub = f_skip rawhgt in let dptsub = f_skip rawdpt in @@ -359,6 +376,7 @@ let get_math_char_info (mathctx : math_context) (is_in_display : bool) (is_big : else FontFormat.get_math_script_variant md gidraw in + let gid = if is_in_display && is_big then match FontFormat.get_math_vertical_variants md gidsub with | [] -> gidsub @@ -373,6 +391,8 @@ let get_math_char_info (mathctx : math_context) (is_in_display : bool) (is_big : (* -- somewhat ad-hoc; uses the second smallest as the glyph for display style -- *) else gidsub + in + (gid, []) (* temporary; empty marks *) ) in let (gidligedlst, otxt, (rawwid, rawhgt, rawdpt)) = diff --git a/src/frontend/fontInfo.mli b/src/frontend/fontInfo.mli index 782696b30..abe5255c6 100644 --- a/src/frontend/fontInfo.mli +++ b/src/frontend/fontInfo.mli @@ -13,7 +13,9 @@ type tag = string val initialize : unit -> unit -val get_metrics_of_word : horz_string_info -> Uchar.t list -> OutputText.t * length * length * length +type uchar_segment = Uchar.t * Uchar.t list + +val get_metrics_of_word : horz_string_info -> uchar_segment list -> OutputText.t * length * length * length val get_math_char_info : math_context -> bool -> bool -> Uchar.t list -> OutputText.t * length * length * length * length * FontFormat.math_kern_info option From 06edd7d9a91880f7acce86cacb5dbc598abecf00 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 12 Aug 2018 23:52:46 +0900 Subject: [PATCH 17/78] extend text procedure to handle diacritical marks --- src/backend/lineBreakBox.ml | 4 +- src/backend/loadHyph.ml | 36 ++++--- src/backend/loadHyph.mli | 8 +- src/chardecoder/charBasis.ml | 4 +- src/chardecoder/convertText.ml | 54 +++++----- src/chardecoder/lineBreakDataMap.ml | 160 +++++++++++++++++++++++----- src/chardecoder/scriptDataMap.ml | 51 +++++---- src/frontend/fontInfo.ml | 4 +- src/frontend/fontInfo.mli | 3 +- 9 files changed, 220 insertions(+), 104 deletions(-) diff --git a/src/backend/lineBreakBox.ml b/src/backend/lineBreakBox.ml index 5544365a6..9cf409159 100644 --- a/src/backend/lineBreakBox.ml +++ b/src/backend/lineBreakBox.ml @@ -58,7 +58,7 @@ let natural wid = type line_break_chunk_main = - | AlphabeticChunk of script * line_break_class * line_break_class * Uchar.t list * break_opportunity + | AlphabeticChunk of script * line_break_class * line_break_class * uchar_segment list * break_opportunity (* -- (1) script (2) line break class for the previous chunk @@ -68,7 +68,7 @@ type line_break_chunk_main = -- *) | Space | UnbreakableSpace - | IdeographicChunk of script * line_break_class * Uchar.t * break_opportunity + | IdeographicChunk of script * line_break_class * uchar_segment * break_opportunity (* -- (1) script (2) line break class diff --git a/src/backend/loadHyph.ml b/src/backend/loadHyph.ml index 158a18ac5..f336b29fc 100644 --- a/src/backend/loadHyph.ml +++ b/src/backend/loadHyph.ml @@ -1,5 +1,6 @@ open MyUtil +open CharBasis open Config @@ -35,8 +36,8 @@ type pattern = beginning * (Uchar.t * number) list * final type t = exception_map * pattern list type answer = - | Single of Uchar.t list - | Fractions of (Uchar.t list) list + | Single of uchar_segment list + | Fractions of (uchar_segment list) list let read_exception_list (srcpath : file_path) (jsonarr : Yojson.Safe.json) : exception_map = @@ -173,7 +174,7 @@ let main (filename : file_path) : t = let empty = (ExceptionMap.empty, []) -let match_prefix (opt : (number ref * number) option) (pairlst : (Uchar.t * number) list) (clst : (Uchar.t * number ref) list) : unit = +let match_prefix (opt : (number ref * number) option) (pairlst : (Uchar.t * number) list) (clst : (uchar_segment * number ref) list) : unit = let rec aux acc pairlst clst = match (pairlst, clst) with | (_ :: _, []) -> @@ -182,7 +183,7 @@ let match_prefix (opt : (number ref * number) option) (pairlst : (Uchar.t * numb | ([], _) -> acc |> Alist.to_list |> List.iter (fun (numref, num) -> numref := max (!numref) num) - | ((uchp, num) :: pairtail, (uchw, numref) :: ctail) -> + | ((uchp, num) :: pairtail, ((uchw, _), numref) :: ctail) -> if Uchar.equal uchp uchw then aux (Alist.extend acc (numref, num)) pairtail ctail else @@ -222,9 +223,9 @@ let make_fraction fracacc = 'lookup_patterns': determines hyphen pattern of the given word. this implemenmtation is currently very inefficient. -- *) -let lookup_patterns (lmin : int) (rmin : int) (patlst : pattern list) (uchlst : Uchar.t list) : (Uchar.t list) list = - let len = List.length uchlst in - let clst = uchlst |> List.map (fun uch -> (uch, ref 0)) in +let lookup_patterns (lmin : int) (rmin : int) (patlst : pattern list) (uchseglst : uchar_segment list) : (uchar_segment list) list = + let len = List.length uchseglst in + let clst = uchseglst |> List.map (fun uchseg -> (uchseg, ref 0)) in let () = patlst |> List.iter (fun (beginning, pairlst, final) -> match beginning with @@ -233,7 +234,7 @@ let lookup_patterns (lmin : int) (rmin : int) (patlst : pattern list) (uchlst : ) in let (_, acc, fracaccopt) = - clst |> List.fold_left (fun (i, acc, fracaccopt) (uch, numref) -> + clst |> List.fold_left (fun (i, acc, fracaccopt) (uchseg, numref) -> if (!numref) mod 2 = 1 && i + 1 >= lmin && len - (i + 1) >= rmin then (* -- if able to break the word with hyphen immediately after the current position -- *) let fracacc = @@ -241,12 +242,12 @@ let lookup_patterns (lmin : int) (rmin : int) (patlst : pattern list) (uchlst : | Some(fracacc) -> fracacc | None -> Alist.empty in - let sfrac = make_fraction (Alist.extend fracacc uch) in + let sfrac = make_fraction (Alist.extend fracacc uchseg) in (i + 1, Alist.extend acc sfrac, None) else match fracaccopt with - | Some(fracacc) -> (i + 1, acc, Some(Alist.extend fracacc uch)) - | None -> (i + 1, acc, Some(Alist.extend Alist.empty uch)) + | Some(fracacc) -> (i + 1, acc, Some(Alist.extend fracacc uchseg)) + | None -> (i + 1, acc, Some(Alist.extend Alist.empty uchseg)) ) (0, Alist.empty, None) in match fracaccopt with @@ -254,11 +255,18 @@ let lookup_patterns (lmin : int) (rmin : int) (patlst : pattern list) (uchlst : | None -> acc |> Alist.to_list -let lookup (lmin : int) (rmin : int) ((excpmap, patlst) : t) (uchlst : Uchar.t list) : answer = +let lookup (lmin : int) (rmin : int) ((excpmap, patlst) : t) (uchseglst : uchar_segment list) : answer = let fraclst = + let uchlst = uchseglst |> List.map (fun (u, _) -> u) in match excpmap |> ExceptionMap.find_opt (InternalText.to_utf8 (InternalText.of_uchar_list uchlst)) with - | Some(sfraclst) -> sfraclst |> List.map (fun sfrac -> InternalText.to_uchar_list (InternalText.of_utf8 sfrac)) - | None -> lookup_patterns lmin rmin patlst uchlst + | Some(sfraclst) -> + sfraclst |> List.map (fun sfrac -> + let uchlst = InternalText.to_uchar_list (InternalText.of_utf8 sfrac) in + uchlst |> List.map (fun uch -> (uch, [])) + ) + + | None -> + lookup_patterns lmin rmin patlst uchseglst in match fraclst with | frac :: [] -> Single(frac) diff --git a/src/backend/loadHyph.mli b/src/backend/loadHyph.mli index 864fc9d2f..2d89e8d6d 100644 --- a/src/backend/loadHyph.mli +++ b/src/backend/loadHyph.mli @@ -1,4 +1,6 @@ +open CharBasis + type dir_path = string type file_path = string @@ -14,11 +16,11 @@ exception InvalidPatternElement of file_path type t type answer = - | Single of Uchar.t list - | Fractions of (Uchar.t list) list + | Single of uchar_segment list + | Fractions of (uchar_segment list) list val empty : t val main : file_path -> t -val lookup : int -> int -> t -> Uchar.t list -> answer +val lookup : int -> int -> t -> uchar_segment list -> answer diff --git a/src/chardecoder/charBasis.ml b/src/chardecoder/charBasis.ml index 04dc1a421..5cec4d184 100644 --- a/src/chardecoder/charBasis.ml +++ b/src/chardecoder/charBasis.ml @@ -1,4 +1,6 @@ +type uchar_segment = Uchar.t * Uchar.t list + type code_point = int type code_point_kind = @@ -222,4 +224,4 @@ let rec show_lregexp lregexp = ) |> String.concat " " -type line_break_element = Uchar.t * line_break_class * break_opportunity +type line_break_element = uchar_segment * line_break_class * break_opportunity diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index b1ab75d61..3e7a4360f 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -140,9 +140,8 @@ let unbreakable_space ctx : lb_box = LBPure(pure_space ctx) -let inner_string_pure (ctx : context_main) (script : script) (uchlst : Uchar.t list) : lb_pure_box = +let inner_string_pure (ctx : context_main) (script : script) (uchseglst : uchar_segment list) : lb_pure_box = let hsinfo = get_string_info ctx script in - let uchseglst = uchlst |> List.map (fun uch -> (uch, [])) in (* temporary; empty marks *) let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) @@ -153,50 +152,49 @@ let soft_hyphen ctx script () : lb_box = LBDiscretionary(ctx.hyphen_badness, dscrid, [], [lphb_hyphen], []) *) -let generate_separation_list (uchlstlst : (Uchar.t list) list) : (Uchar.t list * Uchar.t list) list = - let rec aux (acc : (Uchar.t list * Uchar.t list) Alist.t) (revprefix : Uchar.t Alist.t) (suffix : (Uchar.t list) list) = +let generate_separation_list (uchseglstlst : (uchar_segment list) list) : (uchar_segment list * uchar_segment list) list = + let rec aux acc revprefix suffix = match suffix with | [] -> Alist.to_list acc - | uchlst :: [] -> + | uchseglst :: [] -> Alist.to_list acc - | uchlst :: suffixnew -> - let revprefixnew = Alist.append revprefix uchlst in + | uchseglst :: suffixnew -> + let revprefixnew = Alist.append revprefix uchseglst in let accnew = Alist.extend acc (Alist.to_list revprefixnew, List.concat suffixnew) in aux accnew revprefixnew suffixnew in - aux Alist.empty Alist.empty uchlstlst + aux Alist.empty Alist.empty uchseglstlst -let make_string_atom (hsinfo : horz_string_info) (uchlst : Uchar.t list) : lb_pure_box = - let uchseglst = uchlst |> List.map (fun uch -> (uch, [])) in (* temporary; empty marks *) +let make_string_atom (hsinfo : horz_string_info) (uchseglst : uchar_segment list) : lb_pure_box = let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) (* -- 'inner_string': makes an alphabetic word or a CJK character -- *) -let inner_string (ctx : context_main) (script : script) (uchlst : Uchar.t list) : lb_box list = +let inner_string (ctx : context_main) (script : script) (uchseglst : uchar_segment list) : lb_box list = let hsinfo = get_string_info ctx script in (* let lbhyphenf = soft_hyphen ctx script in *) - match LoadHyph.lookup ctx.left_hyphen_min ctx.right_hyphen_min ctx.hyphen_dictionary uchlst with - | LoadHyph.Single(uchlst) -> - [LBPure(make_string_atom hsinfo uchlst)] - - | LoadHyph.Fractions(uchlstlst) -> - let uchlst0 = List.concat uchlstlst in - let lphb0 = make_string_atom hsinfo uchlst0 in - let lphb_hyphen = inner_string_pure ctx script [Uchar.of_char '-'] in - let seplst = generate_separation_list uchlstlst in + match LoadHyph.lookup ctx.left_hyphen_min ctx.right_hyphen_min ctx.hyphen_dictionary uchseglst with + | LoadHyph.Single(uchseglst) -> + [LBPure(make_string_atom hsinfo uchseglst)] + + | LoadHyph.Fractions(uchseglstlst) -> + let uchseglst0 = List.concat uchseglstlst in + let lphb0 = make_string_atom hsinfo uchseglst0 in + let lphb_hyphen = inner_string_pure ctx script [(Uchar.of_char '-', [])] in (* temporary; should be variable *) + let seplst = generate_separation_list uchseglstlst in let dscrlst = - seplst |> List.fold_left (fun dscracc (uchlstP, uchlstS) -> - let lphbP = make_string_atom hsinfo uchlstP in - let lphbS = make_string_atom hsinfo uchlstS in + seplst |> List.fold_left (fun dscracc (uchseglstP, uchseglstS) -> + let lphbP = make_string_atom hsinfo uchseglstP in + let lphbS = make_string_atom hsinfo uchseglstS in let dscrid = DiscretionaryID.fresh () in - Alist.extend dscracc (dscrid, [lphbP; lphb_hyphen], [lphbS]) + Alist.extend dscracc (dscrid, [lphbP; lphb_hyphen], [lphbS]) ) Alist.empty |> Alist.to_list in [LBDiscretionaryList(ctx.hyphen_badness, [lphb0], dscrlst)] @@ -354,9 +352,9 @@ let chunks_to_boxes (lphbf : horz_box list -> lb_pure_box list) (script_before : | UnbreakableSpace -> (AccNone, [unbreakable_space ctx]) - | AlphabeticChunk(script, lbcfirst, lbclast, uchlst, alwnext) -> + | AlphabeticChunk(script, lbcfirst, lbclast, uchseglst, alwnext) -> let opt = AccSome(((ctx, script, lbclast), alwnext)) in - let lhblststr = inner_string ctx script uchlst in + let lhblststr = inner_string ctx script uchseglst in begin match optprev with | AccInitial -> @@ -372,9 +370,9 @@ let chunks_to_boxes (lphbf : horz_box list -> lb_pure_box list) (script_before : (opt, List.append autospace lhblststr) end - | IdeographicChunk(script, lbc, uch, alwnext) -> + | IdeographicChunk(script, lbc, uchseg, alwnext) -> let opt = AccSome((ctx, script, lbc), alwnext) in - let lhblststr = ideographic_single ctx script lbc [uch] in + let lhblststr = ideographic_single ctx script lbc [uchseg] in begin match optprev with | AccNone -> diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index 9add5b4b4..69619eef5 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -136,8 +136,11 @@ let nonspaced = set [ID; CJ; IN; SA; JLOP; JLCP; JLNS; JLMD; JLFS; JLCM; JLPL; J let bispace = (Uchar.of_int 32, SP) (* -- space character -- *) +type 'a rule = line_break_regexp * 'a * line_break_regexp + + (* -- the rules for normalizing texts about spaces, break letters, etc. -- *) -let normalization_rule = +let normalization_rule : (((Uchar.t * line_break_class) list) rule) list = [ (* -- ignore spaces or break letters *) ([nonspaced; set [SP; INBR]], [], [spaced]); @@ -149,7 +152,7 @@ let normalization_rule = (* -- the rules for inserting line break opportunities based on [UAX#14 Section 6] -- *) -let line_break_rule = +let line_break_rule : (break_opportunity rule) list = [ (* -- LB7 -- *) ([], PreventBreak, [exact SP]); @@ -231,7 +234,7 @@ let line_break_rule = (* -- a naive, greedy regexp matching (it suffices to use greedy one) -- *) -let match_prefix (type a) (getf : a -> line_break_class) (trilst : a list) (lregexp : line_break_regexp) = +let match_prefix (type a) (getf : a -> line_break_class) (trilst : a list) (lregexp : line_break_regexp) : bool = let rec cut trilst lregexp = match lregexp with | [] -> Some(trilst) @@ -265,7 +268,7 @@ let match_prefix (type a) (getf : a -> line_break_class) (trilst : a list) (lreg | Some(_) -> true -let match_postfix getf trilst lregexp = +let match_postfix (type a) (getf : a -> line_break_class) (trilst : a list) (lregexp : line_break_regexp) : bool = let rec reverse lregexp = let lregexpsub = lregexp |> List.map (function @@ -278,10 +281,12 @@ let match_postfix getf trilst lregexp = match_prefix getf trilst (reverse lregexp) -let find_first_match rules proj1 proj2 acc lst = +let find_first_match (type a) (type b) (type c) (rules : (a rule) list) (proj1 : b -> line_break_class) (proj2 : c -> line_break_class) (acc : b list) (lst : c list) : a option = rules |> List.fold_left (fun resopt (lregexp1, rescand, lregexp2) -> match resopt with - | Some(_) -> resopt + | Some(_) -> + resopt + | None -> let b1 = match_postfix proj1 acc lregexp1 in let b2 = match_prefix proj2 lst lregexp2 in @@ -304,56 +309,161 @@ let append_property (uchlst : Uchar.t list) : (Uchar.t * line_break_class) list let rec normalize biacc bilst = match bilst with - | [] -> Alist.to_list biacc + | [] -> + Alist.to_list biacc | bihead :: bitail -> let replopt = find_first_match normalization_rule proj_bi proj_bi (bihead :: (Alist.to_list_rev biacc)) bitail in + begin match replopt with | None -> normalize (Alist.extend biacc bihead) bitail | Some(repl) -> normalize (Alist.append biacc repl) bitail + end in let bilst = uchlst |> List.map (fun uch -> (uch, find uch)) in normalize Alist.empty bilst -let append_break_opportunity (uchlst : Uchar.t list) (alw_last : break_opportunity) = +type segment_record = { + base : Uchar.t; + marks : Uchar.t Alist.t; + line_break_class : line_break_class; + end_with_ZWJ : bool; +} + + +let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segment_record list = + let (acc, segrcdopt) = + bilst |> List.fold_left (fun (acc, segrcdopt) (uch, lbc) -> + match lbc with + | CM -> + begin + match segrcdopt with + | None -> + (* -- if the CM occurs the beginning of the text, + or follows an SP/INBR/ZW or an invalid CM/ZWJ -- *) + let segrcd = + { + base = uch; + marks = Alist.empty; + line_break_class = AL; (* invalid CM is treated as if it were AL [LB10] *) + end_with_ZWJ = false; + } + in + (Alist.extend acc segrcd, None) + + | Some(segrcd) -> + (acc, Some({ segrcd with marks = Alist.extend segrcd.marks uch; end_with_ZWJ = false; })) + end + + | ZWJ -> + begin + match segrcdopt with + | None -> + (* -- if the ZWJ occurs the beginning of the text, + or follows an SP/BK/CR/LF/NL/ZW or an invalid CM/ZWJ -- *) + let segrcd = + { + base = uch; + marks = Alist.empty; + line_break_class = AL; + end_with_ZWJ = true; + } + in + (Alist.extend acc segrcd, None) + + | Some(segrcd) -> + (acc, Some({ segrcd with marks = Alist.extend segrcd.marks uch; end_with_ZWJ = true; })) + end + + | INBR | SP | ZW -> + let segrcd = + { + base = uch; + marks = Alist.empty; + line_break_class = lbc; + end_with_ZWJ = false; + } + in + begin + match segrcdopt with + | None -> + (Alist.extend acc segrcd, None) + + | Some(segrcdprev) -> + (Alist.extend (Alist.extend acc segrcdprev) segrcd, None) + end + + | _ -> + let segrcd = + { + base = uch; + marks = Alist.empty; + line_break_class = lbc; + end_with_ZWJ = false; + } + in + begin + match segrcdopt with + | None -> + (Alist.extend acc segrcd, None) + + | Some(segrcdprev) -> + (Alist.extend acc segrcdprev, Some(segrcd)) + end + ) (Alist.empty, None) + in + match segrcdopt with + | None -> acc |> Alist.to_list + | Some(segrcd) -> (Alist.extend acc segrcd) |> Alist.to_list - let should_prevent_break triacc bilst = - let alwopt = find_first_match line_break_rule proj_tri proj_bi triacc bilst in + +let proj_segrcd segrcd = segrcd.line_break_class + + +let append_break_opportunity (uchlst : Uchar.t list) (alw_last : break_opportunity) : break_opportunity * line_break_element list = + + let should_prevent_break (trirev : line_break_element list) segrcdlst = + let alwopt = find_first_match line_break_rule proj_tri proj_segrcd trirev segrcdlst in match alwopt with | None -> false | Some(PreventBreak) -> true | Some(AllowBreak) -> false in - let rec aux triacc bilst = - match bilst with - | [] -> [] + let rec aux triacc segrcdlst = + match segrcdlst with + | [] -> + [] - | (uch, lbc) :: bitail -> + | segrcd :: bitail -> + let uchseg = (segrcd.base, segrcd.marks |> Alist.to_list) in + let lbc = segrcd.line_break_class in begin match bitail with | [] -> - begin - Alist.to_list (Alist.extend triacc (uch, lbc, alw_last)) - end + Alist.to_list (Alist.extend triacc (uchseg, lbc, alw_last)) | _ :: _ -> - begin - let b = should_prevent_break ((uch, lbc, PreventBreak (* dummy *)) :: (Alist.to_list_rev triacc)) bitail in - let alw = if b then PreventBreak else AllowBreak in - aux (Alist.extend triacc (uch, lbc, alw)) bitail - end + let alw = + if segrcd.end_with_ZWJ then + PreventBreak + else + let b = should_prevent_break ((uchseg, lbc, PreventBreak (* dummy *)) :: (Alist.to_list_rev triacc)) bitail in + if b then PreventBreak else AllowBreak + in + aux (Alist.extend triacc (uchseg, lbc, alw)) bitail end in - let bilstinit = append_property uchlst in + let bilst = append_property uchlst in + let segrcdlst = cut_into_segment_record bilst in let alw_first = - let b_first = should_prevent_break [] bilstinit in + let b_first = should_prevent_break [] segrcdlst in if b_first then PreventBreak else AllowBreak in - let lst = aux Alist.empty bilstinit in + let lst = aux Alist.empty segrcdlst in (alw_first, lst) diff --git a/src/chardecoder/scriptDataMap.ml b/src/chardecoder/scriptDataMap.ml index b2e22bee7..f5ebce10e 100644 --- a/src/chardecoder/scriptDataMap.ml +++ b/src/chardecoder/scriptDataMap.ml @@ -63,7 +63,7 @@ let set_from_file filename_S filename_EAW = end -let find ctx uch = +let find (ctx : context_main) ((uch, _) : uchar_segment) = try (!script_map_ref) |> BatIMap.find (Uchar.to_int uch) |> normalize_script ctx @@ -72,15 +72,15 @@ let find ctx uch = let divide_by_script (ctx : context_main) (trilst : line_break_element list) : LineBreakBox.line_break_chunk_main list = - let ideographic script lbc uch alw = - IdeographicChunk(script, lbc, uch, alw) + let ideographic script lbc uchseg alw = + IdeographicChunk(script, lbc, uchseg, alw) in - let preword script lbcfirst lbclast uchlst alw = - AlphabeticChunk(script, lbcfirst, lbclast, uchlst, alw) + let preword script lbcfirst lbclast uchseglst alw = + AlphabeticChunk(script, lbcfirst, lbclast, uchseglst, alw) in - let rec aux resacc (scraccopt : (line_break_class * script * line_break_class * Uchar.t list) option) trilst = + let rec aux resacc (scraccopt : (line_break_class * script * line_break_class * uchar_segment list) option) trilst = match trilst with | [] -> begin @@ -88,8 +88,8 @@ let divide_by_script (ctx : context_main) (trilst : line_break_element list) : L | None -> Alist.to_list resacc - | Some((lbcfirst, scriptprev, lbcprev, uchacc)) -> - let chunk = preword scriptprev lbcfirst lbcprev (List.rev uchacc) PreventBreak in + | Some((lbcfirst, scriptprev, lbcprev, uchsegacc)) -> + let chunk = preword scriptprev lbcfirst lbcprev (List.rev uchsegacc) PreventBreak in Alist.to_list (Alist.extend resacc chunk) end @@ -104,25 +104,25 @@ let divide_by_script (ctx : context_main) (trilst : line_break_element list) : L | None -> aux (Alist.extend resacc chunkspace) None tritail - | Some((lbcfirst, scriptprev, lbcprev, uchacc)) -> - let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchacc) PreventBreak in + | Some((lbcfirst, scriptprev, lbcprev, uchsegacc)) -> + let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchsegacc) PreventBreak in aux (Alist.append resacc [chunkprev; chunkspace]) None tritail end - | (uch, lbc, alw) :: tritail -> - let script = find ctx uch in + | (uchseg, lbc, alw) :: tritail -> + let script = find ctx uchseg in if is_ideographic_class lbc then (* temporary; whether 'AI' is ideographic or not should depend on the context *) (* -- if the spotted character is ideographic -- *) begin match scraccopt with | None -> - let chunkideo = ideographic script lbc uch alw in + let chunkideo = ideographic script lbc uchseg alw in aux (Alist.extend resacc chunkideo) None tritail | Some((lbcfirst, scriptprev, lbcprev, uchacc)) -> (* -- if there accumulate some characters before the spotted character -- *) - let chunkideo = ideographic script lbc uch alw in + let chunkideo = ideographic script lbc uchseg alw in let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchacc) PreventBreak in aux (Alist.append resacc [chunkprev; chunkideo]) None tritail end @@ -134,16 +134,16 @@ let divide_by_script (ctx : context_main) (trilst : line_break_element list) : L begin match scraccopt with | None -> - let chunk = preword script lbc lbc [uch] AllowBreak in + let chunk = preword script lbc lbc [uchseg] AllowBreak in aux (Alist.extend resacc chunk) None tritail - | Some((lbcfirst, scriptprev, lbcprev, uchacc)) -> + | Some((lbcfirst, scriptprev, lbcprev, uchsegacc)) -> if script_equal scriptprev script then - let chunk = preword script lbcfirst lbc (List.rev (uch :: uchacc)) AllowBreak in + let chunk = preword script lbcfirst lbc (List.rev (uchseg :: uchsegacc)) AllowBreak in aux (Alist.extend resacc chunk) None tritail else - let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchacc) PreventBreak in - let chunk = preword script lbc lbc [uch] AllowBreak in + let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchsegacc) PreventBreak in + let chunk = preword script lbc lbc [uchseg] AllowBreak in aux (Alist.append resacc [chunkprev; chunk]) None tritail end @@ -151,17 +151,16 @@ let divide_by_script (ctx : context_main) (trilst : line_break_element list) : L begin match scraccopt with | None -> - aux resacc (Some((lbc, script, lbc, [uch]))) tritail + aux resacc (Some((lbc, script, lbc, [uchseg]))) tritail - | Some((lbcfirst, scriptprev, lbcprev, uchacc)) -> + | Some((lbcfirst, scriptprev, lbcprev, uchsegacc)) -> if script_equal scriptprev script then - aux resacc (Some((lbcfirst, script, lbc, uch :: uchacc))) tritail + aux resacc (Some((lbcfirst, script, lbc, uchseg :: uchsegacc))) tritail else - let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchacc) PreventBreak in - aux (Alist.extend resacc chunkprev) (Some((lbc, script, lbc, [uch]))) tritail + let chunkprev = preword scriptprev lbcfirst lbcprev (List.rev uchsegacc) PreventBreak in + aux (Alist.extend resacc chunkprev) (Some((lbc, script, lbc, [uchseg]))) tritail end end in - let scrlst = aux Alist.empty None trilst in - scrlst + aux Alist.empty None trilst diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index aec317663..2a734eabb 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -3,6 +3,7 @@ module Types = Types_ open MyUtil open LengthInterface open HorzBox +open CharBasis open Types open Config @@ -166,9 +167,6 @@ let convert_gid_list (metricsf : FontFormat.glyph_id -> FontFormat.metrics) (dcd (gsynlst |> List.map (fun (gid, _) -> gid) (* temporary *), otxt, (FontFormat.PerMille(rawwid), FontFormat.PerMille(rawhgt), FontFormat.PerMille(rawdpt))) -type uchar_segment = Uchar.t * Uchar.t list - - let get_glyph_id dcdr uch = match FontFormat.get_glyph_id dcdr uch with | None -> diff --git a/src/frontend/fontInfo.mli b/src/frontend/fontInfo.mli index abe5255c6..2194e17cf 100644 --- a/src/frontend/fontInfo.mli +++ b/src/frontend/fontInfo.mli @@ -2,6 +2,7 @@ module Types = Types_ open LengthInterface open HorzBox +open CharBasis open Types exception InvalidFontAbbrev of font_abbrev @@ -13,8 +14,6 @@ type tag = string val initialize : unit -> unit -type uchar_segment = Uchar.t * Uchar.t list - val get_metrics_of_word : horz_string_info -> uchar_segment list -> OutputText.t * length * length * length val get_math_char_info : math_context -> bool -> bool -> Uchar.t list -> OutputText.t * length * length * length * length * FontFormat.math_kern_info option From f70faa58f988176fdfd0046f0648eb89a828e055 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 13 Aug 2018 01:35:32 +0900 Subject: [PATCH 18/78] SUPPORT (SINGLE) COMBINING DIACRITICAL MARKS --- src/backend/fontFormat.ml | 4 +++- src/backend/graphicD.ml | 2 +- src/backend/outputText.ml | 4 ++-- src/chardecoder/convertText.ml | 2 ++ src/chardecoder/lineBreakDataMap.ml | 11 ++++++----- src/frontend/fontInfo.ml | 1 + 6 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 846702221..06d0d687c 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -539,11 +539,13 @@ module LigatureTable begin match mktbl |> MarkTable.find_opt (gobase, gomark) with | None -> + Format.printf "FontFormat> CANNOT attach a diacritical mark\n"; (* for debug *) (* if the diacritical mark cannot attach to the base *) Match(gobase, [], segorgtail) | Some(vB, vM) -> - Match(gobase, [(gomark, vM -@ vB)], segorgtail) + Format.printf "FontFormat> CAN attach a diacritical mark\n"; (* for debug *) + Match(gobase, [(gomark, vB -@ vM)], segorgtail) end | [] -> diff --git a/src/backend/graphicD.ml b/src/backend/graphicD.ml index 50ad9e7cc..80a9d80fb 100644 --- a/src/backend/graphicD.ml +++ b/src/backend/graphicD.ml @@ -201,7 +201,7 @@ let pdfops_of_text (pt : point) (rising : length) (tag : string) (fontsize : len let optxt = op_TJ (Pdf.Array(pdfobjs)) in match hopt with | None -> - Alist.extend acc optxt + Alist.append acc [op_Ts rising; optxt] | Some(FontFormat.PerMille(h)) -> let r = fontsize *% (float_of_int h *. 0.001) in diff --git a/src/backend/outputText.ml b/src/backend/outputText.ml index a3180da1d..b9650c483 100644 --- a/src/backend/outputText.ml +++ b/src/backend/outputText.ml @@ -26,7 +26,7 @@ let append_glyph_synthesis otxt (FontFormat.PerMille(w)) (gid, markinfolst) = otxt | _ :: _ -> - let otxt = Alist.extend otxt (Kern(w)) in + let otxt = Alist.extend otxt (Kern(-w)) in let otxt = markinfolst |> List.fold_left (fun otxt (FontFormat.Mark(gidmark, FontFormat.PerMille(wmark), v)) -> let (FontFormat.PerMille(x), FontFormat.PerMille(y)) = v in @@ -34,7 +34,7 @@ let append_glyph_synthesis otxt (FontFormat.PerMille(w)) (gid, markinfolst) = Alist.extend otxt (Raise((x, y), wmark, data)) ) otxt in - let otxt = Alist.extend otxt (Kern(-w)) in + let otxt = Alist.extend otxt (Kern(w)) in otxt diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index 3e7a4360f..c83c21e3a 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -142,6 +142,7 @@ let unbreakable_space ctx : lb_box = let inner_string_pure (ctx : context_main) (script : script) (uchseglst : uchar_segment list) : lb_pure_box = let hsinfo = get_string_info ctx script in + Format.printf "ConvertText> no diacritical marks? -> %B\n" (List.for_all (fun (_, x) -> x = []) uchseglst); let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) @@ -170,6 +171,7 @@ let generate_separation_list (uchseglstlst : (uchar_segment list) list) : (uchar let make_string_atom (hsinfo : horz_string_info) (uchseglst : uchar_segment list) : lb_pure_box = + Format.printf "ConvertText> no diacritical marks? -> %B\n" (List.for_all (fun (_, x) -> x = []) uchseglst); let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index 69619eef5..3423782df 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -338,6 +338,7 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen bilst |> List.fold_left (fun (acc, segrcdopt) (uch, lbc) -> match lbc with | CM -> + Format.printf "LineBreakDataMap> U+%04X : CM\n" (Uchar.to_int uch); (* for debug *) begin match segrcdopt with | None -> @@ -353,8 +354,8 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen in (Alist.extend acc segrcd, None) - | Some(segrcd) -> - (acc, Some({ segrcd with marks = Alist.extend segrcd.marks uch; end_with_ZWJ = false; })) + | Some(segrcdprev) -> + (acc, Some({ segrcdprev with marks = Alist.extend segrcdprev.marks uch; end_with_ZWJ = false; })) end | ZWJ -> @@ -373,8 +374,8 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen in (Alist.extend acc segrcd, None) - | Some(segrcd) -> - (acc, Some({ segrcd with marks = Alist.extend segrcd.marks uch; end_with_ZWJ = true; })) + | Some(segrcdprev) -> + (acc, Some({ segrcdprev with marks = Alist.extend segrcdprev.marks uch; end_with_ZWJ = true; })) end | INBR | SP | ZW -> @@ -407,7 +408,7 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen begin match segrcdopt with | None -> - (Alist.extend acc segrcd, None) + (acc, Some(segrcd)) | Some(segrcdprev) -> (Alist.extend acc segrcdprev, Some(segrcd)) diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 2a734eabb..46dca7627 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -191,6 +191,7 @@ let get_metrics_of_word (hsinfo : horz_string_info) (uchseglst : uchar_segment l uchseglst |> List.map (fun (ubase, umarks) -> let gbase = get_glyph_id dcdr ubase in let gmarks = List.map (get_glyph_id dcdr) umarks in + if umarks = [] then () else Format.printf "FontInfo> head of marks = U+%04X\n" (Uchar.to_int (List.hd umarks)); (* for debug *) (gbase, gmarks) ) in From 793e1605571513abdc8053acf759095ebff8d6ae Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 13 Aug 2018 01:40:23 +0900 Subject: [PATCH 19/78] disable debug printing --- src/backend/fontFormat.ml | 2 -- src/chardecoder/convertText.ml | 2 -- src/chardecoder/lineBreakDataMap.ml | 1 - src/frontend/fontInfo.ml | 1 - 4 files changed, 6 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 06d0d687c..d842ec4ad 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -539,12 +539,10 @@ module LigatureTable begin match mktbl |> MarkTable.find_opt (gobase, gomark) with | None -> - Format.printf "FontFormat> CANNOT attach a diacritical mark\n"; (* for debug *) (* if the diacritical mark cannot attach to the base *) Match(gobase, [], segorgtail) | Some(vB, vM) -> - Format.printf "FontFormat> CAN attach a diacritical mark\n"; (* for debug *) Match(gobase, [(gomark, vB -@ vM)], segorgtail) end diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index c83c21e3a..3e7a4360f 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -142,7 +142,6 @@ let unbreakable_space ctx : lb_box = let inner_string_pure (ctx : context_main) (script : script) (uchseglst : uchar_segment list) : lb_pure_box = let hsinfo = get_string_info ctx script in - Format.printf "ConvertText> no diacritical marks? -> %B\n" (List.for_all (fun (_, x) -> x = []) uchseglst); let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) @@ -171,7 +170,6 @@ let generate_separation_list (uchseglstlst : (uchar_segment list) list) : (uchar let make_string_atom (hsinfo : horz_string_info) (uchseglst : uchar_segment list) : lb_pure_box = - Format.printf "ConvertText> no diacritical marks? -> %B\n" (List.for_all (fun (_, x) -> x = []) uchseglst); let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index 3423782df..9fa1b03dd 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -338,7 +338,6 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen bilst |> List.fold_left (fun (acc, segrcdopt) (uch, lbc) -> match lbc with | CM -> - Format.printf "LineBreakDataMap> U+%04X : CM\n" (Uchar.to_int uch); (* for debug *) begin match segrcdopt with | None -> diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 46dca7627..2a734eabb 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -191,7 +191,6 @@ let get_metrics_of_word (hsinfo : horz_string_info) (uchseglst : uchar_segment l uchseglst |> List.map (fun (ubase, umarks) -> let gbase = get_glyph_id dcdr ubase in let gmarks = List.map (get_glyph_id dcdr) umarks in - if umarks = [] then () else Format.printf "FontInfo> head of marks = U+%04X\n" (Uchar.to_int (List.hd umarks)); (* for debug *) (gbase, gmarks) ) in From a1d0c0dd267997cd4db798b68cd475589300e0ae Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 13 Aug 2018 02:40:11 +0900 Subject: [PATCH 20/78] add 'standalone.satyh' --- lib-satysfi/dist/packages/standalone.satyh | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 lib-satysfi/dist/packages/standalone.satyh diff --git a/lib-satysfi/dist/packages/standalone.satyh b/lib-satysfi/dist/packages/standalone.satyh new file mode 100644 index 000000000..450a9ab84 --- /dev/null +++ b/lib-satysfi/dist/packages/standalone.satyh @@ -0,0 +1,22 @@ + +let-inline ctx \math m = + embed-math ctx m + +let standalone bt = + let ctx = + get-initial-context 440pt (command \math) + |> set-dominant-narrow-script Latin + in + let bb = read-block ctx bt in + page-break A4Paper + (fun _ -> (| + text-origin = (80pt, 100pt); + text-height = 630pt; + |)) + (fun _ -> (| + header-origin = (0pt, 0pt); + header-content = block-nil; + footer-origin = (0pt, 0pt); + footer-content = block-nil; + |)) + bb From 4dc6a8f0a0746b8d7948bca3f73c51e8ce72f6e1 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 13 Aug 2018 02:57:10 +0900 Subject: [PATCH 21/78] omit unnecessary comment-out code in 'convertText.ml' --- src/chardecoder/convertText.ml | 51 +--------------------------------- 1 file changed, 1 insertion(+), 50 deletions(-) diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index 3e7a4360f..4a135d5a4 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -12,35 +12,6 @@ type chunk_info = context_main * script * line_break_class let to_chunk_main_list ctx uchlst alw : break_opportunity * line_break_chunk_main list = let (alwfirst, trilst) = LineBreakDataMap.append_break_opportunity uchlst alw in let scrlst = ScriptDataMap.divide_by_script ctx trilst in -(* - (* begin: for debug *) - let () = - trilst |> List.iter (fun (uch, lbc, alw) -> - let sc = InternalText.to_utf8 (InternalText.of_uchar uch) in - let sl = (* match lbc with CharBasis.AL -> "@" | _ -> "^" *) "" in - match alw with - | CharBasis.AllowBreak -> PrintForDebug.lexhorz (sc ^ sl ^ "/") - | CharBasis.PreventBreak -> PrintForDebug.lexhorz (sc ^ sl ^ ".") - ); PrintForDebug.lexhorzE "" in - let () = - scrlst |> List.iter (function - | AlphabeticChunk(script, lbcfirst, lbclast, uchlst, alw) -> - let sa = match alw with AllowBreak -> "" | PreventBreak -> "*" in - PrintForDebug.lexhorz ("[Alph] " ^ (CharBasis.show_script script) ^ sa ^ " "); - let s = uchlst |> List.map (fun uch -> InternalText.to_utf8 (InternalText.of_uchar uch)) |> String.concat "" in - PrintForDebug.lexhorzE s - | Space -> - PrintForDebug.lexhorzE "[Space]" - | UnbreakableSpace -> - PrintForDebug.lexhorzE "[UnbreakableSpace]" - | IdeographicChunk(script, lbc, uch, alw) -> - let sa = match alw with AllowBreak -> "" | PreventBreak -> "*" in - PrintForDebug.lexhorz ("[Ideo] " ^ (CharBasis.show_script script) ^ sa ^ " "); - PrintForDebug.lexhorzE (InternalText.to_utf8 (InternalText.of_uchar uch)) - ) - in - (* end: for debug *) -*) (alwfirst, scrlst) @@ -145,12 +116,6 @@ let inner_string_pure (ctx : context_main) (script : script) (uchseglst : uchar_ let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchseglst in LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt)) -(* -let soft_hyphen ctx script () : lb_box = - let lphb_hyphen = inner_string_pure ctx script [Uchar.of_char '-'] in - let dscrid = DiscretionaryID.fresh () in - LBDiscretionary(ctx.hyphen_badness, dscrid, [], [lphb_hyphen], []) -*) let generate_separation_list (uchseglstlst : (uchar_segment list) list) : (uchar_segment list * uchar_segment list) list = let rec aux acc revprefix suffix = @@ -177,9 +142,6 @@ let make_string_atom (hsinfo : horz_string_info) (uchseglst : uchar_segment list (* -- 'inner_string': makes an alphabetic word or a CJK character -- *) let inner_string (ctx : context_main) (script : script) (uchseglst : uchar_segment list) : lb_box list = let hsinfo = get_string_info ctx script in -(* - let lbhyphenf = soft_hyphen ctx script in -*) match LoadHyph.lookup ctx.left_hyphen_min ctx.right_hyphen_min ctx.hyphen_dictionary uchseglst with | LoadHyph.Single(uchseglst) -> [LBPure(make_string_atom hsinfo uchseglst)] @@ -198,15 +160,7 @@ let inner_string (ctx : context_main) (script : script) (uchseglst : uchar_segme ) Alist.empty |> Alist.to_list in [LBDiscretionaryList(ctx.hyphen_badness, [lphb0], dscrlst)] -(* - uchlstlst |> list_fold_adjacent (fun lbacc uchlst _ optnext -> - let (otxt, wid, hgt, dpt) = FontInfo.get_metrics_of_word hsinfo uchlst in - let lbfrac = LBPure(LBAtom((natural wid, hgt, dpt), EvHorzString(hsinfo, hgt, dpt, otxt))) in - match optnext with - | None -> Alist.extend lbacc lbfrac - | Some(_) -> Alist.extend (Alist.extend lbacc lbfrac) (lbhyphenf ()) - ) Alist.empty |> Alist.to_list -*) + let discretionary_if_breakable alw badns lphb () = match alw with @@ -268,9 +222,6 @@ let space_between_chunks info1 alw info2 : lb_box list = | None -> [discretionary_if_breakable alw badns (adjacent_space ctx1 ctx2) ()] | Some(lphb) -> [discretionary_if_breakable alw badns lphb ()] -(* - LBPure(fixed_string ctx script [Uchar.of_int (Char.code 'A')]) -*) let space_between_chunks_pure info1 info2 : lb_pure_box list = let (ctx1, script1, lbc1) = info1 in From 1f556492d9164bc1c28332937b96160cc390e187 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 13 Aug 2018 12:54:10 +0900 Subject: [PATCH 22/78] use MarkToLig attachment tables for diacritical marks --- satysfi.opam | 2 +- src/backend/fontFormat.ml | 209 +++++++++++++++++++++++++++++++------- 2 files changed, 172 insertions(+), 39 deletions(-) diff --git a/satysfi.opam b/satysfi.opam index 799ab906d..fc59060d7 100644 --- a/satysfi.opam +++ b/satysfi.opam @@ -30,7 +30,7 @@ depends: [ "dune" {build} "menhir" "ocamlfind" {build} - "otfm" {= "0.3.1+satysfi"} + "otfm" {= "0.3.2+satysfi"} "ppx_deriving" "uutf" "yojson" diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index d842ec4ad..214e3d8e5 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -340,8 +340,10 @@ module MarkTable : sig type t val create : unit -> t - val add : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit - val find_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + val add_base : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit + val add_ligature : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.ligature_attach) list -> t -> unit + val find_single_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + val find_ligature_opt : int -> original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option end = struct @@ -351,32 +353,62 @@ module MarkTable base_map : (anchor_point array) GMap.t; } + type mark_to_ligature_entry = { + lig_class_count : int; + lig_mark_map : (mark_class * anchor_point) GMap.t; + lig_base_map : (((anchor_point option) array) array) GMap.t; + } + type t = { - mutable mark_to_base_table : mark_to_base_entry list; + mutable mark_to_base_table : mark_to_base_entry list; + mutable mark_to_ligature_table : mark_to_ligature_entry list; } let create () = - { mark_to_base_table = []; } + { mark_to_base_table = []; mark_to_ligature_table = []; } + + + let make_mark_map pmf markassoc = + markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> + map |> GMap.add gidmark (i, (pmf x, pmf y)) + ) GMap.empty + + let base_record pmf (x, y, _) = + (pmf x, pmf y) - let add units_per_em class_count markassoc baseassoc mktbl = + + let add_base units_per_em class_count markassoc baseassoc mktbl = let pmf = per_mille_raw units_per_em in - let mark_map = - markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> - map |> GMap.add gidmark (i, (pmf x, pmf y)) - ) GMap.empty - in + let mark_map = make_mark_map pmf markassoc in let base_map = baseassoc |> List.fold_left (fun map (gidbase, arr) -> - map |> GMap.add gidbase (arr |> Array.map (fun (x, y, _) -> (pmf x, pmf y))) + map |> GMap.add gidbase (arr |> Array.map (base_record pmf)) ) GMap.empty in let entry = { class_count; mark_map; base_map; } in mktbl.mark_to_base_table <- entry :: mktbl.mark_to_base_table - let find_opt (gidbase, gidmark) mktbl = + let add_ligature units_per_em lig_class_count markassoc (ligassoc : (Otfm.glyph_id * Otfm.ligature_attach) list) mktbl = + let pmf = per_mille_raw units_per_em in + let lig_mark_map = + markassoc |> List.fold_left (fun map (gidmark, (i, (x, y, _))) -> + map |> GMap.add gidmark (i, (pmf x, pmf y)) + ) GMap.empty + in + let lig_base_map = + ligassoc |> List.fold_left (fun map (gidlig, comprcdlst) -> + let lst = comprcdlst |> List.map (Array.map (option_map (base_record pmf))) in + map |> GMap.add gidlig (Array.of_list lst) + ) GMap.empty + in + let entry = { lig_class_count; lig_mark_map; lig_base_map; } in + mktbl.mark_to_ligature_table <- entry :: mktbl.mark_to_ligature_table + + + let find_single_opt (gidbase, gidmark) mktbl = let rec aux lst = match lst with | [] -> @@ -388,11 +420,34 @@ module MarkTable begin match (baseopt, markopt) with | (None, _) | (_, None) -> aux tail - | (Some(arr), Some(i, ptmark)) -> Some((arr.(i), ptmark)) + | (Some(arr), Some(c, ptmark)) -> Some((arr.(c), ptmark)) end in aux mktbl.mark_to_base_table + + let find_ligature_opt i (gidlig, gidmark) mktbl = + let rec aux lst = + match lst with + | [] -> + None + + | entry :: tail -> + let opt = + let open OptionMonad in + entry.lig_mark_map |> GMap.find_opt gidmark >>= fun (c, ptmark) -> + entry.lig_base_map |> GMap.find_opt gidlig >>= fun ligatt -> + ligatt.(i).(c) >>= fun ptlig -> + return (ptlig, ptmark) + in + begin + match opt with + | None -> aux tail + | Some(_) -> opt + end + in + aux mktbl.mark_to_ligature_table + end @@ -415,10 +470,15 @@ let get_mark_table srcpath units_per_em d = Otfm.gpos_langsys script >>= fun (langsys, _) -> (* temporary; should depend on the current language system *) Otfm.gpos_feature langsys >>= fun (_, featurelst) -> - pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature -> - () |> Otfm.gpos feature ~markbase1:(fun clscnt () markassoc baseassoc -> - MarkTable.add units_per_em clscnt markassoc baseassoc mktbl - ) >>= fun () -> + pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature_mark -> + () |> Otfm.gpos feature_mark + ~markbase1:(fun clscnt () markassoc baseassoc -> + MarkTable.add_base units_per_em clscnt markassoc baseassoc mktbl + ) + ~marklig1:(fun clscnt () markassoc ligassoc -> + MarkTable.add_ligature units_per_em clscnt markassoc ligassoc mktbl + ) + >>= fun () -> Ok() in match res with @@ -501,27 +561,100 @@ module LigatureTable GHt.fold (fun gidorg gidorglst acc -> f gidorg gidorglst acc) htrev init - let rec prefix (lst1 : original_glyph_id list) (seglst2 : original_glyph_segment list) = - match (lst1, seglst2) with - | ([], _) -> Some(seglst2) - | (head1 :: tail1, (head2, []) :: tail2) when head1 = head2 -> prefix tail1 tail2 - (* temporary; should refer to MarkToLig attachment table *) - | _ -> None - - - let rec lookup liginfolst (segorglst : original_glyph_segment list) = - match liginfolst with + let attach_marks mktbl markbasef (* markmarkf *) gobase gomarks = + match gomarks with | [] -> - None + Some([]) - | single :: liginfotail -> - let gidorgtail = single.tail in - let gidorglig = single.ligature in + | gomark :: _ -> begin - match prefix gidorgtail segorglst with - | None -> lookup liginfotail segorglst - | Some(orgsegrest) -> Some((gidorglig), orgsegrest) + match markbasef (gobase, gomark) mktbl with + | None -> None + | Some((vL, vM)) -> Some([(gomark, vL -@ vM)]) end + (* temporary; should refer to MarkToMark *) + + + (* -- + 'make_ligature_mark_info mktbl golig markpairs' returns: + + - 'Some(markinfolst)' if all diacritical marks of 'markpairs' + are attachable to the ligature 'golig'. + + - 'None' otherwise. + + -- *) + let make_ligature_mark_info mktbl golig markpairs = + let rec aux acc = function + | [] -> + Some(Alist.to_list acc) + + | (i, gomarks) :: tail -> + let markbasef = MarkTable.find_ligature_opt i in + begin + match attach_marks mktbl markbasef golig gomarks with + | None -> None + | Some(markinfolst) -> aux (Alist.append acc markinfolst) tail + end + in + aux Alist.empty markpairs + + + (* -- + 'prefix mktbl golig lst1 seglst2' returns: + + - 'Some(seglst, markinfolst)' + if 'lst1' is a prefix of 'seglst2' and + forming ligature does not prevent attachment of diacritical marks, + where 'seglst' is the rest of 'seglst2' + and 'markinfolst' is the position information of diacritical marks. + + - 'None' otherwise. + + -- *) + let prefix (mktbl : MarkTable.t) (golig : original_glyph_id) (lst1 : original_glyph_id list) (seglst2 : original_glyph_segment list) : (original_glyph_segment list * (original_glyph_id * anchor_point) list) option = + let rec aux i acc lst1 seglst2 = + match (lst1, seglst2) with + | ([], _) -> + let markpairs = Alist.to_list acc in + begin + match make_ligature_mark_info mktbl golig markpairs with + | None -> None + | Some(markinfolst) -> Some(seglst2, markinfolst) + end + + | (head1 :: tail1, (head2, gomarks) :: tail2) -> + if head1 = head2 then + let acc = Alist.extend acc (i, gomarks) in + aux (i + 1) acc tail1 tail2 + else + None + + | _ -> + None + in + aux 0 Alist.empty lst1 seglst2 + + + let lookup (mktbl : MarkTable.t) (liginfolst : single list) (segorglst : original_glyph_segment list) = + let rec aux liginfolst = + match liginfolst with + | [] -> + None + + | single :: liginfotail -> + let gotail = single.tail in + let golig = single.ligature in + begin + match prefix mktbl golig gotail segorglst with + | None -> + aux liginfotail + + | Some(orgsegrest, markinfolst) -> + Some(golig, markinfolst, orgsegrest) + end + in + aux liginfolst let match_prefix (segorglst : original_glyph_segment list) (mktbl : MarkTable.t) (ligtbl : t) = @@ -537,7 +670,7 @@ module LigatureTable (* temporary; should refer to MarkToMark table in order to handle diacritical marks after the first one *) begin - match mktbl |> MarkTable.find_opt (gobase, gomark) with + match mktbl |> MarkTable.find_single_opt (gobase, gomark) with | None -> (* if the diacritical mark cannot attach to the base *) Match(gobase, [], segorgtail) @@ -554,9 +687,9 @@ module LigatureTable | Some(liginfolst) -> begin - match lookup liginfolst segorgtail with - | None -> Match(gobase, [], segorgtail) - | Some((golig, segorgrest)) -> Match(golig, [], segorgrest) (* temporary *) + match lookup mktbl liginfolst segorgtail with + | None -> Match(gobase, [], segorgtail) + | Some((golig, markinfolst, segorgrest)) -> Match(golig, markinfolst, segorgrest) (* temporary *) end end end From f1437fbaa7a76e1b26edee2f44eb3cdb23ec7e4a Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 14 Aug 2018 01:57:20 +0900 Subject: [PATCH 23/78] SUPPORT COMBINING MORE THAN ONE DIACRITICAL MARK --- src/backend/fontFormat.ml | 157 +++++++++++++++++++++++++++++--------- 1 file changed, 119 insertions(+), 38 deletions(-) diff --git a/src/backend/fontFormat.ml b/src/backend/fontFormat.ml index 214e3d8e5..25e9b8066 100644 --- a/src/backend/fontFormat.ml +++ b/src/backend/fontFormat.ml @@ -335,15 +335,19 @@ type mark_class = int type anchor_point = per_mille * per_mille +type mark_assoc = (Otfm.glyph_id * Otfm.mark_record) list + module MarkTable : sig type t val create : unit -> t - val add_base : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit - val add_ligature : int -> int -> (Otfm.glyph_id * Otfm.mark_record) list -> (Otfm.glyph_id * Otfm.ligature_attach) list -> t -> unit - val find_single_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + val add_base : int -> int -> mark_assoc -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit + val add_ligature : int -> int -> mark_assoc -> (Otfm.glyph_id * Otfm.ligature_attach) list -> t -> unit + val add_mark_to_mark : int -> int -> mark_assoc -> (Otfm.glyph_id * Otfm.base_record) list -> t -> unit + val find_base_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option val find_ligature_opt : int -> original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option + val find_mark_to_mark_opt : original_glyph_id * original_glyph_id -> t -> (anchor_point * anchor_point) option end = struct @@ -408,7 +412,10 @@ module MarkTable mktbl.mark_to_ligature_table <- entry :: mktbl.mark_to_ligature_table - let find_single_opt (gidbase, gidmark) mktbl = + let add_mark_to_mark = add_base + + + let find_base_opt (gidbase, gidmark) mktbl = let rec aux lst = match lst with | [] -> @@ -448,6 +455,9 @@ module MarkTable in aux mktbl.mark_to_ligature_table + + let find_mark_to_mark_opt = find_base_opt + end @@ -463,33 +473,56 @@ let result_bind x f = let get_mark_table srcpath units_per_em d = let mktbl = MarkTable.create () in let res = - let (>>=) = result_bind in + let open ResultMonad in Otfm.gpos_script d >>= fun scriptlst -> - pickup scriptlst (fun gs -> Otfm.gpos_script_tag gs = "latn") `Missing_script >>= fun script -> + match scriptlst |> List.find_opt (fun gs -> Otfm.gpos_script_tag gs = "latn") with (* temporary; should depend on the script *) - Otfm.gpos_langsys script >>= fun (langsys, _) -> - (* temporary; should depend on the current language system *) - Otfm.gpos_feature langsys >>= fun (_, featurelst) -> - pickup featurelst (fun gf -> Otfm.gpos_feature_tag gf = "mark") `Missing_feature >>= fun feature_mark -> - () |> Otfm.gpos feature_mark - ~markbase1:(fun clscnt () markassoc baseassoc -> - MarkTable.add_base units_per_em clscnt markassoc baseassoc mktbl - ) - ~marklig1:(fun clscnt () markassoc ligassoc -> - MarkTable.add_ligature units_per_em clscnt markassoc ligassoc mktbl - ) - >>= fun () -> - Ok() + | None -> + return () + + | Some(script) -> + Otfm.gpos_langsys script >>= fun (langsys, _) -> + (* temporary; should depend on the current language system *) + Otfm.gpos_feature langsys >>= fun (_, featurelst) -> + begin + match featurelst |> List.find_opt (fun gf -> Otfm.gpos_feature_tag gf = "mark") with + | None -> + return () + + | Some(feature_mark) -> + () |> Otfm.gpos feature_mark + ~markbase1:(fun clscnt () markassoc baseassoc -> + MarkTable.add_base units_per_em clscnt markassoc baseassoc mktbl + ) + ~marklig1:(fun clscnt () markassoc ligassoc -> + MarkTable.add_ligature units_per_em clscnt markassoc ligassoc mktbl + ) + end >>= fun () -> + begin + match featurelst |> List.find_opt (fun gf -> Otfm.gpos_feature_tag gf = "mkmk") with + | None -> + return () + + | Some(feature_mkmk) -> + () |> Otfm.gpos feature_mkmk + ~markmark1:(fun clscnt () mark1assoc mark2assoc -> + MarkTable.add_mark_to_mark units_per_em clscnt mark1assoc mark2assoc mktbl + ) + end in match res with - | Error(#Otfm.error as oerr) -> raise_err srcpath oerr "get_mark_table" - | _ -> mktbl + | Error(oerr) -> raise_err srcpath oerr "get_mark_table" + | _ -> mktbl let ( -@ ) (PerMille(x1), PerMille(y1)) (PerMille(x2), PerMille(y2)) = (PerMille(x1 - x2), PerMille(y1 - y2)) +let ( +@ ) (PerMille(x1), PerMille(y1)) (PerMille(x2), PerMille(y2)) = + (PerMille(x1 + x2), PerMille(y1 + y2)) + + type per_mille_vector = per_mille * per_mille type mark_info = @@ -561,18 +594,66 @@ module LigatureTable GHt.fold (fun gidorg gidorglst acc -> f gidorg gidorglst acc) htrev init - let attach_marks mktbl markbasef (* markmarkf *) gobase gomarks = - match gomarks with - | [] -> - Some([]) + (* -- + 'backtrack_mark_to_mark mktbl markbasef gobase markpairacc gomark' returns: - | gomark :: _ -> - begin - match markbasef (gobase, gomark) mktbl with - | None -> None - | Some((vL, vM)) -> Some([(gomark, vL -@ vM)]) - end - (* temporary; should refer to MarkToMark *) + - 'Some(p)' if 'gomark' can be attached at the position 'p' + to 'gobase', to which every mark in 'markpairacc' is already attached. + + - 'None' otherwise. + + -- *) + let backtrack_mark_to_mark mktbl markbasef gobase markpairacc gomark = + let rec aux markpairacc = + match Alist.chop_last markpairacc with + | None -> + begin + match markbasef (gobase, gomark) mktbl with + | None -> None + | Some((vB, vM)) -> Some(vB -@ vM) + end + + | Some((rest, (gomarklast, pM2))) -> + begin + match MarkTable.find_mark_to_mark_opt (gomarklast, gomark) mktbl with + | None -> aux rest + | Some((vM2, vM1)) -> Some(vM2 -@ vM1 +@ pM2) + end + in + aux markpairacc + + + (* -- + 'attach_marks mktbl markbasef gobase gomarks' returns: + + - 'Some([(gm1, p1), ..., (gmN, pN)])' if every 'gmI' in 'gomarks' + can be attached to 'gobase' at the position 'p'. + + - 'None' otherwise. + + -- *) + let attach_marks is_ligature mktbl markbasef gobase gomarks = + let rec aux markpairacc gomarks = + match gomarks with + | [] -> + Some(Alist.to_list markpairacc) + + | gomark :: gomarktail -> + begin + match backtrack_mark_to_mark mktbl markbasef gobase markpairacc gomark with + | None -> + begin + if is_ligature then () else + Format.printf "FontFormat> combining diacritical mark of GID %d cannot be attached to GID %d\n" gomark gobase + (* temporary; should warn in a more sophisticated manner *) + end; + None + + | Some(p) -> + aux (Alist.extend markpairacc (gomark, p)) gomarktail + end + in + aux Alist.empty gomarks (* -- @@ -592,7 +673,7 @@ module LigatureTable | (i, gomarks) :: tail -> let markbasef = MarkTable.find_ligature_opt i in begin - match attach_marks mktbl markbasef golig gomarks with + match attach_marks true mktbl markbasef golig gomarks with | None -> None | Some(markinfolst) -> aux (Alist.append acc markinfolst) tail end @@ -666,17 +747,17 @@ module LigatureTable | (gobase, gomarks) :: segorgtail -> begin match gomarks with - | gomark :: _ -> + | _ :: _ -> (* temporary; should refer to MarkToMark table in order to handle diacritical marks after the first one *) begin - match mktbl |> MarkTable.find_single_opt (gobase, gomark) with + match attach_marks false mktbl MarkTable.find_base_opt gobase gomarks with | None -> - (* if the diacritical mark cannot attach to the base *) + (* if the diacritical marks cannot attach to the base *) Match(gobase, [], segorgtail) - | Some(vB, vM) -> - Match(gobase, [(gomark, vB -@ vM)], segorgtail) + | Some(markpairs) -> + Match(gobase, markpairs, segorgtail) end | [] -> From 80ce95f2074a20bc2e103445c41115b89ef9987e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 14 Aug 2018 22:56:14 +0900 Subject: [PATCH 24/78] refactor 'pageBreak.ml' --- src/backend/pageBreak.ml | 37 +++---------------------------------- 1 file changed, 3 insertions(+), 34 deletions(-) diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index 48d654549..4a2761613 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -3,26 +3,6 @@ open LengthInterface open HorzBox -(* for test *) -let print_evaled_vert_box evvb = - () -(* - match evvb with - | EvVertLine(_, _, evhblst) -> - begin - Format.printf "@[(vert@ " ; - evhblst |> List.iter (function - | EvHorzFixedBoxAtom(wid, FixedString(_, str)) -> Format.printf "@[(fixed@ \"%s\"@ :@ %s)@]@ " str (Length.show wid) - | EvHorzFixedBoxAtom(wid, FixedEmpty(_)) -> Format.printf "@[(fixed-empty@ %s)@]@ " (Length.show wid) - | EvHorzOuterBoxAtom(wid, _) -> Format.printf "@[(outer@ :@ %s)@]@ " (Length.show wid) - ) ; - Format.printf ")@]@ " ; - end - | EvVertFixedEmpty(vskip) -> - begin - Format.printf "@[(vskip@ %s)@]@ " (Length.show vskip) ; - end -*) type frame_breaking = | Beginning @@ -36,7 +16,7 @@ type pb_vert_box = | PBClearPage -let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * pb_vert_box list option = +let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * (pb_vert_box list) option = let calculate_badness_of_page_break hgttotal = let hgtdiff = area_height -% hgttotal in @@ -52,7 +32,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst let rec aux (bprev : bool) (vpbprev : pure_badness) (evvbacc : evaled_vert_box Alist.t) (evvbaccdiscardable : evaled_vert_box Alist.t) (hgttotal : length) (pbvblst : pb_vert_box list) : evaled_vert_box Alist.t * (pb_vert_box list) option * length * pure_badness = match pbvblst with - | PBVertLine(hgt, dpt, imhblst) :: imvbtail -> + | PBVertLine(hgt, dpt, imhblst) :: pbvbtail -> let hgttotalnew = hgttotal +% hgt +% (Length.negate dpt) in let vpb = calculate_badness_of_page_break hgttotalnew in if bprev && (vpb >= vpbprev) && (hgttotal <% hgttotalnew) then @@ -64,7 +44,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst else let evhblst = PageInfo.embed_page_info pbinfo imhblst in let evvbaccnew = Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertLine(hgt, dpt, evhblst)) in - aux true vpb evvbaccnew Alist.empty hgttotalnew imvbtail + aux true vpb evvbaccnew Alist.empty hgttotalnew pbvbtail | PBVertFixedBreakable(vskip) :: pbvbtail -> let hgttotalnew = hgttotal +% vskip in @@ -118,9 +98,6 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst end | [] -> -(* - let () = PrintForDebug.pagebreakE ("CE " ^ (Length.show hgttotal) ^ " ===> None\n") in (* for debug *) -*) (evvbacc, None, hgttotal, vpbprev) in let vpbinit = 100000 in @@ -208,10 +185,6 @@ let solidify (vblst : vert_box list) : intermediate_vert_box list = let main (file_name_out : string) (pagesize : page_size) (pagecontf : page_content_scheme_func) (pagepartsf : page_parts_scheme_func) (vblst : vert_box list) : HandlePdf.t = -(* - let () = PrintForDebug.pagebreakE ("PageBreak.main: accept data of length " ^ (string_of_int (List.length vblst))) in (* for debug *) - let () = List.iter (Format.fprintf PrintForDebug.pagebreakF "%a,@ " pp_vert_box) vblst in (* for debug *) -*) let pdfinit = HandlePdf.create_empty_pdf file_name_out in let rec aux pageno (pdfacc : HandlePdf.t) pbvblst = @@ -221,10 +194,6 @@ let main (file_name_out : string) (pagesize : page_size) (pagecontf : page_conte let page = HandlePdf.page_of_evaled_vert_box_list pagesize pbinfo pagecontsch evvblstpage in let pdfaccnew = pdfacc |> HandlePdf.write_page page pagepartsf in -(* - let () = PrintForDebug.pagebreakE ("PageBreak.main: write contents of length " ^ (string_of_int (List.length evvblstpage))) in (* for debug *) - let () = List.iter (Format.fprintf PrintForDebug.pagebreakF "%a,@ " pp_evaled_vert_box) evvblstpage in (* for debug *) -*) match restopt with | None -> pdfaccnew | Some(imvblstrest) -> aux (pageno + 1) pdfaccnew imvblstrest From 0faf0b2f434afb3cad0368c0232ec7a3b6c4814f Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 14 Aug 2018 23:51:20 +0900 Subject: [PATCH 25/78] refactor 'chop_single_page' in 'pageBreak.ml' --- src/backend/pageBreak.ml | 119 +++++++++++++++++++++++++++++++++------ 1 file changed, 101 insertions(+), 18 deletions(-) diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index 4a2761613..cc25962f5 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -15,6 +15,21 @@ type pb_vert_box = | PBVertFrame of frame_breaking * paddings * decoration * decoration * decoration * decoration * length * pb_vert_box list | PBClearPage +type pb_accumulator = { + breakable : bool; + badness : pure_badness; + solid : evaled_vert_box Alist.t; + discardable : evaled_vert_box Alist.t; + total_height : length; +} + +type pb_answer = { + body : evaled_vert_box list; + rest : (pb_vert_box list) option; + last_height : length; + last_badness : pure_badness; +} + let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * (pb_vert_box list) option = @@ -30,7 +45,12 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | _ -> pbvblst in - let rec aux (bprev : bool) (vpbprev : pure_badness) (evvbacc : evaled_vert_box Alist.t) (evvbaccdiscardable : evaled_vert_box Alist.t) (hgttotal : length) (pbvblst : pb_vert_box list) : evaled_vert_box Alist.t * (pb_vert_box list) option * length * pure_badness = + let rec aux (prev : pb_accumulator) (pbvblst : pb_vert_box list) : pb_answer = + let bprev = prev.breakable in + let vpbprev = prev.badness in + let evvbacc = prev.solid in + let evvbaccdiscardable = prev.discardable in + let hgttotal = prev.total_height in match pbvblst with | PBVertLine(hgt, dpt, imhblst) :: pbvbtail -> let hgttotalnew = hgttotal +% hgt +% (Length.negate dpt) in @@ -40,37 +60,76 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst if getting worse, outputs the accumulated non-discardable lines 'evvbacc' as a page. note that the line checked last will be left in the processing list. -- *) - (evvbacc, Some(pbvblst), hgttotalnew, vpb) + { + body = Alist.to_list evvbacc; + rest = Some(pbvblst); + last_height = hgttotalnew; + last_badness = vpb; + } else let evhblst = PageInfo.embed_page_info pbinfo imhblst in let evvbaccnew = Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertLine(hgt, dpt, evhblst)) in - aux true vpb evvbaccnew Alist.empty hgttotalnew pbvbtail + aux { + breakable = true; + badness = vpb; + solid = evvbaccnew; + discardable = Alist.empty; + total_height = hgttotalnew; + } pbvbtail | PBVertFixedBreakable(vskip) :: pbvbtail -> let hgttotalnew = hgttotal +% vskip in let vpb = calculate_badness_of_page_break hgttotalnew in if (vpb >= vpbprev) && (hgttotal <% hgttotalnew) then - (evvbacc, Some(omit_clear_page_element pbvbtail), hgttotalnew, vpb) + { + body = Alist.to_list evvbacc; + rest = Some(omit_clear_page_element pbvbtail); + last_height = hgttotalnew; + last_badness = vpb; + } else let evvbaccdiscardablenew = Alist.extend evvbaccdiscardable (EvVertFixedEmpty(vskip)) in - aux true vpb evvbacc evvbaccdiscardablenew hgttotalnew pbvbtail + aux { + breakable = true; + badness = vpb; + solid = evvbacc; + discardable = evvbaccdiscardablenew; + total_height = hgttotalnew; + } pbvbtail | PBVertFixedUnbreakable(vskip) :: pbvbtail -> let hgttotalnew = hgttotal +% vskip in let evvbaccnew = Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertFixedEmpty(vskip)) in - aux false vpbprev evvbaccnew Alist.empty hgttotalnew pbvbtail + aux { + breakable = false; + badness = vpbprev; + solid = evvbaccnew; + discardable = Alist.empty; + total_height = hgttotalnew; + } pbvbtail | PBClearPage :: pbvbtail -> - (evvbacc, Some(pbvbtail), hgttotal, 0) + { + body = Alist.to_list evvbacc; + rest = Some(pbvbtail); + last_height = hgttotal; + last_badness = 0; + } | PBVertFrame(midway, pads, decoS, decoH, decoM, decoT, wid, pbvblstsub) :: pbvbtail -> let hgttotalbefore = hgttotal +% pads.paddingT in - let (evvbaccsub, restsubopt, hgttotalsub, vpbsub) = - aux false vpbprev Alist.empty Alist.empty hgttotalbefore pbvblstsub + let ans = + aux { + breakable = false; + badness = vpbprev; + solid = Alist.empty; + discardable = Alist.empty; + total_height = hgttotalbefore; + } pbvblstsub in - let hgttotalafter = hgttotalsub +% pads.paddingB in + let hgttotalafter = ans.last_height +% pads.paddingB in begin - match restsubopt with + match ans.rest with | None -> let evvbaccnew = let decosub = @@ -79,9 +138,15 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | Beginning -> decoS in Alist.extend (Alist.cat evvbacc evvbaccdiscardable) - (EvVertFrame(pads, pbinfo, decosub, wid, Alist.to_list evvbaccsub)) + (EvVertFrame(pads, pbinfo, decosub, wid, ans.body)) in - aux true vpbsub evvbaccnew Alist.empty hgttotalafter pbvbtail + aux { + breakable = true; + badness = ans.last_badness; + solid = evvbaccnew; + discardable = Alist.empty; + total_height = hgttotalafter; + } pbvbtail | Some(pbvbrestsub) -> let evvbaccret = @@ -91,18 +156,36 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | Beginning -> decoH in Alist.extend (Alist.cat evvbacc evvbaccdiscardable) - (EvVertFrame(pads, pbinfo, decosub, wid, Alist.to_list evvbaccsub)) + (EvVertFrame(pads, pbinfo, decosub, wid, ans.body)) in let pbvbrest = Some(PBVertFrame(Midway, pads, decoS, decoH, decoM, decoT, wid, pbvbrestsub) :: pbvbtail) in - (evvbaccret, pbvbrest, hgttotalafter, vpbsub) + { + body = Alist.to_list evvbaccret; + rest = pbvbrest; + last_height = hgttotalafter; + last_badness = ans.last_badness; + } end | [] -> - (evvbacc, None, hgttotal, vpbprev) + { + body = Alist.to_list evvbacc; + rest = None; + last_height = hgttotal; + last_badness = vpbprev; + } in let vpbinit = 100000 in - let (evvbacc, restopt, _, _) = aux false vpbinit Alist.empty Alist.empty Length.zero pbvblst in - (Alist.to_list evvbacc, restopt) + let ans = + aux { + breakable = false; + badness = vpbinit; + solid = Alist.empty; + discardable = Alist.empty; + total_height = Length.zero; + } pbvblst + in + (ans.body, ans.rest) (* -- From dcb78a4493bb05594662b530e890cbc00fb1577b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 00:16:13 +0900 Subject: [PATCH 26/78] add footnote entry to 'chop_single_page' --- src/backend/pageBreak.ml | 47 ++++++++++++++++++++++++++-------------- 1 file changed, 31 insertions(+), 16 deletions(-) diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index cc25962f5..26eaf1169 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -16,22 +16,24 @@ type pb_vert_box = | PBClearPage type pb_accumulator = { - breakable : bool; - badness : pure_badness; - solid : evaled_vert_box Alist.t; - discardable : evaled_vert_box Alist.t; - total_height : length; + breakable : bool; + badness : pure_badness; + solid_body : evaled_vert_box Alist.t; + solid_footnote : evaled_vert_box Alist.t; + discardable : evaled_vert_box Alist.t; + total_height : length; } type pb_answer = { body : evaled_vert_box list; + footnote : evaled_vert_box Alist.t; rest : (pb_vert_box list) option; last_height : length; last_badness : pure_badness; } -let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * (pb_vert_box list) option = +let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * evaled_vert_box list * (pb_vert_box list) option = let calculate_badness_of_page_break hgttotal = let hgtdiff = area_height -% hgttotal in @@ -48,7 +50,8 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst let rec aux (prev : pb_accumulator) (pbvblst : pb_vert_box list) : pb_answer = let bprev = prev.breakable in let vpbprev = prev.badness in - let evvbacc = prev.solid in + let evvbacc = prev.solid_body in + let footnote = prev.solid_footnote in let evvbaccdiscardable = prev.discardable in let hgttotal = prev.total_height in match pbvblst with @@ -62,6 +65,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst -- *) { body = Alist.to_list evvbacc; + footnote = footnote; rest = Some(pbvblst); last_height = hgttotalnew; last_badness = vpb; @@ -72,7 +76,8 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst aux { breakable = true; badness = vpb; - solid = evvbaccnew; + solid_body = evvbaccnew; + solid_footnote = footnote; discardable = Alist.empty; total_height = hgttotalnew; } pbvbtail @@ -83,6 +88,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst if (vpb >= vpbprev) && (hgttotal <% hgttotalnew) then { body = Alist.to_list evvbacc; + footnote = footnote; rest = Some(omit_clear_page_element pbvbtail); last_height = hgttotalnew; last_badness = vpb; @@ -92,7 +98,8 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst aux { breakable = true; badness = vpb; - solid = evvbacc; + solid_body = evvbacc; + solid_footnote = footnote; discardable = evvbaccdiscardablenew; total_height = hgttotalnew; } pbvbtail @@ -102,8 +109,9 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst let evvbaccnew = Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertFixedEmpty(vskip)) in aux { breakable = false; - badness = vpbprev; - solid = evvbaccnew; + badness = vpbprev; (* doubtful *) + solid_body = evvbaccnew; + solid_footnote = footnote; discardable = Alist.empty; total_height = hgttotalnew; } pbvbtail @@ -111,6 +119,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | PBClearPage :: pbvbtail -> { body = Alist.to_list evvbacc; + footnote = footnote; rest = Some(pbvbtail); last_height = hgttotal; last_badness = 0; @@ -122,10 +131,12 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst aux { breakable = false; badness = vpbprev; - solid = Alist.empty; + solid_body = Alist.empty; + solid_footnote = footnote; discardable = Alist.empty; total_height = hgttotalbefore; } pbvblstsub + (* -- propagates total height and footnotes, but does NOT propagate body -- *) in let hgttotalafter = ans.last_height +% pads.paddingB in begin @@ -143,7 +154,8 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst aux { breakable = true; badness = ans.last_badness; - solid = evvbaccnew; + solid_body = evvbaccnew; + solid_footnote = ans.footnote; discardable = Alist.empty; total_height = hgttotalafter; } pbvbtail @@ -161,6 +173,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst let pbvbrest = Some(PBVertFrame(Midway, pads, decoS, decoH, decoM, decoT, wid, pbvbrestsub) :: pbvbtail) in { body = Alist.to_list evvbaccret; + footnote = footnote; rest = pbvbrest; last_height = hgttotalafter; last_badness = ans.last_badness; @@ -170,6 +183,7 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | [] -> { body = Alist.to_list evvbacc; + footnote = footnote; rest = None; last_height = hgttotal; last_badness = vpbprev; @@ -180,12 +194,13 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst aux { breakable = false; badness = vpbinit; - solid = Alist.empty; + solid_body = Alist.empty; + solid_footnote = Alist.empty; discardable = Alist.empty; total_height = Length.zero; } pbvblst in - (ans.body, ans.rest) + (ans.body, Alist.to_list ans.footnote, ans.rest) (* -- @@ -273,7 +288,7 @@ let main (file_name_out : string) (pagesize : page_size) (pagecontf : page_conte let rec aux pageno (pdfacc : HandlePdf.t) pbvblst = let pbinfo = { current_page_number = pageno; } in let pagecontsch = pagecontf pbinfo in (* -- invokes the page scheme function -- *) - let (evvblstpage, restopt) = chop_single_page pbinfo pagecontsch.page_content_height pbvblst in + let (evvblstpage, footnote, restopt) = chop_single_page pbinfo pagecontsch.page_content_height pbvblst in let page = HandlePdf.page_of_evaled_vert_box_list pagesize pbinfo pagecontsch evvblstpage in let pdfaccnew = pdfacc |> HandlePdf.write_page page pagepartsf in From f3a5d6d7f867be2057e16c14d43b3c3167113950 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 02:26:31 +0900 Subject: [PATCH 27/78] add 'ImHorzFootnote' to 'intermediate_horz_box' --- src/backend/handlePdf.ml | 6 +- src/backend/horzBox.ml | 1 + src/backend/lineBreak.ml | 1 + src/backend/pageBreak.ml | 19 +++++- src/backend/pageInfo.ml | 129 ++++++++++++++++++++++++++++++--------- 5 files changed, 121 insertions(+), 35 deletions(-) diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index d4943f1a2..21c696589 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -220,7 +220,7 @@ and ops_of_evaled_vert_box_list pbinfo (xinit, yinit) opaccinit evvblst = and pdfops_of_intermediate_horz_box_list (pbinfo : page_break_info) ((xpos, yposbaseline) : point) (imhblst : intermediate_horz_box list) : Pdfops.t list = - let evhblst = PageInfo.embed_page_info pbinfo imhblst in + let (evhblst, _) = PageInfo.embed_page_info pbinfo imhblst in let (_, opacc) = evhblst |> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) (xpos, Alist.empty) in @@ -272,11 +272,11 @@ let write_page (Page(paper, pagecontsch, opaccpage, pbinfo) : page) (pagepartsf let paper_height = get_paper_height paper in let pagepartssch = pagepartsf pbinfo in (* -- invokes the page-parts function -- *) - let evvblst_header = pagepartssch.header_content |> PageInfo.embed_page_info_vert pbinfo in + let (evvblst_header, _) = pagepartssch.header_content |> PageInfo.embed_page_info_vert pbinfo in let pt_header = invert_coordinate paper_height pagepartssch.header_origin in let (_, opacc_header) = ops_of_evaled_vert_box_list pbinfo pt_header opaccpage evvblst_header in - let evvblst_footer = pagepartssch.footer_content |> PageInfo.embed_page_info_vert pbinfo in + let (evvblst_footer, _) = pagepartssch.footer_content |> PageInfo.embed_page_info_vert pbinfo in let pt_footer = invert_coordinate paper_height pagepartssch.footer_origin in let (_, opacc_footer) = ops_of_evaled_vert_box_list pbinfo pt_footer opacc_header evvblst_footer in diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index 6113975c6..0f0805f03 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -263,6 +263,7 @@ and intermediate_horz_box = | ImHorzEmbeddedVert of length * length * length * intermediate_vert_box list | ImHorzInlineGraphics of length * length * length * (point -> (intermediate_horz_box list) GraphicD.t) | ImHorzHookPageBreak of (page_break_info -> point -> unit) + | ImHorzFootnote of intermediate_vert_box list and evaled_horz_box = length * evaled_horz_box_main diff --git a/src/backend/lineBreak.ml b/src/backend/lineBreak.ml index ab2a74e1d..63ae42909 100644 --- a/src/backend/lineBreak.ml +++ b/src/backend/lineBreak.ml @@ -482,6 +482,7 @@ let rec determine_widths (widreqopt : length option) (lphblst : lb_pure_box list | ImHorzInlineGraphics(w, _, _, _) -> wacc +% w | ImHorzEmbeddedVert(w, _, _, _) -> wacc +% w | ImHorzHookPageBreak(_) -> wacc + | ImHorzFootnote(_) -> wacc ) Length.zero in diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index 26eaf1169..498b531e6 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -33,6 +33,15 @@ type pb_answer = { } +let rec get_height_of_evaled_vert_box_list evvblst = + evvblst |> List.fold_left (fun l evvb -> + match evvb with + | EvVertLine(hgt, dpt, _) -> l +% hgt +% (Length.negate dpt) + | EvVertFixedEmpty(len) -> l +% len + | EvVertFrame(pads, _, _, _, evvblst) -> l +% pads.paddingB +% pads.paddingL +% get_height_of_evaled_vert_box_list evvblst + ) Length.zero + + let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * evaled_vert_box list * (pb_vert_box list) option = let calculate_badness_of_page_break hgttotal = @@ -56,7 +65,12 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst let hgttotal = prev.total_height in match pbvblst with | PBVertLine(hgt, dpt, imhblst) :: pbvbtail -> - let hgttotalnew = hgttotal +% hgt +% (Length.negate dpt) in + let hgtline = hgt +% (Length.negate dpt) in + let (evhblst, imvblstlstfootnote) = PageInfo.embed_page_info pbinfo imhblst in + let (evvblstfootnote, _) = PageInfo.embed_page_info_vert pbinfo (List.concat imvblstlstfootnote) in + (* -- ignores footnote designation in footnote -- *) + let hgtnewfootnote = get_height_of_evaled_vert_box_list evvblstfootnote in + let hgttotalnew = hgttotal +% hgtline +% hgtnewfootnote in let vpb = calculate_badness_of_page_break hgttotalnew in if bprev && (vpb >= vpbprev) && (hgttotal <% hgttotalnew) then (* -- @@ -71,13 +85,12 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst last_badness = vpb; } else - let evhblst = PageInfo.embed_page_info pbinfo imhblst in let evvbaccnew = Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertLine(hgt, dpt, evhblst)) in aux { breakable = true; badness = vpb; solid_body = evvbaccnew; - solid_footnote = footnote; + solid_footnote = Alist.append footnote evvblstfootnote; discardable = Alist.empty; total_height = hgttotalnew; } pbvbtail diff --git a/src/backend/pageInfo.ml b/src/backend/pageInfo.ml index 289406b6f..ee078c8fd 100644 --- a/src/backend/pageInfo.ml +++ b/src/backend/pageInfo.ml @@ -2,33 +2,104 @@ open HorzBox -let rec embed_page_info (pbinfo : page_break_info) (imhblst : intermediate_horz_box list) : evaled_horz_box list = +(* -- + 'embed_page_info pbinfo imhblst' + associates 'ImHorzHookPageBreak(...)' in 'imhblst' with 'pbinfo', and + returns footnotes in 'imhblst' + -- *) + +let rec embed_page_info (pbinfo : page_break_info) (imhblst : intermediate_horz_box list) : evaled_horz_box list * (intermediate_vert_box list) list = let iter = embed_page_info pbinfo in - imhblst |> List.map (function - | ImHorz(evhb) -> evhb - | ImHorzRising(wid, hgt, dpt, lenrising, imhblst) -> (wid, EvHorzRising(hgt, dpt, lenrising, iter imhblst)) - | ImHorzFrame(wid, hgt, dpt, deco, imhblst) -> (wid, EvHorzFrame(hgt, dpt, deco, iter imhblst)) - | ImHorzInlineTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf) -> (wid, EvHorzInlineTabular(hgt, dpt, embed_page_info_to_tabular pbinfo imtabular, widlst, lenlst, rulesf)) - | ImHorzEmbeddedVert(wid, hgt, dpt, imvblst) -> (wid, EvHorzEmbeddedVert(hgt, dpt, embed_page_info_vert pbinfo imvblst)) - | ImHorzHookPageBreak(hookf) -> (Length.zero, EvHorzHookPageBreak(pbinfo, hookf)) - | ImHorzInlineGraphics(wid, hgt, dpt, graphics) -> (wid, EvHorzInlineGraphics(hgt, dpt, graphics)) - ) - -and embed_page_info_to_tabular (pbinfo : page_break_info) (imtabular : intermediate_row list) : evaled_row list = - imtabular |> List.map (fun (widtotal, imcelllst) -> - let evcelllst = - imcelllst |> List.map (function - | ImEmptyCell(len) -> EvEmptyCell(len) - | ImNormalCell(info, imhblst) -> EvNormalCell(info, embed_page_info pbinfo imhblst) - | ImMultiCell(info, imhblst) -> EvMultiCell(info, embed_page_info pbinfo imhblst) - ) - in - (widtotal, evcelllst) - ) - -and embed_page_info_vert (pbinfo : page_break_info) (imvblst : intermediate_vert_box list) : evaled_vert_box list = - imvblst |> List.map (function - | ImVertLine(hgt, dpt, imhblst) -> EvVertLine(hgt, dpt, embed_page_info pbinfo imhblst) - | ImVertFixedEmpty(vskip) -> EvVertFixedEmpty(vskip) - | ImVertFrame(pads, deco, wid, imvblst) -> EvVertFrame(pads, pbinfo, deco, wid, embed_page_info_vert pbinfo imvblst) - ) + let (evhbacc, footnoteacc) = + imhblst |> List.fold_left (fun (evhbacc, footnoteacc) imhb -> + let extH = Alist.extend evhbacc in + let appendF = Alist.append footnoteacc in + let ext evhb = (extH evhb, footnoteacc) in + match imhb with + | ImHorz(evhb) -> + ext evhb + + | ImHorzRising(wid, hgt, dpt, lenrising, imhblst) -> + let (evhblst, footnotelst) = iter imhblst in + let evhb = (wid, EvHorzRising(hgt, dpt, lenrising, evhblst)) in + (extH evhb, appendF footnotelst) + + | ImHorzFrame(wid, hgt, dpt, deco, imhblst) -> + let (evhblst, footnotelst) = iter imhblst in + let evhb = (wid, EvHorzFrame(hgt, dpt, deco, evhblst)) in + (extH evhb, appendF footnotelst) + + | ImHorzInlineTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf) -> + let (evrowlst, footnotelst) = embed_page_info_to_tabular pbinfo imtabular in + ext (wid, EvHorzInlineTabular(hgt, dpt, evrowlst, widlst, lenlst, rulesf)) + + | ImHorzEmbeddedVert(wid, hgt, dpt, imvblst) -> + let (evvblst, footnotelst) = embed_page_info_vert pbinfo imvblst in + let evhb = (wid, EvHorzEmbeddedVert(hgt, dpt, evvblst)) in + (extH evhb, appendF footnotelst) + + | ImHorzHookPageBreak(hookf) -> + ext (Length.zero, EvHorzHookPageBreak(pbinfo, hookf)) + + | ImHorzInlineGraphics(wid, hgt, dpt, graphics) -> + ext (wid, EvHorzInlineGraphics(hgt, dpt, graphics)) + + | ImHorzFootnote(imvblst) -> + (evhbacc, Alist.extend footnoteacc imvblst) + + ) (Alist.empty, Alist.empty) + in + (Alist.to_list evhbacc, Alist.to_list footnoteacc) + + +and embed_page_info_to_tabular (pbinfo : page_break_info) (imtabular : intermediate_row list) : evaled_row list * (intermediate_vert_box list) list = + let (evrowacc, footnoteacc) = + imtabular |> List.fold_left (fun (evrowacc, footnoteacc) (widtotal, imcelllst) -> + let (evcellacc, footnoteacc) = + imcelllst |> List.fold_left (fun (evcellacc, footnoteacc) imcell -> + let extC = Alist.extend evcellacc in + let appendF = Alist.append footnoteacc in + match imcell with + | ImEmptyCell(len) -> + (extC (EvEmptyCell(len)), footnoteacc) + + | ImNormalCell(info, imhblst) -> + let (evhblst, footnotelst) = embed_page_info pbinfo imhblst in + let evcell = EvNormalCell(info, evhblst) in + (extC evcell, appendF footnotelst) + + | ImMultiCell(info, imhblst) -> + let (evhblst, footnotelst) = embed_page_info pbinfo imhblst in + let evcell = EvMultiCell(info, evhblst) in + (extC evcell, appendF footnotelst) + + ) (Alist.empty, footnoteacc) + in + (Alist.extend evrowacc (widtotal, Alist.to_list evcellacc), footnoteacc) + ) (Alist.empty, Alist.empty) + in + (Alist.to_list evrowacc, Alist.to_list footnoteacc) + + +and embed_page_info_vert (pbinfo : page_break_info) (imvblst : intermediate_vert_box list) : evaled_vert_box list * (intermediate_vert_box list) list = + let (evvbacc, footnoteacc) = + imvblst |> List.fold_left (fun (evvbacc, footnoteacc) imvb -> + let extV = Alist.extend evvbacc in + let appendF = Alist.append footnoteacc in + match imvb with + | ImVertLine(hgt, dpt, imhblst) -> + let (imvblst, footnotelst) = embed_page_info pbinfo imhblst in + let evvb = EvVertLine(hgt, dpt, imvblst) in + (extV evvb, appendF footnotelst) + + | ImVertFixedEmpty(vskip) -> + (extV (EvVertFixedEmpty(vskip)), footnoteacc) + + | ImVertFrame(pads, deco, wid, imvblst) -> + let (evvblst, footnotelst) = embed_page_info_vert pbinfo imvblst in + let evvb = EvVertFrame(pads, pbinfo, deco, wid, evvblst) in + (extV evvb, appendF footnotelst) + + ) (Alist.empty, Alist.empty) + in + (Alist.to_list evvbacc, Alist.to_list footnoteacc) From 62a1365bbf25927eca8da2e4e509cc792a8021e5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 02:46:11 +0900 Subject: [PATCH 28/78] add 'PHGFootnote' and 'LBFootnote' --- src/backend/horzBox.ml | 10 +++++++++- src/backend/lineBreak.ml | 11 ++++++++++- src/backend/lineBreakBox.ml | 1 + 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index 0f0805f03..f19cd4ffc 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -246,6 +246,7 @@ and pure_horz_box = | PHGFixedImage of length * length * ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "@[PHGFixedImage(...)@]")] | PHGHookPageBreak of (page_break_info -> point -> unit) + | PHGFootnote of intermediate_vert_box list and horz_box = | HorzPure of pure_horz_box @@ -318,6 +319,11 @@ and intermediate_vert_box = and evaled_vert_box = | EvVertLine of length * length * evaled_horz_box list [@printer (fun fmt _ -> Format.fprintf fmt "EvLine")] + (* -- + (1) height of the contents + (2) depth of the contents (nonpositive) + (3) contents + -- *) | EvVertFixedEmpty of length [@printer (fun fmt _ -> Format.fprintf fmt "EvEmpty")] | EvVertFrame of paddings * page_break_info * decoration * length * evaled_vert_box list @@ -476,7 +482,9 @@ let get_metrics_of_intermediate_horz_box_list (imhblst : intermediate_horz_box l match imhb with | ImHorz(evhb) -> get_metrics_of_evaled_horz_box evhb - | ImHorzHookPageBreak(_) -> (Length.zero, Length.zero, Length.zero) + | ImHorzHookPageBreak(_) + | ImHorzFootnote(_) + -> (Length.zero, Length.zero, Length.zero) | ImHorzRising(w, h, d, _, _) | ImHorzFrame(w, h, d, _, _) diff --git a/src/backend/lineBreak.ml b/src/backend/lineBreak.ml index 63ae42909..084e0530d 100644 --- a/src/backend/lineBreak.ml +++ b/src/backend/lineBreak.ml @@ -31,7 +31,10 @@ let get_metrics (lphb : lb_pure_box) : metrics = | LBFixedGraphics(wid, hgt, dpt, _) -> (natural wid, hgt, dpt) | LBFixedTabular(wid, hgt, dpt, _, _, _, _) -> (natural wid, hgt, dpt) | LBFixedImage(wid, hgt, _) -> (natural wid, hgt, Length.zero) - | LBHookPageBreak(_) -> (widinfo_zero, Length.zero, Length.zero) + + | LBHookPageBreak(_) + | LBFootnote(_) + -> (widinfo_zero, Length.zero, Length.zero) let get_total_metrics (lphblst : lb_pure_box list) : metrics = @@ -159,6 +162,9 @@ let convert_pure_box_for_line_breaking_scheme (type a) (listf : horz_box list -> | PHGHookPageBreak(hookf) -> puref (LBHookPageBreak(hookf)) + | PHGFootnote(imvblst) -> + puref (LBFootnote(imvblst)) + let convert_pure_box_for_line_breaking_pure listf (phb : pure_horz_box) : lb_pure_either = let puref p = PLB(p) in @@ -532,6 +538,9 @@ let rec determine_widths (widreqopt : length option) (lphblst : lb_pure_box list | LBHookPageBreak(hookf) -> ImHorzHookPageBreak(hookf) + + | LBFootnote(imvblst) -> + ImHorzFootnote(imvblst) in let imhblst = lphblst |> List.map (main_conversion ratios widperfil) in (* diff --git a/src/backend/lineBreakBox.ml b/src/backend/lineBreakBox.ml index 9cf409159..469a93304 100644 --- a/src/backend/lineBreakBox.ml +++ b/src/backend/lineBreakBox.ml @@ -16,6 +16,7 @@ type lb_pure_box = | LBFixedTabular of length * length * length * intermediate_row list * length list * length list * rules_func | LBFixedImage of length * length * ImageInfo.key | LBHookPageBreak of (page_break_info -> point -> unit) + | LBFootnote of intermediate_vert_box list type lb_box = | LBPure of lb_pure_box From c1f2248441f494a37b183fa193b5117cbfd412fe Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 03:17:10 +0900 Subject: [PATCH 29/78] add the operation of outputting footnotes --- src/backend/handlePdf.ml | 16 +++++++++++++--- src/backend/handlePdf.mli | 2 +- src/backend/horzBox.ml | 9 +++++++++ src/backend/pageBreak.ml | 11 +---------- 4 files changed, 24 insertions(+), 14 deletions(-) diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index 21c696589..bf0f8b801 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -247,7 +247,7 @@ let get_paper_height (paper : Pdfpaper.t) : length = Length.of_pdf_point pdfpt -let page_of_evaled_vert_box_list (pagesize : page_size) (pbinfo : page_break_info) (pagecontsch : page_content_scheme) (evvblstpage : evaled_vert_box list) : page = +let make_page (pagesize : page_size) (pbinfo : page_break_info) (pagecontsch : page_content_scheme) (evvblstbody : evaled_vert_box list) (evvblstfootnote : evaled_vert_box list) : page = let paper = match pagesize with | A0Paper -> Pdfpaper.a0 @@ -262,8 +262,18 @@ let page_of_evaled_vert_box_list (pagesize : page_size) (pbinfo : page_break_inf in let paper_height = get_paper_height paper in - let pt_init = invert_coordinate paper_height pagecontsch.page_content_origin in - let (_, opaccpage) = ops_of_evaled_vert_box_list pbinfo pt_init Alist.empty evvblstpage in + let (_, opaccbody) = + let pt_init = invert_coordinate paper_height pagecontsch.page_content_origin in + ops_of_evaled_vert_box_list pbinfo pt_init Alist.empty evvblstbody + in + let (_, opaccfootnote) = + let hgtfootnote = get_height_of_evaled_vert_box_list evvblstfootnote in + let (xorg, yorg) = pagecontsch.page_content_origin in + let hgtreq = pagecontsch.page_content_height in + let pt_init = invert_coordinate paper_height (xorg, yorg +% hgtreq -% hgtfootnote) in + ops_of_evaled_vert_box_list pbinfo pt_init Alist.empty evvblstfootnote + in + let opaccpage = Alist.cat opaccbody opaccfootnote in Page(paper, pagecontsch, opaccpage, pbinfo) diff --git a/src/backend/handlePdf.mli b/src/backend/handlePdf.mli index 167ca7525..f12e3f2e8 100644 --- a/src/backend/handlePdf.mli +++ b/src/backend/handlePdf.mli @@ -12,4 +12,4 @@ val write_page : page -> page_parts_scheme_func -> t -> t val write_to_file : t -> unit -val page_of_evaled_vert_box_list : page_size -> page_break_info -> page_content_scheme -> evaled_vert_box list -> page +val make_page : page_size -> page_break_info -> page_content_scheme -> evaled_vert_box list -> evaled_vert_box list -> page diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index f19cd4ffc..0c5503312 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -476,6 +476,15 @@ let get_metrics_of_evaled_horz_box ((wid, evhbmain) : evaled_horz_box) : length (wid, hgt, dpt) +let rec get_height_of_evaled_vert_box_list evvblst = + evvblst |> List.fold_left (fun l evvb -> + match evvb with + | EvVertLine(hgt, dpt, _) -> l +% hgt +% (Length.negate dpt) + | EvVertFixedEmpty(len) -> l +% len + | EvVertFrame(pads, _, _, _, evvblst) -> l +% pads.paddingB +% pads.paddingL +% get_height_of_evaled_vert_box_list evvblst + ) Length.zero + + let get_metrics_of_intermediate_horz_box_list (imhblst : intermediate_horz_box list) : length * length * length = imhblst |> List.fold_left (fun (wid, hgt, dpt) imhb -> let (w, h, d) = diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index 498b531e6..229e4fe10 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -33,15 +33,6 @@ type pb_answer = { } -let rec get_height_of_evaled_vert_box_list evvblst = - evvblst |> List.fold_left (fun l evvb -> - match evvb with - | EvVertLine(hgt, dpt, _) -> l +% hgt +% (Length.negate dpt) - | EvVertFixedEmpty(len) -> l +% len - | EvVertFrame(pads, _, _, _, evvblst) -> l +% pads.paddingB +% pads.paddingL +% get_height_of_evaled_vert_box_list evvblst - ) Length.zero - - let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst : pb_vert_box list) : evaled_vert_box list * evaled_vert_box list * (pb_vert_box list) option = let calculate_badness_of_page_break hgttotal = @@ -303,7 +294,7 @@ let main (file_name_out : string) (pagesize : page_size) (pagecontf : page_conte let pagecontsch = pagecontf pbinfo in (* -- invokes the page scheme function -- *) let (evvblstpage, footnote, restopt) = chop_single_page pbinfo pagecontsch.page_content_height pbvblst in - let page = HandlePdf.page_of_evaled_vert_box_list pagesize pbinfo pagecontsch evvblstpage in + let page = HandlePdf.make_page pagesize pbinfo pagecontsch evvblstpage footnote in let pdfaccnew = pdfacc |> HandlePdf.write_page page pagepartsf in match restopt with | None -> pdfaccnew From 91cfb96e0fd775a3a901095b856e8488ed6d96a9 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 05:15:40 +0900 Subject: [PATCH 30/78] add primitive 'add-footnote' --- src/frontend/bytecomp/vminstdef.yaml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index be0fa42b9..80f4b4c14 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1416,6 +1416,19 @@ code: | VertBottomMargin(true, ctx.paragraph_bottom); ])) +--- +inst: BackendAddFootnote +is-primitive: yes +name: "add-footnote" +type: | + ~% (tBB @-> tIB) + +params: +- vblst : vert +code: | + let imvblst = PageBreak.solidify vblst in + Horz(HorzBox.([HorzPure(PHGFootnote(imvblst))])) + --- inst: BackendEmbeddedVertTop is-primitive: yes From b75b4c3c479104e2c05b3c6d031d8ab76877b62c Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 15 Aug 2018 05:16:05 +0900 Subject: [PATCH 31/78] add '\footnote' to 'stdjabook' --- lib-satysfi/dist/packages/stdjabook.satyh | 86 ++++++++++++++++++++++- 1 file changed, 85 insertions(+), 1 deletion(-) diff --git a/lib-satysfi/dist/packages/stdjabook.satyh b/lib-satysfi/dist/packages/stdjabook.satyh index 0ea64cff1..6fb681d5c 100644 --- a/lib-satysfi/dist/packages/stdjabook.satyh +++ b/lib-satysfi/dist/packages/stdjabook.satyh @@ -31,6 +31,7 @@ module StdJaBook : sig direct +section : [string?; inline-text; block-text] block-cmd direct +subsection : [string?; inline-text; block-text] block-cmd direct \emph : [inline-text] inline-cmd + direct \footnote : [inline-text] inline-cmd end = struct @@ -302,6 +303,10 @@ let title-deco = inline-fil ++ (repeat-inline n ib) + let-mutable footnote-ref <- 0 + let-mutable first-footnote <- true + + let document record inner = % -- constants -- let title = record#title in @@ -316,6 +321,10 @@ let title-deco = let ftrwid = 520pt in let thickness = header-line-thickness in + let () = + register-cross-reference `changed` `F` + in + let ctx-doc = get-standard-context txtwid in % -- title -- @@ -378,6 +387,7 @@ let title-deco = % -- page settings -- let pagecontf pbinfo = + let () = first-footnote <- true in let hgtfb = height-of-float-boxes pbinfo#page-number in let (txtorgx, txtorgy) = txtorg in (| @@ -532,7 +542,81 @@ let title-deco = in read-inline ctx-emph inner -end + + let generate-footnote-label n = + `footnote:` ^ (arabic n) + + + let promote-another-trial () = + register-cross-reference `changed` `T` + + + let-inline ctx \footnote it = + let () = footnote-ref <- !footnote-ref + 1 in + let num = !footnote-ref in + let label = generate-footnote-label num in + let it-num = embed-string (arabic num) in + let size = get-font-size ctx in + let ib-num = + let ctx = + ctx |> set-font-size (size *' 0.75) + |> set-manual-rising (size *' 0.25) + in + read-inline ctx {\*#it-num;} + in + let (bb-before, top-margin) = + match get-cross-reference label with + | Some(`T`) -> + let () = display-message (`'` ^ label ^ `': T`) in % for debug + let bar-top-margin = size in + let bar-bottom-margin = 2pt in + let wid = get-text-width ctx in + let ib = + inline-graphics wid bar-top-margin bar-bottom-margin (fun (x, y) -> + [ stroke 0.5pt Color.black (Gr.line (x, y) (x +' wid, y)); ] + ) + in + (line-break false false (ctx |> set-paragraph-margin 0pt 0pt) ib, 0pt) + + | _ -> + let () = display-message (`'` ^ label ^ `': F`) in % for debug + (block-skip 0pt, size *' 0.5) + in + let bb = + let ctx = + ctx |> set-font-size (size *' 0.9) + |> set-leading (size *' 1.2) + |> set-paragraph-margin top-margin (size *' 0.5) + %temporary + in + line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil) + in + let pads = (0pt, 0pt, 0pt, 0pt) in + let deco _ _ _ _ = [] in + inline-frame-inner pads deco + (add-footnote (bb-before +++ bb) ++ ib-num + ++ hook-page-break (fun _ _ -> ( + let () = + if !first-footnote then + match get-cross-reference label with + | Some(`T`) -> + () + + | _ -> + let () = promote-another-trial () in + register-cross-reference label `T` + else + match get-cross-reference label with + | Some(`F`) -> + () + + | _ -> + let () = promote-another-trial () in + register-cross-reference label `F` + in + first-footnote <- false))) + + end let document = StdJaBook.document From 4d317e7470f90a4b1f1f96cc40ac8050a9a8cf62 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 16 Aug 2018 11:00:04 +0900 Subject: [PATCH 32/78] omit unnecessary code in 'math.ml' --- src/frontend/math.ml | 69 ++------------------------------------------ 1 file changed, 3 insertions(+), 66 deletions(-) diff --git a/src/frontend/math.ml b/src/frontend/math.ml index bea080a96..2822ac0b7 100644 --- a/src/frontend/math.ml +++ b/src/frontend/math.ml @@ -74,8 +74,8 @@ type low_math_main = | LowMathSubSuperscript of length * length * low_math * low_math * low_math (* -- - (1) baselin height of the superscript - (2) baselin height of the subscript + (1) baseline height of the superscript + (2) baseline height of the subscript (3) base contents (4) superscript contents (5) subscript contents @@ -274,29 +274,6 @@ let normalize_math_kind mkprev mknext mkraw = else MathBinary -(* - begin - match (mkprev, mknext) with - | (MathOrdinary, MathOrdinary) - | (MathInner , MathInner ) - | (MathInner , MathOrdinary) - | (MathOrdinary, MathInner ) - - | (MathClose , MathOrdinary) - | (MathClose , MathInner ) - - | (MathOrdinary, MathOpen ) - | (MathInner , MathOpen ) - - | (MathClose , MathOpen ) - -> MathBinary - - | _ -> - Format.printf "Math> normalize (%a, %a)\n" pp_math_kind mkprev pp_math_kind mknext; (*for debug *) - MathOrdinary - end -*) - | MathRelation -> mkraw @@ -336,9 +313,6 @@ let space_after_script mathctx = None else let mc = FontInfo.get_math_constants mathctx in -(* - Format.printf "Math> space_after_script = %f\n" mc.FontFormat.space_after_script; (* for debug *) -*) Some(outer_empty (fontsize *% mc.FontFormat.space_after_script) Length.zero Length.zero) (* temporary; should have variable stretchability and shrinkability *) @@ -738,16 +712,6 @@ let rec convert_math_element (mathctx : math_context) (mkprev : math_kind) (mkne let mk = normalize_math_kind mkprev mknext mkrawv in let is_big = false in convert_math_char mathctx is_big uchlst mk -(* - begin - match mvvaluemain with - | MathVariantToChar(is_big, uchlst) -> - convert_math_char mathctx is_big uchlst mk - - | MathVariantToCharWithKern(is_big, uchlst, mckernfL, mckernfR) -> - convert_math_char_with_kern mathctx is_big uchlst mk mckernfL mckernfR - end -*) | MathVariantCharDirect(mkraw, is_big, mvsty) -> let mk = normalize_math_kind mkprev mknext mkraw in @@ -973,14 +937,7 @@ let horz_fraction_bar mathctx wid = let calculate_kern mathctx (mkernsch : FontInfo.math_kern_scheme) (corrhgt : length) : length = -(* - Format.printf "Math> corrB = %f\n" (Length.to_pdf_point corrhgt); (* for debug *) -*) - let len = FontInfo.get_math_kern mathctx mkernsch corrhgt in -(* - Format.printf "Math> kern = %f\n" (Length.to_pdf_point len); (* for debug *) -*) - len + FontInfo.get_math_kern mathctx mkernsch corrhgt let raise_horz r hblst = @@ -1046,9 +1003,6 @@ let rec horz_of_low_math (mathctx : math_context) (mkprevfirst : math_kind) (mkl let l_kernbase = calculate_kern mathctx rkB.kernTR l_base in let l_kernsup = calculate_kern (MathContext.enter_script mathctx) lkS.kernBL l_sup in let l_italic = rkB.italics_correction in - (* - Format.printf "Math> l_italic = %f, l_kernbase = %f, l_kernsup = %f\n" (Length.to_pdf_point l_italic) (Length.to_pdf_point l_kernbase) (Length.to_pdf_point l_kernsup); - *) let kern = l_italic +% l_kernbase +% l_kernsup in let hbkern = fixed_empty kern in let hblstsup = @@ -1274,20 +1228,3 @@ let space_between_maths (mathctx : math_context) (mathlst1 : math list) (mathlst | _ -> None - - - - - - -(* -(* for tests *) -let () = - let mathinfo = { math_font_abbrev = "euler"; math_font_size = Length.of_pdf_point 12.; } in - let md = FontFormat.get_math_decoder "/usr/local/lib-satysfi/dist/fonts/euler.otf" in - let mlst = [MathSuperscript([MathPure(MathOrdinary, MathChar(mathinfo, Uchar.of_char 'P'))], [MathPure(MathOrdinary, MathChar(mathinfo, Uchar.of_char 'A'))])] in - let lm = convert_to_low 0 mlst in - let hblst = horz_of_low_math 0 mathinfo md lm in - List.iter (fun hb -> Format.printf "%a@ " pp_horz_box hb) hblst; - print_endline ""; -*) From f4e4fafb0ff3e7620cfb632e1cfb70d7ab9f30d5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 16 Aug 2018 11:48:06 +0900 Subject: [PATCH 33/78] add 'MathPullInScripts' --- src/frontend/math.ml | 125 +++++++++++++++++++++++++++--------- src/frontend/types_.cppo.ml | 1 + 2 files changed, 94 insertions(+), 32 deletions(-) diff --git a/src/frontend/math.ml b/src/frontend/math.ml index 2822ac0b7..6206fc49f 100644 --- a/src/frontend/math.ml +++ b/src/frontend/math.ml @@ -45,7 +45,7 @@ type low_radical = horz_box list type low_math_main = | LowMathPure of low_math_pure - | LowMathList of math_context_change * low_math + | LowMathList of math_context_change option * low_math (* -- (1) information for updating math contexts (2) inner contents @@ -481,6 +481,7 @@ let get_math_kind_of_math_element (ctx : input_context) = function let rec get_left_math_kind (ctx : input_context) = function | MathPure(me) -> get_math_kind_of_math_element ctx me + | MathPullInScripts(mkL, _, _) -> mkL | MathGroup(mkL, _, _) -> mkL | MathSuperscript([], _) -> MathEnd | MathSuperscript(mathB :: _, _) -> get_left_math_kind ctx mathB @@ -503,6 +504,7 @@ let rec get_right_math_kind (ctx : input_context) math = try match math with | MathPure(me) -> get_math_kind_of_math_element ctx me + | MathPullInScripts(_, mkR, _) -> mkR | MathGroup(_, mkR, _) -> mkR | MathSuperscript([], _) -> MathEnd | MathSuperscript(mathlst, _) -> get_right_math_kind ctx (List.hd (List.rev mathlst)) @@ -699,6 +701,16 @@ let rec check_subscript mlstB = | _ -> None +let check_pull_in mlstB = + match List.rev mlstB with + | MathPullInScripts(mkL, mkR, mlstf) :: mtailrev -> + (* -- if the last element of the base contents is a pull-in-scripts -- *) + Some(((mkL, mkR, mlstf), List.rev mtailrev)) + + | _ -> + None + + let rec convert_math_element (mathctx : math_context) (mkprev : math_kind) (mknext : math_kind) (me : math_element) : low_math_pure = match me with | MathElement(mkraw, MathEmbeddedText(hblstf)) -> @@ -769,11 +781,18 @@ and convert_to_low_single (mkprev : math_kind) (mknext : math_kind) (mathctx : m let (mk, wid, hgt, dpt, lme, lk, rk) = convert_math_element mathctx mkprev mknext me in (LowMathPure(mk, wid, hgt, dpt, lme, lk, rk), hgt, dpt) + | MathPullInScripts(mkL, mkR, mlstf) -> + let mlstI = mlstf None None in + (* -- invokes the math-generating function -- *) + let lmI = convert_to_low mathctx mkprev mknext mlstI in + let (_, h_inner, d_inner, _, rk) = lmI in + (LowMathGroup(mkL, mkR, lmI), h_inner, d_inner) + | MathChangeContext(chg, mlstI) -> let mathctxnew = mathctx |> change_math_context chg in let lmI = convert_to_low mathctxnew mkprev mknext mlstI in let (_, h_inner, d_inner, _, rk) = lmI in - (LowMathList(chg, lmI), h_inner, d_inner) + (LowMathList(Some(chg), lmI), h_inner, d_inner) | MathGroup(mkL, mkR, mlstC) -> let lmC = convert_to_low mathctx MathEnd MathClose mlstC in @@ -792,43 +811,67 @@ and convert_to_low_single (mkprev : math_kind) (mknext : math_kind) (mathctx : m (LowMathFraction(h_numerbl, d_denombl, lmN, lmD), h_frac, d_frac) | MathSubscript(mlstB, mlstS) -> - let lmB = convert_to_low mathctx mkprev MathEnd mlstB in - let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in - let (_, h_base, d_base, _, rkB) = lmB in - let (_, h_sub, d_sub, _, _) = lmS in - let d_subbl = subscript_baseline_depth mathctx rkB.last_depth h_sub in - let h_whole = h_base in - let d_whole = Length.min d_base (d_subbl +% d_sub) in - (LowMathSubscript(d_subbl, lmB, lmS), h_whole, d_whole) + begin + match check_pull_in mlstB with + | Some((pullin, mlstB)) -> + (* -- if the last element of the base contents is a pull-in-scripts -- *) + invoke_pull_in_scripts (mathctx, mkprev, mknext) pullin (Some(mlstS)) None mlstB + + | None -> + let lmB = convert_to_low mathctx mkprev MathEnd mlstB in + let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in + let (_, h_base, d_base, _, rkB) = lmB in + let (_, h_sub, d_sub, _, _) = lmS in + let d_subbl = subscript_baseline_depth mathctx rkB.last_depth h_sub in + let h_whole = h_base in + let d_whole = Length.min d_base (d_subbl +% d_sub) in + (LowMathSubscript(d_subbl, lmB, lmS), h_whole, d_whole) + end | MathSuperscript(mlstB, mlstS) -> begin match check_subscript mlstB with | Some((mlstT, mlstB)) -> (* -- if the last element of the base contents has a subscript -- *) - let lmB = convert_to_low mathctx mkprev MathEnd mlstB in - let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in - let lmT = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstT in - let (_, h_base, d_base, _, rkB) = lmB in - let (_, h_sup, d_sup, _, _) = lmS in - let (_, h_sub, d_sub, _, _) = lmT in - let h_supbl_raw = superscript_baseline_height mathctx h_base d_sup in - let d_subbl_raw = subscript_baseline_depth mathctx rkB.last_depth h_sub in - let (h_supbl, d_subbl) = correct_script_baseline_heights mathctx d_sup h_sub h_supbl_raw d_subbl_raw in - let h_whole = Length.max h_base (h_supbl +% h_sup) in - let d_whole = Length.min d_base (d_subbl +% d_sub) in - (LowMathSubSuperscript(h_supbl, d_subbl, lmB, lmS, lmT), h_whole, d_whole) + begin + match check_pull_in mlstB with + | Some((pullin, mlstB)) -> + (* -- if the last element of the base contents is a pull-in-scipts -- *) + invoke_pull_in_scripts (mathctx, mkprev, mknext) pullin (Some(mlstT)) (Some(mlstS)) mlstB + + | None -> + let lmB = convert_to_low mathctx mkprev MathEnd mlstB in + let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in + let lmT = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstT in + let (_, h_base, d_base, _, rkB) = lmB in + let (_, h_sup, d_sup, _, _) = lmS in + let (_, h_sub, d_sub, _, _) = lmT in + let h_supbl_raw = superscript_baseline_height mathctx h_base d_sup in + let d_subbl_raw = subscript_baseline_depth mathctx rkB.last_depth h_sub in + let (h_supbl, d_subbl) = correct_script_baseline_heights mathctx d_sup h_sub h_supbl_raw d_subbl_raw in + let h_whole = Length.max h_base (h_supbl +% h_sup) in + let d_whole = Length.min d_base (d_subbl +% d_sub) in + (LowMathSubSuperscript(h_supbl, d_subbl, lmB, lmS, lmT), h_whole, d_whole) + end | None -> (* -- if the last element of the base contents does NOT have a subscript -- *) - let lmB = convert_to_low mathctx mkprev MathEnd mlstB in - let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in - let (_, h_base, d_base, _, rkB) = lmB in - let (_, h_sup, d_sup, _, _) = lmS in - let h_supbl = superscript_baseline_height mathctx h_base d_sup in - let h_whole = Length.max h_base (h_supbl +% h_sup) in - let d_whole = d_base in - (LowMathSuperscript(h_supbl, lmB, lmS), h_whole, d_whole) + begin + match check_pull_in mlstB with + | Some((pullin, mlstB)) -> + (* -- if the last element of the base contents is a pull-in-scipts -- *) + invoke_pull_in_scripts (mathctx, mkprev, mknext) pullin None (Some(mlstS)) mlstB + + | None -> + let lmB = convert_to_low mathctx mkprev MathEnd mlstB in + let lmS = convert_to_low (MathContext.enter_script mathctx) MathEnd MathEnd mlstS in + let (_, h_base, d_base, _, rkB) = lmB in + let (_, h_sup, d_sup, _, _) = lmS in + let h_supbl = superscript_baseline_height mathctx h_base d_sup in + let h_whole = Length.max h_base (h_supbl +% h_sup) in + let d_whole = d_base in + (LowMathSuperscript(h_supbl, lmB, lmS), h_whole, d_whole) + end end | MathRadical(radical, mlstC) -> @@ -910,6 +953,20 @@ and convert_to_low_single (mkprev : math_kind) (mknext : math_kind) (mathctx : m (LowMathLowerLimit(d_lowbl, lmB, lmL), h_whole, d_whole) +(* -- + 'mlstSopt': 'None' or subscript enveloped in 'Some(_)' + 'mlstTopt': 'None' or superscript enveloped in 'Some(_)' + 'mlstB': the math list attached before the math list generated by pull-in-scripts + -- *) +and invoke_pull_in_scripts (mathctx, mkprev, mknext) (mkL, mkR, mlstf) mlstSopt mlstTopt mlstB = + let mlstIsub = mlstf mlstSopt mlstTopt in + (* -- invokes the math-generating function -- *) + let mlstI = List.append mlstB [MathGroup(mkL, mkR, mlstIsub)] in + let lmI = convert_to_low mathctx mkprev mknext mlstI in + let (_, h_inner, d_inner, _, rk) = lmI in + (LowMathList(None, lmI), h_inner, d_inner) + + let horz_of_low_math_element (lme : low_math_atom) : horz_box list = match lme with | LowMathGlyph(mathstrinfo, wid, hgt, dpt, otxt) -> @@ -976,9 +1033,13 @@ let rec horz_of_low_math (mathctx : math_context) (mkprevfirst : math_kind) (mkl let corrnext = get_space_correction lmmain in let (hblst, hbspaceopt, mk) = match lmmain with - | LowMathList(chg, lmI) -> + | LowMathList(chgopt, lmI) -> let (_, _, _, lkI, rkI) = lmI in - let mathctxnew = mathctx |> change_math_context chg in + let mathctxnew = + match chgopt with + | None -> mathctx + | Some(chg) -> mathctx |> change_math_context chg + in let hblst = horz_of_low_math mathctxnew mkprevfirst MathEnd lmI in let hbspaceopt = space_between_math_kinds mathctxnew mkprev corr lkI.left_math_kind in (hblst, hbspaceopt, rkI.right_math_kind) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index e3f535726..39256a037 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -791,6 +791,7 @@ and math_context_change = and math = | MathPure of math_element + | MathPullInScripts of HorzBox.math_kind * HorzBox.math_kind * ((math list) option -> (math list) option -> math list) | MathChangeContext of math_context_change * math list | MathGroup of HorzBox.math_kind * HorzBox.math_kind * math list | MathSubscript of math list * math list From d92559301d4d48df8e7ddc45a5aa8ed7cdae7ef5 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 16 Aug 2018 12:28:20 +0900 Subject: [PATCH 34/78] add primitive 'math-pull-in-scripts' --- src/frontend/bytecomp/vminstdef.yaml | 17 +++++++++++++++++ src/frontend/evalUtil.ml | 19 +++++++++++++++++++ 2 files changed, 36 insertions(+) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 80f4b4c14..194bcf8c8 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -896,6 +896,23 @@ params: code: | MathValue([MathLowerLimit(mlst1, mlst2)]) +--- +inst: BackendMathPullInScripts +is-primitive: yes +name: "math-pull-in-scripts" +type: | + ~% (tMATHCLS @-> tMATHCLS @-> (tOPT tMATH @-> tOPT tMATH @-> tMATH) @-> tMATH) + +params: +- mathcls1 : math_class +- mathcls2 : math_class +- valuef +needs-reducef: yes +code: | + let mlstf = make_pull_in_scripts reducef valuef in + let mlst = [HorzBox.(MathPullInScripts(mathcls1, mathcls2, mlstf))] in + MathValue(mlst) + --- inst: BackendMathChar is-primitive: yes diff --git a/src/frontend/evalUtil.ml b/src/frontend/evalUtil.ml index 30eebb317..f1cff176a 100644 --- a/src/frontend/evalUtil.ml +++ b/src/frontend/evalUtil.ml @@ -592,6 +592,25 @@ let make_paren reducef valueparenf : HorzBox.paren = ) +let make_math (mlst : math list) : syntactic_value = + MathValue(mlst) + + +let make_option (type a) (makef : a -> syntactic_value) (opt : a option) : syntactic_value = + match opt with + | None -> Constructor("None", UnitConstant) + | Some(x) -> let value = makef x in Constructor("Some", value) + + +let make_pull_in_scripts reducef valuef = + (fun mopt1 mopt2 -> + let value1 = make_option make_math mopt1 in + let value2 = make_option make_math mopt2 in + let valueret = reducef valuef [value1; value2] in + get_math valueret + ) + + let make_math_char_kern_func reducef valuekernf : HorzBox.math_char_kern_func = (fun fontsize ypos -> let valuefontsize = LengthConstant(fontsize) in From f2d253b964398aeabce85dc645bac8a19fbd78f9 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 16 Aug 2018 12:58:47 +0900 Subject: [PATCH 35/78] update 'math.satyh' by using 'math-pull-in-scripts' --- lib-satysfi/dist/packages/math.satyh | 30 +++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/lib-satysfi/dist/packages/math.satyh b/lib-satysfi/dist/packages/math.satyh index 6c231e8a9..3840ea7b6 100644 --- a/lib-satysfi/dist/packages/math.satyh +++ b/lib-satysfi/dist/packages/math.satyh @@ -666,7 +666,23 @@ end = struct let op = math-char MathOp let punct = math-char MathPunct let prefix = math-char MathPrefix - let bigop = math-big-char MathOp + + let vop-scheme charf s = + let mop = charf MathOp s in + math-pull-in-scripts MathOp MathOp + (fun moptS moptT -> ( + let m = + match moptS with + | None -> mop + | Some(mS) -> math-lower mop mS + in + match moptT with + | None -> m + | Some(mT) -> math-upper m mT + )) + + let bigop = vop-scheme math-big-char + let vop = vop-scheme math-char let-math \to = rel `→` let-math \pm = bin `±` @@ -762,12 +778,12 @@ end = struct let-math \ddots = ord `⋱` let-math \backddots = ord `⋰` - let-math \lim = op `lim` - let-math \colim = op `colim` - let-math \max = op `max` - let-math \min = op `min` - let-math \inf = op `inf` - let-math \sup = op `sup` + let-math \lim = vop `lim` + let-math \colim = vop `colim` + let-math \max = vop `max` + let-math \min = vop `min` + let-math \inf = vop `inf` + let-math \sup = vop `sup` let-math \sin = op `sin` let-math \cos = op `cos` let-math \tan = op `tan` From 1697ee3c06514b8d21143e334e132323359f0798 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 04:06:39 +0900 Subject: [PATCH 36/78] change function names in 'Primitives' --- src/frontend/bytecomp/vminstdef.yaml | 3 +- src/frontend/main.ml | 2 +- src/frontend/primitives_.cppo.ml | 75 +++------------------------- src/frontend/primitives_.mli | 4 +- 4 files changed, 11 insertions(+), 73 deletions(-) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 194bcf8c8..a3ece25af 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1549,7 +1549,8 @@ params: - txtwid : length - valuecmd code: | - Context(Primitives.get_initial_context txtwid, valuecmd) + let ctx = Primitives.get_pdf_mode_initial_context txtwid in + Context(ctx, valuecmd) --- inst: PrimitiveSetHyphenMin diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 9b79c21c7..5d569203b 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -160,7 +160,7 @@ let initialize (dump_file : file_path) = EvalVarID.initialize (); StoreID.initialize (); let dump_file_exists = CrossRef.initialize dump_file in - let (tyenv, env) = Primitives.make_environments () in + let (tyenv, env) = Primitives.make_pdf_mode_environments () in begin if OptionState.bytecomp_mode () then Bytecomp.compile_environment env diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 303ae6424..a7c7fd4da 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -138,7 +138,7 @@ let option_type = tOPT let itemize_type () = tITMZ () -let add_default_types (tyenvmid : Typeenv.t) : Typeenv.t = +let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = let dr = Range.dummy "add_default_types" in let bid = BoundID.fresh UniversalKind () in let typaram = (dr, TypeVariable(PolyBound(bid))) in @@ -267,69 +267,6 @@ let rec lambda5 astf env = let pdfpt = Length.of_pdf_point -(* -let default_math_left_paren hgt dpt hgtaxis fontsize color = - let open HorzBox in - let lenappend = fontsize *% 0.1 in - let minhalflen = fontsize *% 0.5 in - let halflen = Length.max minhalflen ((Length.max (hgt -% hgtaxis) (hgtaxis -% dpt)) +% lenappend) in - let widparen = halflen *% 0.375 in - let wid = widparen +% fontsize *% 0.1 in - let graphics (xpos, ypos) = - GraphicD.pdfops_of_stroke (pdfpt 0.5) color [ - GeneralPath((xpos +% wid, ypos +% hgtaxis +% halflen), [ - LineTo((xpos +% wid -% widparen, ypos +% hgtaxis)); - LineTo((xpos +% wid, ypos +% hgtaxis -% halflen)); - ], None); - ] - in - let kerninfo y = - let widkern = widparen in - let r = 0. in - let gap = Length.abs (y -% hgtaxis) in - let topdfpt = Length.to_pdf_point in (* for debug *) - let () = Printf.printf "Primitives> y = %f, hgtaxis = %f\n" (topdfpt y) (topdfpt hgtaxis) in (* for debug *) - if halflen *% r <% gap then - widkern *% ((gap -% halflen *% r) /% (halflen *% (1. -. r))) - else - Length.zero - in - let hgtparen = hgtaxis +% halflen in - let dptparen = hgtaxis -% halflen in - ([HorzPure(PHGFixedGraphics(wid, hgtparen, dptparen, graphics))], kerninfo) - - -let default_math_right_paren hgt dpt hgtaxis fontsize color = - let open HorzBox in - let lenappend = fontsize *% 0.1 in - let minhalflen = fontsize *% 0.5 in - let halflen = Length.max minhalflen ((Length.max (hgt -% hgtaxis) (hgtaxis -% dpt)) +% lenappend) in - let widparen = halflen *% 0.375 in - let wid = widparen +% fontsize *% 0.1 in - let graphics (xpos, ypos) = - GraphicD.pdfops_of_stroke (pdfpt 0.5) color [ - GeneralPath((xpos, ypos +% hgtaxis +% halflen), [ - LineTo((xpos +% widparen, ypos +% hgtaxis)); - LineTo((xpos, ypos +% hgtaxis -% halflen)); - ], None); - ] - in - let kerninfo y = - let widkern = widparen in - let r = 0. in - let gap = Length.abs (y -% hgtaxis) in - let topdfpt = Length.to_pdf_point in (* for debug *) - let () = Printf.printf "Primitives> y = %f, hgtaxis = %f\n" (topdfpt y) (topdfpt hgtaxis) in (* for debug *) - if halflen *% r <% gap then - widkern *% ((gap -% halflen *% r) /% (halflen *% (1. -. r))) - else - Length.zero - in - let hgtparen = hgtaxis +% halflen in - let dptparen = hgtaxis -% halflen in - ([HorzPure(PHGFixedGraphics(wid, hgtparen, dptparen, graphics))], kerninfo) -*) - let default_radical hgt_bar t_bar dpt fontsize color = let open HorzBox in let wM = fontsize *% 0.02 in @@ -505,7 +442,7 @@ let default_font_scheme_ref = ref CharBasis.ScriptSchemeMap.empty let default_hyphen_dictionary = ref LoadHyph.empty -let get_initial_context wid = +let get_pdf_mode_initial_context wid = let open HorzBox in { hyphen_dictionary = !default_hyphen_dictionary; @@ -546,13 +483,13 @@ let get_initial_context wid = } -let make_environments () = - let tyenvinit = add_default_types Typeenv.empty in +let make_pdf_mode_environments () = + let tyenvinit = add_pdf_mode_default_types Typeenv.empty in let envinit : environment = (EvalVarIDMap.empty, ref (StoreIDHashTable.create 128)) in - let (~@) n = (~! "tv", TypeVariable(n)) in + let (~@) n = (~! "tv", TypeVariable(n)) in let (-%) n ptysub = ptysub in - let (~%) ty = Poly(ty) in + let (~%) ty = Poly(ty) in let tv1 = (let bid1 = BoundID.fresh UniversalKind () in PolyBound(bid1)) in let tv2 = (let bid2 = BoundID.fresh UniversalKind () in PolyBound(bid2)) in diff --git a/src/frontend/primitives_.mli b/src/frontend/primitives_.mli index f11b6220d..b45ddcfd7 100644 --- a/src/frontend/primitives_.mli +++ b/src/frontend/primitives_.mli @@ -7,8 +7,8 @@ val option_type : ('a, 'b) typ -> ('a, 'b) typ val itemize_type : unit -> ('a, 'b) typ -val get_initial_context : length -> HorzBox.context_main +val get_pdf_mode_initial_context : length -> HorzBox.context_main -val make_environments : unit -> Typeenv.t * environment +val make_pdf_mode_environments : unit -> Typeenv.t * environment val default_radical : HorzBox.radical From b20bde20f3951f26020dc4db2aae8a697739b0b7 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 04:41:32 +0900 Subject: [PATCH 37/78] refactor 'primitives_.cppo.ml' for extending it --- src/frontend/primitives_.cppo.ml | 72 ++++++++++++++++++++++---------- src/frontend/primitives_.mli | 2 + 2 files changed, 52 insertions(+), 22 deletions(-) diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index a7c7fd4da..d597938b5 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -138,7 +138,7 @@ let option_type = tOPT let itemize_type () = tITMZ () -let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = +let add_general_default_types (tyenvmid : Typeenv.t) : Typeenv.t = let dr = Range.dummy "add_default_types" in let bid = BoundID.fresh UniversalKind () in let typaram = (dr, TypeVariable(PolyBound(bid))) in @@ -151,6 +151,10 @@ let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.register_type "itemize" tyid_itemize (Typeenv.Data(0)) |> Typeenv.Raw.add_constructor "Item" ([], Poly(tPROD [tIT; tL (tITMZ ())])) tyid_itemize + +let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = + + tyenvmid |> Typeenv.Raw.register_type "color" tyid_color (Typeenv.Data(0)) |> Typeenv.Raw.add_constructor "Gray" ([], Poly(tFL)) tyid_color |> Typeenv.Raw.add_constructor "RGB" ([], Poly(tPROD [tFL; tFL; tFL])) tyid_color @@ -483,37 +487,53 @@ let get_pdf_mode_initial_context wid = } -let make_pdf_mode_environments () = - let tyenvinit = add_pdf_mode_default_types Typeenv.empty in - let envinit : environment = (EvalVarIDMap.empty, ref (StoreIDHashTable.create 128)) in +let (~%) ty = Poly(ty) + +let general_table : (var_name * poly_type * (environment -> syntactic_value)) list = let (~@) n = (~! "tv", TypeVariable(n)) in let (-%) n ptysub = ptysub in - let (~%) ty = Poly(ty) in let tv1 = (let bid1 = BoundID.fresh UniversalKind () in PolyBound(bid1)) in let tv2 = (let bid2 = BoundID.fresh UniversalKind () in PolyBound(bid2)) in + let ptyderef = tv1 -% (~% ((tR (~@ tv1)) @-> (~@ tv1))) in + let ptycons = tv2 -% (~% ((~@ tv2) @-> (tL (~@ tv2)) @-> (tL (~@ tv2)))) in + let ptyappinv = tv1 -% (tv2 -% (~% ((~@ tv1) @-> ((~@ tv1) @-> (~@ tv2)) @-> (~@ tv2)))) in + [ + ( "!" , ptyderef , lambda1 (fun v1 -> Dereference(v1)) ); + ( "::" , ptycons , lambda2 (fun v1 v2 -> PrimitiveListCons(v1, v2)) ); + ( "|>" , ptyappinv , lambda2 (fun vx vf -> Apply(vf, vx)) ); + ( "<>" , ~% (tI @-> tI @-> tB), lambda2 (fun v1 v2 -> LogicalNot(EqualTo(v1, v2))) ); + ( ">=" , ~% (tI @-> tI @-> tB), lambda2 (fun v1 v2 -> LogicalNot(LessThan(v1, v2))) ); + ( "<=" , ~% (tI @-> tI @-> tB), lambda2 (fun v1 v2 -> LogicalNot(GreaterThan(v1, v2)))); + ] - let table : (var_name * poly_type * (environment -> syntactic_value)) list = - let ptyderef = tv1 -% (~% ((tR (~@ tv1)) @-> (~@ tv1))) in - let ptycons = tv2 -% (~% ((~@ tv2) @-> (tL (~@ tv2)) @-> (tL (~@ tv2)))) in - let ptyappinv = tv1 -% (tv2 -% (~% ((~@ tv1) @-> ((~@ tv1) @-> (~@ tv2)) @-> (~@ tv2)))) in - [ - ( "!" , ptyderef , lambda1 (fun v1 -> Dereference(v1))); - ( "::" , ptycons , lambda2 (fun v1 v2 -> PrimitiveListCons(v1, v2))); - ( "|>" , ptyappinv , lambda2 (fun vx vf -> Apply(vf, vx))); - ("inline-fil" , ~% tIB , (fun _ -> Horz(HorzBox.([HorzPure(PHSOuterFil)])))); - ("inline-nil" , ~% tIB , (fun _ -> Horz([]))); - ("block-nil" , ~% tBB , (fun _ -> Vert([]))); - ("clear-page" , ~% tBB , (fun _ -> Vert(HorzBox.([VertClearPage])))); - - ( "<>" , ~% (tI @-> tI @-> tB) , lambda2 (fun v1 v2 -> LogicalNot(EqualTo(v1, v2))) ); - ( ">=" , ~% (tI @-> tI @-> tB) , lambda2 (fun v1 v2 -> LogicalNot(LessThan(v1, v2))) ); - ( "<=" , ~% (tI @-> tI @-> tB) , lambda2 (fun v1 v2 -> LogicalNot(GreaterThan(v1, v2))) ); + +let pdf_mode_table = + List.append general_table + [ + ("inline-fil", ~% tIB, (fun _ -> Horz(HorzBox.([HorzPure(PHSOuterFil)])))); + ("inline-nil", ~% tIB, (fun _ -> Horz([])) ); + ("block-nil" , ~% tBB, (fun _ -> Vert([])) ); + ("clear-page", ~% tBB, (fun _ -> Vert(HorzBox.([VertClearPage]))) ); #include "__primitives.gen.ml" + ] - ] + +let text_mode_table = + List.append general_table + [] (* temporary *) + + +let make_environments table = + let tyenvinit = + Typeenv.empty + |> add_general_default_types + |> add_pdf_mode_default_types in + let envinit : environment = (EvalVarIDMap.empty, ref (StoreIDHashTable.create 128)) in + + let temporary_ast = StringEmpty in let (tyenvfinal, envfinal, locacc) = table |> List.fold_left (fun (tyenv, env, acc) (varnm, pty, deff) -> @@ -529,3 +549,11 @@ let make_pdf_mode_environments () = default_hyphen_dictionary := LoadHyph.main "english.satysfi-hyph"; (* temporary; should depend on the current language -- *) (tyenvfinal, envfinal) + + +let make_pdf_mode_environments () = + make_environments pdf_mode_table + + +let make_text_mode_environments () = + make_environments text_mode_table diff --git a/src/frontend/primitives_.mli b/src/frontend/primitives_.mli index b45ddcfd7..bbb9eddb4 100644 --- a/src/frontend/primitives_.mli +++ b/src/frontend/primitives_.mli @@ -11,4 +11,6 @@ val get_pdf_mode_initial_context : length -> HorzBox.context_main val make_pdf_mode_environments : unit -> Typeenv.t * environment +val make_text_mode_environments : unit -> Typeenv.t * environment + val default_radical : HorzBox.radical From 847a1171f6fbe4b9badb94e4c9bb2c714d298451 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 05:16:33 +0900 Subject: [PATCH 38/78] add 'textBackend.ml' --- src/dune | 1 + src/frontend/types_.cppo.ml | 10 ++----- src/text-mode/textBackend.ml | 58 ++++++++++++++++++++++++++++++++++++ 3 files changed, 61 insertions(+), 8 deletions(-) create mode 100644 src/text-mode/textBackend.ml diff --git a/src/dune b/src/dune index f13d2538b..a0ff33834 100644 --- a/src/dune +++ b/src/dune @@ -21,6 +21,7 @@ ;; dune requires all the .ml/.mli files to be in the same directory as the jbuild. ;; https://github.com/ocaml/dune/issues/109 (copy_files# backend/*.{ml,mli}) +(copy_files# text-mode/*.{ml,mli}) (copy_files# chardecoder/*.{ml,mli}) (copy_files chardecoder/*.{mll,mly}) (copy_files# frontend/*.{ml,mli}) diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index 39256a037..f77296ffb 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -698,6 +698,7 @@ and syntactic_value = | ImageKey of ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "")] | Context of input_context + | TextModeContext of TextBackend.text_mode_context | DocumentValue of HorzBox.page_size * HorzBox.page_content_scheme_func * HorzBox.page_parts_scheme_func * HorzBox.vert_box list and abstract_tree = @@ -804,14 +805,7 @@ and math = | MathUpperLimit of math list * math list | MathLowerLimit of math list * math list [@@deriving show { with_path = false; }] -(* -type output_unit = - | OString of string - | OBreakAndIndent - | OSoftBreakAndIndent - | ODeepen - | OShallow -*) + let get_range (rng, _) = rng diff --git a/src/text-mode/textBackend.ml b/src/text-mode/textBackend.ml new file mode 100644 index 000000000..e2b5d2f80 --- /dev/null +++ b/src/text-mode/textBackend.ml @@ -0,0 +1,58 @@ + +type text_mode_context = { + indent : int; + escape_list : (Uchar.t list * Uchar.t list) list; + [@printer (fun ppf _ -> Format.fprintf ppf "")] +} +[@@deriving show { with_path = false; }] + + +let get_initial_text_mode_context () = { + indent = 0; + escape_list = []; +} + + +let deepen_indent i tctx = + { tctx with indent = tctx.indent + (max i 0); } + + +let set_escape_list elst tctx = + { tctx with escape_list = elst; } + + +let rec prefix uchlst1 uchlst2 = + match (uchlst1, uchlst2) with + | ([], _) -> Some(uchlst2) + | (_, []) -> None + | (uch1 :: tl1, uch2 :: tl2) -> if Uchar.equal uch1 uch2 then prefix tl1 tl2 else None + + +let rec first_match uchlst elst = + match elst with + | [] -> + None + + | (ulfrom, ulto) :: etail -> + begin + match prefix ulfrom uchlst with + | None -> first_match uchlst etail + | Some(uchrest) -> Some((ulto, uchrest)) + end + + +let stringify uchlst tctx = + let elst = tctx.escape_list in + let rec aux acc uchlst = + match uchlst with + | [] -> + Alist.to_list acc + + | uchhead :: uchtail -> + begin + match first_match uchlst elst with + | Some((ulto, uchrest)) -> aux (Alist.append acc ulto) uchrest + | None -> aux (Alist.extend acc uchhead) uchtail + end + in + aux Alist.empty uchlst From 29bb51ee75efef15ab69d4bbee04714bf32a0976 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 05:35:27 +0900 Subject: [PATCH 39/78] develop 'TextBackend.stringify' --- src/text-mode/textBackend.ml | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/text-mode/textBackend.ml b/src/text-mode/textBackend.ml index e2b5d2f80..0127ffc6f 100644 --- a/src/text-mode/textBackend.ml +++ b/src/text-mode/textBackend.ml @@ -41,9 +41,25 @@ let rec first_match uchlst elst = end +let uchar_line_feed = Uchar.of_int 0x0A +let uchar_space = Uchar.of_int 0x20 + +let spaces i = + List.init i (fun _ -> uchar_space) + + +let insert_indent i uchlst = + uchlst |> List.fold_left (fun acc uch -> + if Uchar.equal uch uchar_line_feed then + Alist.append (Alist.extend acc uchar_line_feed) (spaces i) + else + Alist.extend acc uch + ) Alist.empty |> Alist.to_list + + let stringify uchlst tctx = let elst = tctx.escape_list in - let rec aux acc uchlst = + let rec escape acc uchlst = match uchlst with | [] -> Alist.to_list acc @@ -51,8 +67,9 @@ let stringify uchlst tctx = | uchhead :: uchtail -> begin match first_match uchlst elst with - | Some((ulto, uchrest)) -> aux (Alist.append acc ulto) uchrest - | None -> aux (Alist.extend acc uchhead) uchtail + | Some((ulto, uchrest)) -> escape (Alist.append acc ulto) uchrest + | None -> escape (Alist.extend acc uchhead) uchtail end in - aux Alist.empty uchlst + let uchlst = escape Alist.empty uchlst in + insert_indent tctx.indent uchlst From 824ecf548cf1c62d9c7c97ba5e990ccd1fc8165d Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 06:01:08 +0900 Subject: [PATCH 40/78] begin to separate PDF-generating mode and text-generating mode --- Makefile | 8 +- gen_code.rb | 25 +- src/dune | 2 +- src/frontend/bytecomp/vminstdef.yaml | 348 +++++++++++++++------------ src/frontend/primitives_.cppo.ml | 2 +- 5 files changed, 219 insertions(+), 166 deletions(-) diff --git a/Makefile b/Makefile index b634b914f..3063bae94 100644 --- a/Makefile +++ b/Makefile @@ -17,14 +17,14 @@ ATTYPE_GEN=$(FRONTEND)/__attype.gen.ml VM_GEN=$(BYTECOMP)/__vm.gen.ml IR_GEN=$(BYTECOMP)/__ir.gen.ml EVAL_GEN=$(FRONTEND)/__evaluator.gen.ml -PRIM_GEN=$(FRONTEND)/__primitives.gen.ml +PRIM_PDF_GEN=$(FRONTEND)/__primitives_pdf_mode.gen.ml GENS= \ $(INSTTYPE_GEN) \ $(ATTYPE_GEN) \ $(VM_GEN) \ $(IR_GEN) \ $(EVAL_GEN) \ - $(PRIM_GEN) + $(PRIM_PDF_GEN) .PHONY: all gen install lib uninstall clean @@ -49,8 +49,8 @@ $(IR_GEN): $(INSTDEF) $(GENCODE) $(EVAL_GEN): $(INSTDEF) $(GENCODE) $(RUBY) $(GENCODE) --gen-interps $(INSTDEF) > $@ -$(PRIM_GEN): $(INSTDEF) $(GENCODE) - $(RUBY) $(GENCODE) --gen-prims $(INSTDEF) > $@ +$(PRIM_PDF_GEN): $(INSTDEF) $(GENCODE) + $(RUBY) $(GENCODE) --gen-pdf-mode-prims $(INSTDEF) > $@ install: $(TARGET) mkdir -p $(BINDIR) diff --git a/gen_code.rb b/gen_code.rb index 5e9143d3a..e2b89fd7f 100644 --- a/gen_code.rb +++ b/gen_code.rb @@ -29,9 +29,9 @@ def default_false b if b == nil then false else b end end -def gen_prims +def gen_prims tag YAML.load_stream(ARGF.read) do |inst| - if inst["is-primitive"] && inst["name"] != nil then + if inst[tag] && inst["name"] != nil then len = inst["params"].length args = [] for i in 1..len @@ -52,9 +52,17 @@ def gen_prims end end +def gen_pdf_mode_prims + gen_prims("is-pdf-mode-primitive") +end + +def gen_text_mode_prims + gen_prims("is-text-mode-primitive") +end + def gen_interps YAML.load_stream(ARGF.read) do |inst| - if inst["is-primitive"] && !default_false(inst["no-interp"]) then + if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) && !default_false(inst["no-interp"]) then tmpn = 0 astargs = [] valueidents = [] @@ -141,7 +149,7 @@ def gen_vminstrs if inst["needs-reducef"] then puts " let reducef = exec_application #{ENVIRONMENT} in" end - if inst["is-primitive"] then + if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) then puts " let #{RET} =" else puts " begin" @@ -149,7 +157,7 @@ def gen_vminstrs inst["code"].each_line do |line| puts " #{line}" end - if inst["is-primitive"] then + if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) then puts " in #{VMEXEC} (#{RET} :: #{STACK}) #{ENVIRONMENT} #{CODE} #{DUMP}" else puts " end" @@ -179,7 +187,7 @@ def gen_insttype def gen_attype YAML.load_stream(ARGF.read) do |inst| - if inst["is-primitive"] && !default_false(inst["no-ircode"]) then + if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) && !default_false(inst["no-ircode"]) then if inst["params"] != nil then puts " | #{inst["inst"]} of #{(["abstract_tree"] * inst["params"].length).join ' * '}" else @@ -191,7 +199,7 @@ def gen_attype def gen_ircases YAML.load_stream(ARGF.read) do |inst| - if inst["is-primitive"] && !default_false(inst["no-ircode"]) then + if (inst["is-pdf-mode-primitive"] || inst["is-text-mode-primitive"]) && !default_false(inst["no-ircode"]) then params = [*1..inst["params"].length].collect{|n| "p"+n.to_s} puts " | #{inst["inst"]}(#{params.join ', '}) ->" @@ -210,7 +218,8 @@ def gen_ircases opt.on('--gen-insttype') {|v| func = method(:gen_insttype) } opt.on('--gen-attype') {|v| func = method(:gen_attype) } opt.on('--gen-interps') {|v| func = method(:gen_interps) } -opt.on('--gen-prims') {|v| func = method(:gen_prims) } +opt.on('--gen-pdf-mode-prims') {|v| func = method(:gen_pdf_mode_prims) } +opt.on('--gen-text-mode-prims') {|v| func = method(:gen_text_mode_prims) } opt.parse!(ARGV) diff --git a/src/dune b/src/dune index a0ff33834..a6724e771 100644 --- a/src/dune +++ b/src/dune @@ -57,5 +57,5 @@ (rule (targets primitives_.ml) - (deps (:src primitives_.cppo.ml) __primitives.gen.ml) + (deps (:src primitives_.cppo.ml) __primitives_pdf_mode.gen.ml) (action (run %{bin:cppo} %{src} -o %{targets}))) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index a3ece25af..f1819c478 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -22,23 +22,24 @@ # # To add a new primitive, # 1. Add a new instruction definition to this file. -# (`is-primitive` should be yes.) +# (`is-pdf-mode-primitive` or `is-text-mode-primitive` should be yes.) # 2. Add a new entry to primitives.ml. # # # inst: Instruction name (essential) -# is-primitive: Primitive or pure vm instruction (default: no) +# is-pdf-mode-primitive: Primitive for generating PDFs or not (default: no) +# is-text-mode-primitive: Primitive for generating texts or not (default: no) # needs-reducef: Use `reducef` for evaluating applications (default: no) # suppress-pp: Use a simple pritty printer (default: no) # custom-pp: Specify custom pritty printer # no-ircode: Suppress code generation for `ir_.ml` (default: no) -# no-interp: Suppress code generation for `evaluator_.ml` (default: !`is-primitive`) +# no-interp: Suppress code generation for `evaluator_.ml` (default: !`is-pdf-mode-primitive`) # name: Identifier for the primitive # type: Type expression for the primitive # fields: Field list (for `abstract_tree` type) # params: Paramater list # code: Instruction code -# (note: If `is-primitive` is yes, code that pushes to stack and +# (note: If `is-pdf-mode-primitive` or `is-text-mode-primitive` is yes, code that pushes to stack and # go to next instruction will be automatically inserted. # (see `gen_code.rb`)) # @@ -325,7 +326,7 @@ code: | --- inst: Dereference -is-primitive: yes +is-pdf-mode-primitive: yes no-interp: yes params: - valuecont @@ -616,7 +617,8 @@ code: | --- inst: Concat -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "^" type: | ~% (tS @-> tS @-> tS) @@ -633,7 +635,7 @@ code: | --- inst: PrimitiveSetMathVariantToChar -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-math-variant-char" type: | ~% (tMCCLS @-> tI @-> tI @-> tCTX @-> tCTX) @@ -653,7 +655,7 @@ code: | --- inst: PrimitiveConvertStringForMath -is-primitive: yes +is-pdf-mode-primitive: yes name: "convert-string-for-math" type: | ~% (tCTX @-> tMCCLS @-> tS @-> tS) @@ -669,7 +671,7 @@ code: --- inst: PrimitiveSetMathCommand -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-math-command" type: | ~% (tCMD @-> tCTX @-> tCTX) @@ -682,7 +684,7 @@ code: | --- inst: BackendMathVariantCharDirect -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-variant-char" type: | ~% (tMATHCLS @-> tMCSTY @-> tMATH) @@ -697,7 +699,7 @@ code: | --- inst: BackendGetLeftMathClass -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-left-math-class" type: | ~% (tCTX @-> tMATH @-> tOPT tMATHCLS) @@ -716,7 +718,7 @@ code: | --- inst: BackendGetRightMathClass -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-right-math-class" type: | ~% (tCTX @-> tMATH @-> tOPT tMATHCLS) @@ -735,7 +737,7 @@ code: | --- inst: BackendSpaceBetweenMaths -is-primitive: yes +is-pdf-mode-primitive: yes name: "space-between-maths" type: | ~% (tCTX @-> tMATH @-> tMATH @-> tOPT tIB) @@ -753,7 +755,7 @@ code: | --- inst: BackendMathConcat -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-concat" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -766,7 +768,7 @@ code: | --- inst: BackendMathGroup -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-group" type: | ~% (tMATHCLS @-> tMATHCLS @-> tMATH @-> tMATH) @@ -780,7 +782,7 @@ code: | --- inst: BackendMathSuperscript -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-sup" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -793,7 +795,7 @@ code: | --- inst: BackendMathSubscript -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-sub" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -806,7 +808,7 @@ code: | --- inst: BackendMathFraction -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-frac" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -819,7 +821,7 @@ code: | --- inst: BackendMathRadical -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-radical" type: | ~% (tOPT tMATH @-> tMATH @-> tMATH) @@ -836,7 +838,7 @@ code: | --- inst: BackendMathParen -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-paren" type: | ~% (tPAREN @-> tPAREN @-> tMATH @-> tMATH) @@ -853,7 +855,7 @@ code: | --- inst: BackendMathParenWithMiddle -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-paren-with-middle" type: | ~% (tPAREN @-> tPAREN @-> tPAREN @-> tL tMATH @-> tMATH) @@ -872,7 +874,7 @@ code: | --- inst: BackendMathUpperLimit -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-upper" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -885,7 +887,7 @@ code: | --- inst: BackendMathLowerLimit -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-lower" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -898,7 +900,7 @@ code: | --- inst: BackendMathPullInScripts -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-pull-in-scripts" type: | ~% (tMATHCLS @-> tMATHCLS @-> (tOPT tMATH @-> tOPT tMATH @-> tMATH) @-> tMATH) @@ -915,7 +917,7 @@ code: | --- inst: BackendMathChar -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-char" type: | ~% (tMATHCLS @-> tS @-> tMATH) @@ -929,7 +931,7 @@ code: | --- inst: BackendMathBigChar -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-big-char" type: | ~% (tMATHCLS @-> tS @-> tMATH) @@ -943,7 +945,7 @@ code: | --- inst: BackendMathCharWithKern -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-char-with-kern" type: | let mckf = tLN @-> tLN @-> tLN in @@ -963,7 +965,7 @@ code: | --- inst: BackendMathBigCharWithKern -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-big-char-with-kern" type: | let mckf = tLN @-> tLN @-> tLN in @@ -983,7 +985,7 @@ code: | --- inst: BackendMathText -is-primitive: yes +is-pdf-mode-primitive: yes name: "text-in-math" type: | ~% (tMATHCLS @-> (tCTX @-> tIB) @-> tMATH) @@ -1001,7 +1003,7 @@ code: | --- inst: BackendMathColor -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-color" type: | ~% (tCLR @-> tMATH @-> tMATH) @@ -1014,7 +1016,7 @@ code: | --- inst: BackendMathCharClass -is-primitive: yes +is-pdf-mode-primitive: yes name: "math-char-class" type: | ~% (tMCCLS @-> tMATH @-> tMATH) @@ -1044,7 +1046,7 @@ code: | --- inst: BackendEmbeddedMath -is-primitive: yes +is-pdf-mode-primitive: yes name: "embed-math" type: | ~% (tCTX @-> tMATH @-> tIB) @@ -1059,7 +1061,7 @@ code: | --- inst: BackendTabular -is-primitive: yes +is-pdf-mode-primitive: yes name: "tabular" type: | ~% ((tL (tL tCELL)) @-> tRULESF @-> tIB) @@ -1081,7 +1083,7 @@ code: | --- inst: BackendRegisterPdfImage -is-primitive: yes +is-pdf-mode-primitive: yes name: "load-pdf-image" type: | ~% (tS @-> tI @-> tIMG) @@ -1095,7 +1097,7 @@ code: | --- inst: BackendRegisterOtherImage -is-primitive: yes +is-pdf-mode-primitive: yes name: "load-image" type: | ~% (tS @-> tIMG) @@ -1108,7 +1110,7 @@ code: | --- inst: BackendUseImageByWidth -is-primitive: yes +is-pdf-mode-primitive: yes name: "use-image-by-width" type: | ~% (tIMG @-> tLN @-> tIB) @@ -1126,7 +1128,7 @@ code: | --- inst: BackendHookPageBreak -is-primitive: yes +is-pdf-mode-primitive: yes name: "hook-page-break" type: | ~% ((tPBINFO @-> tPT @-> tU) @-> tIB) @@ -1141,7 +1143,7 @@ code: | --- inst: Path suppress-pp : yes -is-primitive : yes +is-pdf-mode-primitive : yes separated: yes no-ircode: yes no-interp: yes @@ -1156,7 +1158,7 @@ code: | --- inst: PathUnite -is-primitive: yes +is-pdf-mode-primitive: yes name: "unite-path" type: | ~% (tPATH @-> tPATH @-> tPATH) @@ -1169,7 +1171,7 @@ code: | --- inst: PathShift -is-primitive: yes +is-pdf-mode-primitive: yes name: "shift-path" type: | ~% (tPT @-> tPATH @-> tPATH) @@ -1182,7 +1184,7 @@ code: | --- inst: PathGetBoundingBox -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-path-bbox" type: | ~% (tPATH @-> tPROD [tPT; tPT]) @@ -1197,7 +1199,7 @@ code: | --- inst: PrePathBeginning -is-primitive: yes +is-pdf-mode-primitive: yes name: "start-path" type: | ~% (tPT @-> tPRP) @@ -1209,7 +1211,7 @@ code: | --- inst: PrePathLineTo -is-primitive: yes +is-pdf-mode-primitive: yes name: "line-to" type: | ~% (tPT @-> tPRP @-> tPRP) @@ -1222,7 +1224,7 @@ code: | --- inst: PrePathCubicBezierTo -is-primitive: yes +is-pdf-mode-primitive: yes name: "bezier-to" type: | ~% (tPT @-> tPT @-> tPT @-> tPRP @-> tPRP) @@ -1237,7 +1239,7 @@ code: | --- inst: PrePathTerminate -is-primitive: yes +is-pdf-mode-primitive: yes name: "terminate-path" type: | ~% (tPRP @-> tPATH) @@ -1249,7 +1251,7 @@ code: | --- inst: PrePathCloseWithLine -is-primitive: yes +is-pdf-mode-primitive: yes name: "close-with-line" type: | ~% (tPRP @-> tPATH) @@ -1261,7 +1263,7 @@ code: | --- inst: PrePathCloseWithCubicBezier -is-primitive: yes +is-pdf-mode-primitive: yes name: "close-with-bezier" type: | ~% (tPT @-> tPT @-> tPRP @-> tPATH) @@ -1275,7 +1277,7 @@ code: | --- inst: HorzConcat -is-primitive: yes +is-pdf-mode-primitive: yes name: "++" type: | ~% (tIB @-> tIB @-> tIB) @@ -1288,7 +1290,7 @@ code: | --- inst: VertConcat -is-primitive: yes +is-pdf-mode-primitive: yes name: "+++" type: | ~% (tBB @-> tBB @-> tBB) @@ -1301,7 +1303,7 @@ code: | --- inst: HorzLex -is-primitive: yes +is-pdf-mode-primitive: yes name: "read-inline" type: | ~% (tCTX @-> tIT @-> tIB) @@ -1322,7 +1324,7 @@ code-interp: | --- inst: VertLex -is-primitive: yes +is-pdf-mode-primitive: yes name: "read-block" type: | ~% (tCTX @-> tBT @-> tBB) @@ -1343,7 +1345,7 @@ code-interp: | --- inst: PrimitiveEmbeddedVertBreakable -is-primitive: yes +is-pdf-mode-primitive: yes name: "embed-block-breakable" type: | ~% (tCTX @-> tBB @-> tIB) @@ -1357,7 +1359,7 @@ code: | --- inst: BackendFont -is-primitive: yes +is-pdf-mode-primitive: yes params: - abbrev : string - size_ratio : float @@ -1367,7 +1369,7 @@ code: | --- inst: BackendLineBreaking -is-primitive: yes +is-pdf-mode-primitive: yes name: "line-break" type: | ~% (tB @-> tB @-> tCTX @-> tIB @-> tBB) @@ -1383,7 +1385,7 @@ code: | --- inst: BackendPageBreaking -is-primitive: yes +is-pdf-mode-primitive: yes name: "page-break" type: | ~% (tPG @-> tPAGECONTF @-> tPAGEPARTSF @-> tBB @-> tDOC) @@ -1401,7 +1403,7 @@ code: | --- inst: BackendVertFrame -is-primitive: yes +is-pdf-mode-primitive: yes name: "block-frame-breakable" type: | ~% (tCTX @-> tPADS @-> tDECOSET @-> (tCTX @-> tBB) @-> tBB) @@ -1435,7 +1437,7 @@ code: | --- inst: BackendAddFootnote -is-primitive: yes +is-pdf-mode-primitive: yes name: "add-footnote" type: | ~% (tBB @-> tIB) @@ -1448,7 +1450,7 @@ code: | --- inst: BackendEmbeddedVertTop -is-primitive: yes +is-pdf-mode-primitive: yes name: "embed-block-top" type: | ~% (tCTX @-> tLN @-> (tCTX @-> tBB) @-> tIB) @@ -1472,7 +1474,7 @@ code: | --- inst: BackendVertSkip -is-primitive: yes +is-pdf-mode-primitive: yes name: "block-skip" type: | ~% (tLN @-> tBB) @@ -1484,7 +1486,7 @@ code: | --- inst: BackendEmbeddedVertBottom -is-primitive: yes +is-pdf-mode-primitive: yes name: "embed-block-bottom" type: | ~% (tCTX @-> tLN @-> (tCTX @-> tBB) @-> tIB) @@ -1508,7 +1510,7 @@ code: | --- inst: BackendLineStackTop -is-primitive: yes +is-pdf-mode-primitive: yes name: "line-stack-top" type: | ~% ((tL tIB) @-> tIB) @@ -1524,7 +1526,7 @@ code: | --- inst: BackendLineStackBottom -is-primitive: yes +is-pdf-mode-primitive: yes name: "line-stack-bottom" type: | ~% ((tL tIB) @-> tIB) @@ -1540,7 +1542,7 @@ code: | --- inst: PrimitiveGetInitialContext -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-initial-context" type: | ~% (tLN @-> tCMD @-> tCTX) @@ -1554,7 +1556,7 @@ code: | --- inst: PrimitiveSetHyphenMin -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-hyphen-min" type: | ~% (tI @-> tI @-> tCTX @-> tCTX) @@ -1571,7 +1573,7 @@ code: | --- inst: PrimitiveSetMinGapOfLines -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-min-gap-of-lines" type: | ~% (tLN @-> tCTX @-> tCTX) @@ -1586,7 +1588,7 @@ code: | --- inst: PrimitiveSetSpaceRatio -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-space-ratio" type: | ~% (tFL @-> tFL @-> tFL @-> tCTX @-> tCTX) @@ -1605,7 +1607,7 @@ code: | --- inst: PrimitiveSetParagraphMargin -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-paragraph-margin" type: | ~% (tLN @-> tLN @-> tCTX @-> tCTX) @@ -1622,7 +1624,7 @@ code: | --- inst: PrimitiveSetParagraphMinAscenderAndDescender -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-min-paragraph-ascender-and-descender" type: | ~% (tLN @-> tLN @-> tCTX @-> tCTX) @@ -1639,7 +1641,7 @@ code: | --- inst: PrimitiveSetFontSize -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-font-size" type: | ~% (tLN @-> tCTX @-> tCTX) @@ -1652,7 +1654,7 @@ code: | --- inst: PrimitiveGetFontSize -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-font-size" type: | ~% (tCTX @-> tLN) @@ -1664,7 +1666,7 @@ code: | --- inst: PrimitiveSetFont -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-font" type: | ~% (tSCR @-> tFONT @-> tCTX @-> tCTX) @@ -1679,7 +1681,7 @@ code: | --- inst: PrimitiveGetFont -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-font" type: | ~% (tSCR @-> tCTX @-> tFONT) @@ -1693,7 +1695,7 @@ code: | --- inst: PrimitiveSetMathFont -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-math-font" type: | ~% (tS @-> tCTX @-> tCTX) @@ -1706,7 +1708,7 @@ code: | --- inst: PrimitiveSetDominantWideScript -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-dominant-wide-script" type: | ~% (tSCR @-> tCTX @-> tCTX) @@ -1719,7 +1721,7 @@ code: | --- inst: PrimitiveGetDominantWideScript -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-dominant-wide-script" type: | ~% (tCTX @-> tSCR) @@ -1731,7 +1733,7 @@ code: | --- inst: PrimitiveSetDominantNarrowScript -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-dominant-narrow-script" type: | ~% (tSCR @-> tCTX @-> tCTX) @@ -1744,7 +1746,7 @@ code: | --- inst: PrimitiveGetDominantNarrowScript -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-dominant-narrow-script" type: | ~% (tCTX @-> tSCR) @@ -1756,7 +1758,7 @@ code: | --- inst: PrimitiveSetLangSys -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-language" type: | ~% (tSCR @-> tLANG @-> tCTX @-> tCTX) @@ -1772,7 +1774,7 @@ code: | --- inst: PrimitiveGetLangSys -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-language" type: | ~% (tSCR @-> tCTX @-> tLANG) @@ -1786,7 +1788,7 @@ code: | --- inst: PrimitiveSetTextColor -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-text-color" type: | ~% (tCLR @-> tCTX @-> tCTX) @@ -1799,7 +1801,7 @@ code: | --- inst: PrimitiveGetTextColor -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-text-color" type: | ~% (tCTX @-> tCLR) @@ -1812,7 +1814,7 @@ code: | --- inst: PrimitiveSetLeading -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-leading" type: | ~% (tLN @-> tCTX @-> tCTX) @@ -1825,7 +1827,7 @@ code: | --- inst: PrimitiveGetTextWidth -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-text-width" type: | ~% (tCTX @-> tLN) @@ -1837,7 +1839,7 @@ code: | --- inst: PrimitiveSetManualRising -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-manual-rising" type: | ~% (tLN @-> tCTX @-> tCTX) @@ -1850,7 +1852,7 @@ code: | --- inst: PrimitiveRaise -is-primitive: yes +is-pdf-mode-primitive: yes name: "raise-inline" type: | ~% (tLN @-> tIB @-> tIB) @@ -1863,7 +1865,7 @@ code: | --- inst: PrimitiveSetHyphenPenalty -is-primitive: yes +is-pdf-mode-primitive: yes name: "set-hyphen-penalty" type: | ~% (tI @-> tCTX @-> tCTX) @@ -1876,7 +1878,8 @@ code: | --- inst: PrimitiveEmbed -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "embed-string" type: | ~% (tS @-> tIT) @@ -1892,7 +1895,7 @@ code-interp: | --- inst: PrimitiveGetAxisHeight -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-axis-height" type: | ~% (tCTX @-> tLN) @@ -1907,7 +1910,7 @@ code: | --- inst: BackendFixedEmpty -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-skip" type: | ~% (tLN @-> tIB) @@ -1919,7 +1922,7 @@ code: | --- inst: BackendOuterEmpty -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-glue" type: | ~% (tLN @-> tLN @-> tLN @-> tIB) @@ -1933,7 +1936,7 @@ code: | --- inst: BackendOuterFrame -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-frame-outer" type: | ~% (tPADS @-> tDECO @-> tIB @-> tIB) @@ -1951,7 +1954,7 @@ code: | --- inst: BackendInnerFrame -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-frame-inner" type: | ~% (tPADS @-> tDECO @-> tIB @-> tIB) @@ -1969,7 +1972,7 @@ code: | --- inst: BackendFixedFrame -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-frame-fixed" type: | ~% (tLN @-> tPADS @-> tDECO @-> tIB @-> tIB) @@ -1988,7 +1991,7 @@ code: | --- inst: BackendOuterFrameBreakable -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-frame-breakable" type: | ~% (tPADS @-> tDECOSET @-> tIB @-> tIB) @@ -2010,7 +2013,7 @@ code: | --- inst: BackendInlineGraphics -is-primitive: yes +is-pdf-mode-primitive: yes name: "inline-graphics" type: | ~% (tLN @-> tLN @-> tLN @-> tIGR @-> tIB) @@ -2027,7 +2030,7 @@ code: | --- inst: BackendScriptGuard -is-primitive: yes +is-pdf-mode-primitive: yes name: "script-guard" type: | ~% (tSCR @-> tIB @-> tIB) @@ -2040,7 +2043,7 @@ code: | --- inst: BackendDiscretionary -is-primitive: yes +is-pdf-mode-primitive: yes name: "discretionary" type: | ~% (tI @-> tIB @-> tIB @-> tIB @-> tIB) @@ -2055,7 +2058,8 @@ code: | --- inst: BackendRegisterCrossReference -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "register-cross-reference" type: | ~% (tS @-> tS @-> tU) @@ -2069,7 +2073,8 @@ code: | --- inst: BackendGetCrossReference -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "get-cross-reference" type: | ~% (tS @-> (tOPT tS)) @@ -2083,7 +2088,7 @@ code: | --- inst: PrimitiveGetNaturalMetrics -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-natural-metrics" type: | ~% (tIB @-> tPROD [tLN; tLN; tLN]) @@ -2098,7 +2103,7 @@ code: | --- inst: PrimitiveGetNaturalLength -is-primitive: yes +is-pdf-mode-primitive: yes name: "get-natural-length" type: | ~% (tBB @-> tLN) @@ -2112,7 +2117,8 @@ code: | --- inst: PrimitiveDisplayMessage -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "display-message" type: | ~% (tS @-> tU) @@ -2125,7 +2131,8 @@ code: | --- inst: PrimitiveListCons -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes params: - valuehd - valuetl @@ -2134,7 +2141,8 @@ code: | --- inst: PrimitiveSame -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-same" type: | ~% (tS @-> tS @-> tB) @@ -2147,7 +2155,8 @@ code: | --- inst: PrimitiveStringSub -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-sub" type: | ~% (tS @-> tI @-> tI @-> tS) @@ -2165,7 +2174,8 @@ code: | --- inst: PrimitiveStringSubBytes -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-sub-bytes" type: | ~% (tS @-> tI @-> tI @-> tS) @@ -2183,7 +2193,8 @@ code: | --- inst: PrimitiveStringLength -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-length" type: | ~% (tS @-> tI) @@ -2195,7 +2206,8 @@ code: | --- inst: PrimitiveStringByteLength -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-byte-length" type: | ~% (tS @-> tI) @@ -2207,7 +2219,8 @@ code: | --- inst: PrimitiveStringUnexplode -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-unexplode" type: | ~% ((tL tI) @-> tS) @@ -2221,7 +2234,8 @@ code: | --- inst: PrimitiveRegExpOfString -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "regexp-of-string" type: | ~% (tS @-> tRE) @@ -2237,7 +2251,8 @@ code: | --- inst: PrimitiveStringMatch -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "string-match" type: | ~% (tRE @-> tS @-> tB) @@ -2250,7 +2265,8 @@ code: | --- inst: PrimitiveSplitIntoLines -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "split-into-lines" type: | ~% (tS @-> (tL (tPROD [tI; tS]))) @@ -2265,7 +2281,8 @@ code: | --- inst: PrimitiveSplitOnRegExp -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "split-on-regexp" type: | ~% (tRE @-> tS @-> (tL (tPROD [tI; tS]))) @@ -2281,7 +2298,8 @@ code: | --- inst: PrimitiveArabic -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "arabic" type: | ~% (tI @-> tS) @@ -2293,7 +2311,8 @@ code: | --- inst: PrimitiveFloat -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "float" type: | ~% (tI @-> tFL) @@ -2305,7 +2324,8 @@ code: | --- inst: PrimitiveRound -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "round" type: | ~% (tFL @-> tI) @@ -2317,7 +2337,7 @@ code: | --- inst: PrimitiveDrawText -is-primitive: yes +is-pdf-mode-primitive: yes name: "draw-text" type: | ~% (tPT @-> tIB @-> tGR) @@ -2332,7 +2352,7 @@ code: | --- inst: PrimitiveDrawStroke -is-primitive: yes +is-pdf-mode-primitive: yes name: "stroke" type: | ~% (tLN @-> tCLR @-> tPATH @-> tGR) @@ -2347,7 +2367,7 @@ code: | --- inst: PrimitiveDrawFill -is-primitive: yes +is-pdf-mode-primitive: yes name: "fill" type: | ~% (tCLR @-> tPATH @-> tGR) @@ -2361,7 +2381,7 @@ code: | --- inst: PrimitiveDrawDashedStroke -is-primitive: yes +is-pdf-mode-primitive: yes name: "dashed-stroke" type: | ~% (tLN @-> tDASH @-> tCLR @-> tPATH @-> tGR) @@ -2378,7 +2398,7 @@ code: | --- inst: PrimitiveShiftGraphics -is-primitive: yes +is-pdf-mode-primitive: yes name: "shift-graphics" type: | ~% (tPT @-> tGR @-> tGR) @@ -2391,7 +2411,7 @@ code: | --- inst: PrimtiveGetGraphicsBBox -is-primitive: yes +is-pdf-mode-primitive: yes name: get-graphics-bbox type: | ~% (tGR @-> tPROD [tPT; tPT]) @@ -2411,7 +2431,8 @@ code: | --- inst: Times -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "*" type: | ~% (tI @-> tI @-> tI) @@ -2424,7 +2445,8 @@ code: | --- inst: Divides -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "/" type: | ~% (tI @-> tI @-> tI) @@ -2438,7 +2460,8 @@ code: | --- inst: Mod -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "mod" type: | ~% (tI @-> tI @-> tI) @@ -2452,7 +2475,8 @@ code: | --- inst: Plus -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "+" type: | ~% (tI @-> tI @-> tI) @@ -2465,7 +2489,8 @@ code: | --- inst: Minus -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "-" type: | ~% (tI @-> tI @-> tI) @@ -2478,7 +2503,8 @@ code: | --- inst: EqualTo -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "==" type: | ~% (tI @-> tI @-> tB) @@ -2491,7 +2517,8 @@ code: | --- inst: GreaterThan -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: ">" type: | ~% (tI @-> tI @-> tB) @@ -2504,7 +2531,8 @@ code: | --- inst: LessThan -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "<" type: | ~% (tI @-> tI @-> tB) @@ -2517,7 +2545,8 @@ code: | --- inst: LogicalAnd -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "&&" type: | ~% (tB @-> tB @-> tB) @@ -2530,7 +2559,8 @@ code: | --- inst: LogicalOr -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "||" type: | ~% (tB @-> tB @-> tB) @@ -2543,7 +2573,8 @@ code: | --- inst: LogicalNot -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "not" type: | ~% (tB @-> tB) @@ -2555,7 +2586,8 @@ code: | --- inst: FloatPlus -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "+." type: | ~% (tFL @-> tFL @-> tFL) @@ -2568,7 +2600,8 @@ code: | --- inst: FloatMinus -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "-." type: | ~% (tFL @-> tFL @-> tFL) @@ -2581,7 +2614,8 @@ code: | --- inst: FloatTimes -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "*." type: | ~% (tFL @-> tFL @-> tFL) @@ -2594,7 +2628,8 @@ code: | --- inst: FloatDivides -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "/." type: | ~% (tFL @-> tFL @-> tFL) @@ -2607,7 +2642,8 @@ code: | --- inst: FloatSine -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "sin" type: | ~% (tFL @-> tFL) @@ -2619,7 +2655,8 @@ code: | --- inst: FloatArcSine -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "asin" type: | ~% (tFL @-> tFL) @@ -2631,7 +2668,8 @@ code: | --- inst: FloatCosine -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "cos" type: | ~% (tFL @-> tFL) @@ -2643,7 +2681,8 @@ code: | --- inst: FloatArcCosine -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "acos" type: | ~% (tFL @-> tFL) @@ -2655,7 +2694,8 @@ code: | --- inst: FloatTangent -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "tan" type: | ~% (tFL @-> tFL) @@ -2667,7 +2707,8 @@ code: | --- inst: FloatArcTangent -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "atan" type: | ~% (tFL @-> tFL) @@ -2679,7 +2720,8 @@ code: | --- inst: FloatArcTangent2 -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "atan2" type: | ~% (tFL @-> tFL @-> tFL) @@ -2692,7 +2734,7 @@ code: | --- inst: LengthPlus -is-primitive: yes +is-pdf-mode-primitive: yes name: "+'" type: | ~% (tLN @-> tLN @-> tLN) @@ -2705,7 +2747,7 @@ code: | --- inst: LengthMinus -is-primitive: yes +is-pdf-mode-primitive: yes name: "-'" type: | ~% (tLN @-> tLN @-> tLN) @@ -2718,7 +2760,7 @@ code: | --- inst: LengthTimes -is-primitive: yes +is-pdf-mode-primitive: yes name: "*'" type: | ~% (tLN @-> tFL @-> tLN) @@ -2731,7 +2773,7 @@ code: | --- inst: LengthDivides -is-primitive: yes +is-pdf-mode-primitive: yes name: "/'" type: | ~% (tLN @-> tLN @-> tFL) @@ -2744,7 +2786,8 @@ code: | --- inst: LengthLessThan -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "<'" type: | ~% (tLN @-> tLN @-> tB) @@ -2757,7 +2800,8 @@ code: | --- inst: LengthGreaterThan -is-primitive: yes +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: ">'" type: | ~% (tLN @-> tLN @-> tB) @@ -2779,7 +2823,7 @@ code : | --- inst: PrimitiveSetEveryWordBreak -is-primitive : yes +is-pdf-mode-primitive : yes name: "set-every-word-break" type: | ~% (tIB @-> tIB @-> tCTX @-> tCTX) @@ -2796,7 +2840,7 @@ code: | --- inst: BackendProbeCrossReference -is-primitive : yes +is-pdf-mode-primitive : yes name: "probe-cross-reference" type: | ~% (tS @-> (tOPT tS)) diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index d597938b5..fe7c8e793 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -516,7 +516,7 @@ let pdf_mode_table = ("block-nil" , ~% tBB, (fun _ -> Vert([])) ); ("clear-page", ~% tBB, (fun _ -> Vert(HorzBox.([VertClearPage]))) ); -#include "__primitives.gen.ml" +#include "__primitives_pdf_mode.gen.ml" ] From f7109302ce5494b0e832290c11ac8124243f8914 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 06:48:36 +0900 Subject: [PATCH 41/78] introduce 'stringify-inline' and 'stringify-block' (which do not support math) --- Makefile | 7 ++- src/dune | 2 +- src/frontend/bytecomp/vm_.cppo.ml | 81 +++++++++++++++++++++++++++- src/frontend/bytecomp/vminstdef.yaml | 49 +++++++++++++++-- src/frontend/display.ml | 1 + src/frontend/evalUtil.ml | 6 +++ src/frontend/evaluator_.cppo.ml | 81 +++++++++++++++++++++++++++- src/frontend/evaluator_.mli | 3 +- src/frontend/primitives_.cppo.ml | 5 +- src/frontend/types_.cppo.ml | 3 ++ 10 files changed, 225 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index 3063bae94..410e9f354 100644 --- a/Makefile +++ b/Makefile @@ -18,13 +18,15 @@ VM_GEN=$(BYTECOMP)/__vm.gen.ml IR_GEN=$(BYTECOMP)/__ir.gen.ml EVAL_GEN=$(FRONTEND)/__evaluator.gen.ml PRIM_PDF_GEN=$(FRONTEND)/__primitives_pdf_mode.gen.ml +PRIM_TEXT_GEN=$(FRONTEND)/__primitives_text_mode.gen.ml GENS= \ $(INSTTYPE_GEN) \ $(ATTYPE_GEN) \ $(VM_GEN) \ $(IR_GEN) \ $(EVAL_GEN) \ - $(PRIM_PDF_GEN) + $(PRIM_PDF_GEN) \ + $(PRIM_TEXT_GEN) .PHONY: all gen install lib uninstall clean @@ -52,6 +54,9 @@ $(EVAL_GEN): $(INSTDEF) $(GENCODE) $(PRIM_PDF_GEN): $(INSTDEF) $(GENCODE) $(RUBY) $(GENCODE) --gen-pdf-mode-prims $(INSTDEF) > $@ +$(PRIM_TEXT_GEN): $(INSTDEF) $(GENCODE) + $(RUBY) $(GENCODE) --gen-pdf-mode-prims $(INSTDEF) > $@ + install: $(TARGET) mkdir -p $(BINDIR) install $(TARGET) $(BINDIR) diff --git a/src/dune b/src/dune index a6724e771..b1134bf7e 100644 --- a/src/dune +++ b/src/dune @@ -57,5 +57,5 @@ (rule (targets primitives_.ml) - (deps (:src primitives_.cppo.ml) __primitives_pdf_mode.gen.ml) + (deps (:src primitives_.cppo.ml) __primitives_pdf_mode.gen.ml __primitives_text_mode.gen.ml) (action (run %{bin:cppo} %{src} -o %{targets}))) diff --git a/src/frontend/bytecomp/vm_.cppo.ml b/src/frontend/bytecomp/vm_.cppo.ml index 01f6845de..2632ad3af 100644 --- a/src/frontend/bytecomp/vm_.cppo.ml +++ b/src/frontend/bytecomp/vm_.cppo.ml @@ -149,7 +149,84 @@ and exec_input_vert_content env ivlst = CompiledInputVertWithEnvironment(imivlst, env) -and exec_intermediate_input_vert (env : vmenv) (valuectx : syntactic_value) (imivlst : compiled_intermediate_input_vert_element list) : syntactic_value = +and exec_text_mode_intermediate_input_vert (env : vmenv) (valuetctx : syntactic_value) (imivlst : compiled_intermediate_input_vert_element list) : syntactic_value = + let rec interpret_commands env imivlst = + imivlst |> List.map (fun imiv -> + match imiv with + | CompiledImInputVertEmbedded(code) -> + let valueret = exec [valuetctx] env (List.append code [OpApplyT(1)]) [] in + get_string valueret + + | CompiledImInputVertContent(imivlstsub, envsub) -> + interpret_commands envsub imivlstsub + + ) |> String.concat "" + in + let s = interpret_commands env imivlst in + StringConstant(s) + + +and exec_text_mode_intermediate_input_horz (env : vmenv) (valuetctx : syntactic_value) (imihlst : compiled_intermediate_input_horz_element list) : syntactic_value = + let tctx = get_text_mode_context valuetctx in + begin + let rec normalize imihlst = + imihlst |> List.fold_left (fun acc imih -> + match imih with + | CompiledImInputHorzEmbedded(code) -> + let nmih = CompiledNomInputHorzEmbedded(code) in + Alist.extend acc nmih + + | CompiledImInputHorzText(s2) -> + begin + match Alist.chop_last acc with + | Some(accrest, CompiledNomInputHorzText(s1)) -> (Alist.extend accrest (CompiledNomInputHorzText(s1 ^ s2))) + | _ -> (Alist.extend acc (CompiledNomInputHorzText(s2))) + end + + | CompiledImInputHorzEmbeddedMath(mathcode) -> + failwith "Vm_> math; remains to be supported." +(* + let nmih = CompiledNomInputHorzThunk(List.append mathcode [OpPush(valuetctx); OpForward(1); OpPush(valuemcmd); OpApplyT(2)]) in + Alist.extend acc nmih +*) + + | CompiledImInputHorzContent(imihlst, envsub) -> + let nmihlstsub = normalize imihlst in + let nmih = CompiledNomInputHorzContent(nmihlstsub, envsub) in + Alist.extend acc nmih + + ) Alist.empty |> Alist.to_list + in + + let rec interpret_commands (env : vmenv) (nmihlst : compiled_nom_input_horz_element list) : string = + nmihlst |> List.map (fun nmih -> + match nmih with + | CompiledNomInputHorzEmbedded(code) -> + let valueret = exec [valuetctx] env (List.append code [OpApplyT(1)]) [] in + get_string valueret + + | CompiledNomInputHorzThunk(code) -> + let valueret = exec [] env code [] in + get_string valueret + + | CompiledNomInputHorzText(s) -> + let uchlst = InternalText.to_uchar_list (InternalText.of_utf8 s) in + let uchlstret = TextBackend.stringify uchlst tctx in + InternalText.to_utf8 (InternalText.of_uchar_list uchlstret) + + | CompiledNomInputHorzContent(nmihlstsub, envsub) -> + interpret_commands envsub nmihlstsub + + ) |> String.concat "" + in + + let nmihlst = normalize imihlst in + let s = interpret_commands env nmihlst in + StringConstant(s) + end + + +and exec_pdf_mode_intermediate_input_vert (env : vmenv) (valuectx : syntactic_value) (imivlst : compiled_intermediate_input_vert_element list) : syntactic_value = let rec interpret_commands env imivlst = imivlst |> List.map (fun imiv -> match imiv with @@ -166,7 +243,7 @@ and exec_intermediate_input_vert (env : vmenv) (valuectx : syntactic_value) (imi Vert(imvblst) -and exec_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imihlst : compiled_intermediate_input_horz_element list) : syntactic_value = +and exec_pdf_mode_intermediate_input_horz (env : vmenv) (valuectx : syntactic_value) (imihlst : compiled_intermediate_input_horz_element list) : syntactic_value = let (ctx, valuemcmd) = get_context valuectx in begin let rec normalize imihlst = diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index f1819c478..4deba5b82 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1314,12 +1314,12 @@ params: - value1 code: | match value1 with - | CompiledInputHorzWithEnvironment(imihlst, envi) -> exec_intermediate_input_horz envi valuectx imihlst + | CompiledInputHorzWithEnvironment(imihlst, envi) -> exec_pdf_mode_intermediate_input_horz envi valuectx imihlst | _ -> report_bug_vm "HorzLex" code-interp: | match value1 with - | InputHorzWithEnvironment(imihlst, envi) -> interpret_intermediate_input_horz envi valuectx imihlst + | InputHorzWithEnvironment(imihlst, envi) -> interpret_pdf_mode_intermediate_input_horz envi valuectx imihlst | _ -> report_bug_value "HorzLex" value1 --- @@ -1335,14 +1335,55 @@ params: - value1 code: | match value1 with - | CompiledInputVertWithEnvironment(imivlst, envi) -> exec_intermediate_input_vert envi valuectx imivlst + | CompiledInputVertWithEnvironment(imivlst, envi) -> exec_pdf_mode_intermediate_input_vert envi valuectx imivlst | _ -> report_bug_vm "VertLex" code-interp: | match value1 with - | InputVertWithEnvironment(imivlst, envi) -> interpret_intermediate_input_vert envi valuectx imivlst + | InputVertWithEnvironment(imivlst, envi) -> interpret_pdf_mode_intermediate_input_vert envi valuectx imivlst | _ -> report_bug_value "VertLex" value1 +inst: TextHorzLex +is-text-mode-primitive: yes +name: "stringify-inline" +type: | + ~% (tTCTX @-> tIT @-> tS) + +separated: yes +params: +- valuetctx +- value1 +code: | + match value1 with + | CompiledInputHorzWithEnvironment(imihlst, envi) -> exec_text_mode_intermediate_input_horz envi valuetctx imihlst + | _ -> report_bug_vm "TextHorzLex" + +code-interp: | + match value1 with + | InputHorzWithEnvironment(imihlst, envi) -> interpret_text_mode_intermediate_input_horz envi valuetctx imihlst + | _ -> report_bug_value "TextHorzLex" value1 + +--- +inst: TextVertLex +is-text-mode-primitive: yes +name: "stringify-block" +type: | + ~% (tTCTX @-> tBT @-> ts) + +separated: yes +params: +- valuetctx +- value1 +code: | + match value1 with + | CompiledInputVertWithEnvironment(imivlst, envi) -> exec_text_mode_intermediate_input_vert envi valuetctx imivlst + | _ -> report_bug_vm "TextVertLex" + +code-interp: | + match value1 with + | InputVertWithEnvironment(imivlst, envi) -> interpret_text_mode_intermediate_input_vert envi valuetctx imivlst + | _ -> report_bug_value "TextVertLex" value1 + --- inst: PrimitiveEmbeddedVertBreakable is-pdf-mode-primitive: yes diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 71be5ebc4..51e3dc38d 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -142,6 +142,7 @@ let rec string_of_mono_type_sub (tvf : paren_level -> 'a -> string) ortvf (tyenv | BaseType(DocumentType) -> "document" | BaseType(MathType) -> "math" | BaseType(RegExpType) -> "regexp" + | BaseType(TextInfoType) -> "text-info" | VariantType(tyarglist, tyid) -> let s = (iter_args tyarglist) ^ (Typeenv.find_type_name tyenv tyid) in diff --git a/src/frontend/evalUtil.ml b/src/frontend/evalUtil.ml index f1cff176a..52b34cb9f 100644 --- a/src/frontend/evalUtil.ml +++ b/src/frontend/evalUtil.ml @@ -350,6 +350,12 @@ let get_context (value : syntactic_value) : input_context = | _ -> report_bug_value "get_context" value +let get_text_mode_context (value : syntactic_value) : TextBackend.text_mode_context = + match value with + | TextModeContext(tctx) -> tctx + | _ -> report_bug_value "get_text_mode_context" value + + let get_length (value : syntactic_value) : length = match value with | LengthConstant(len) -> len diff --git a/src/frontend/evaluator_.cppo.ml b/src/frontend/evaluator_.cppo.ml index 69a110ef3..3980f4b79 100644 --- a/src/frontend/evaluator_.cppo.ml +++ b/src/frontend/evaluator_.cppo.ml @@ -324,7 +324,84 @@ and interpret env ast = #include "__evaluator.gen.ml" -and interpret_intermediate_input_vert env (valuectx : syntactic_value) (imivlst : intermediate_input_vert_element list) : syntactic_value = +and interpret_text_mode_intermediate_input_vert env (valuetctx : syntactic_value) (imivlst : intermediate_input_vert_element list) : syntactic_value = + let rec interpret_commands env (imivlst : intermediate_input_vert_element list) = + imivlst |> List.map (fun imiv -> + match imiv with + | ImInputVertEmbedded(astabs) -> + let valuevert = interpret env (Apply(astabs, Value(valuetctx))) in + get_string valuevert + + | ImInputVertContent(imivlstsub, envsub) -> + interpret_commands envsub imivlstsub + + ) |> String.concat "" + in + let s = interpret_commands env imivlst in + StringConstant(s) + + +and interpret_text_mode_intermediate_input_horz (env : environment) (valuetctx : syntactic_value) (imihlst : intermediate_input_horz_element list) : syntactic_value = + + let tctx = get_text_mode_context valuetctx in + + let rec normalize (imihlst : intermediate_input_horz_element list) = + imihlst |> List.fold_left (fun acc imih -> + match imih with + | ImInputHorzEmbedded(astabs) -> + let nmih = NomInputHorzEmbedded(astabs) in + Alist.extend acc nmih + + | ImInputHorzText(s2) -> + begin + match Alist.chop_last acc with + | Some(accrest, NomInputHorzText(s1)) -> (Alist.extend accrest (NomInputHorzText(s1 ^ s2))) + | _ -> (Alist.extend acc (NomInputHorzText(s2))) + end + + | ImInputHorzEmbeddedMath(astmath) -> + failwith "Evaluator_> math; remains to be supported." +(* + let nmih = NomInputHorzThunk(Apply(Apply(Value(valuemcmd), Value(valuectx)), astmath)) in + Alist.extend acc nmih +*) + + | ImInputHorzContent(imihlstsub, envsub) -> + let nmihlstsub = normalize imihlstsub in + let nmih = NomInputHorzContent(nmihlstsub, envsub) in + Alist.extend acc nmih + + ) Alist.empty |> Alist.to_list + in + + let rec interpret_commands env (nmihlst : nom_input_horz_element list) : string = + nmihlst |> List.map (fun nmih -> + match nmih with + | NomInputHorzEmbedded(astabs) -> + let valueret = interpret env (Apply(astabs, Value(valuetctx))) in + get_string valueret + + | NomInputHorzThunk(ast) -> + let valueret = interpret env ast in + get_string valueret + + | NomInputHorzText(s) -> + let uchlst = InternalText.to_uchar_list (InternalText.of_utf8 s) in + let uchlstret = tctx |> TextBackend.stringify uchlst in + InternalText.to_utf8 (InternalText.of_uchar_list uchlstret) + + | NomInputHorzContent(nmihlstsub, envsub) -> + interpret_commands envsub nmihlstsub + + ) |> String.concat "" + in + + let nmihlst = normalize imihlst in + let s = interpret_commands env nmihlst in + StringConstant(s) + + +and interpret_pdf_mode_intermediate_input_vert env (valuectx : syntactic_value) (imivlst : intermediate_input_vert_element list) : syntactic_value = let rec interpret_commands env (imivlst : intermediate_input_vert_element list) = imivlst |> List.map (fun imiv -> match imiv with @@ -341,7 +418,7 @@ and interpret_intermediate_input_vert env (valuectx : syntactic_value) (imivlst Vert(imvblst) -and interpret_intermediate_input_horz (env : environment) (valuectx : syntactic_value) (imihlst : intermediate_input_horz_element list) : syntactic_value = +and interpret_pdf_mode_intermediate_input_horz (env : environment) (valuectx : syntactic_value) (imihlst : intermediate_input_horz_element list) : syntactic_value = let (ctx, valuemcmd) = get_context valuectx in diff --git a/src/frontend/evaluator_.mli b/src/frontend/evaluator_.mli index 049129af1..dcc69ff90 100644 --- a/src/frontend/evaluator_.mli +++ b/src/frontend/evaluator_.mli @@ -7,5 +7,4 @@ val interpret : environment -> abstract_tree -> syntactic_value val select_pattern : Range.t -> environment -> syntactic_value -> pattern_branch list -> syntactic_value - -val interpret_intermediate_input_horz : environment -> syntactic_value -> intermediate_input_horz_element list -> syntactic_value +val interpret_pdf_mode_intermediate_input_horz : environment -> syntactic_value -> intermediate_input_horz_element list -> syntactic_value diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index fe7c8e793..15e17ef3b 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -37,6 +37,7 @@ let tIB = (~! "iboxes" , BaseType(BoxRowType) ) let tBB = (~! "bboxes" , BaseType(BoxColType) ) let tCTX = (~! "context" , BaseType(ContextType) ) +let tTCTX = (~! "text-info", BaseType(TextInfoType)) let tPATH = (~! "path" , BaseType(PathType) ) let tPRP = (~! "pre-path", BaseType(PrePathType) ) let tDOC = (~! "document", BaseType(DocumentType)) @@ -522,7 +523,9 @@ let pdf_mode_table = let text_mode_table = List.append general_table - [] (* temporary *) + [ +#include "__primitives_text_mode.gen.ml" + ] let make_environments table = diff --git a/src/frontend/types_.cppo.ml b/src/frontend/types_.cppo.ml index f77296ffb..15612173c 100644 --- a/src/frontend/types_.cppo.ml +++ b/src/frontend/types_.cppo.ml @@ -250,6 +250,7 @@ type base_type = | DocumentType | MathType | RegExpType + | TextInfoType [@@deriving show] @@ -275,6 +276,7 @@ let base_type_hash_table = ("document" , DocumentType); ("math" , MathType ); ("regexp" , RegExpType ); + ("text-info" , TextInfoType); ]; ht end @@ -1332,6 +1334,7 @@ let rec string_of_type_basic tvf orvf tystr : string = | BaseType(DocumentType) -> "document" ^ qstn | BaseType(MathType) -> "math" ^ qstn | BaseType(RegExpType) -> "regexp" ^ qstn + | BaseType(TextInfoType) -> "text-info" ^ qstn | VariantType(tyarglist, tyid) -> (string_of_type_argument_list_basic tvf orvf tyarglist) ^ (TypeID.show_direct tyid) (* temporary *) ^ "@" ^ qstn From 5bb7efb647f00d5d2f0448a76c1f2f2fc661e61e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 07:03:13 +0900 Subject: [PATCH 42/78] omit unnecessary code in 'display.ml' --- src/frontend/display.ml | 162 +--------------------------------------- 1 file changed, 1 insertion(+), 161 deletions(-) diff --git a/src/frontend/display.ml b/src/frontend/display.ml index 51e3dc38d..1f71fa206 100644 --- a/src/frontend/display.ml +++ b/src/frontend/display.ml @@ -111,13 +111,6 @@ let rec string_of_mono_type_sub (tvf : paren_level -> 'a -> string) ortvf (tyenv match tymain with | TypeVariable(tvi) -> tvf plev tvi -(* -(* - "${" ^ iter tyl ^ "}" (* TEMPORARY *) -*) - - | Bound(bid) -> -*) | BaseType(EnvType) -> "env" (* -- unused -- *) | BaseType(UnitType) -> "unit" @@ -130,9 +123,6 @@ let rec string_of_mono_type_sub (tvf : paren_level -> 'a -> string) ortvf (tyenv | BaseType(TextColType) -> "block-text" | BaseType(BoxRowType) -> "inline-boxes" | BaseType(BoxColType) -> "block-boxes" -(* - | BaseType(FontType) -> "font" -*) | BaseType(ContextType) -> "context" | BaseType(PrePathType) -> "pre-path" | BaseType(PathType) -> "path" @@ -330,86 +320,9 @@ let string_of_poly_type (tyenv : Typeenv.t) (Poly(pty) : poly_type) = (* -- following are all for debug -- *) + let string_of_utast utast = show_untyped_abstract_tree utast -(* -let rec string_of_utast ((_, utastmain) : untyped_abstract_tree) = - match utastmain with - | UTStringEmpty -> "{}" - | UTIntegerConstant(nc) -> string_of_int nc - | UTBooleanConstant(bc) -> string_of_bool bc - | UTStringConstant(sc) -> "{" ^ sc ^ "}" - | UTUnitConstant -> "()" - | UTContentOf(lst, varnm) -> (List.fold_left (fun mdlnm s -> s ^ mdlnm ^ ".") "" lst) ^ varnm - | UTConcat(ut1, (_, UTStringEmpty)) -> string_of_utast ut1 - | UTConcat(ut1, ut2) -> "(" ^ (string_of_utast ut1) ^ " ^ " ^ (string_of_utast ut2) ^ ")" - | UTApply(ut1, ut2) -> "(" ^ (string_of_utast ut1) ^ " " ^ (string_of_utast ut2) ^ ")" - | UTListCons(hd, tl) -> "(" ^ (string_of_utast hd) ^ " :: " ^ (string_of_utast tl) ^ ")" - | UTEndOfList -> "[]" - | UTTupleCons(hd, tl) -> "(" ^ (string_of_utast hd) ^ ", " ^ (string_of_utast tl) ^ ")" - | UTEndOfTuple -> "$" -(* - | UTBreakAndIndent -> "break" -*) - | UTLetRecIn(_, ut) -> "(let ... in " ^ (string_of_utast ut) ^ ")" - | UTIfThenElse(ut1, ut2, ut3) -> "(if " ^ (string_of_utast ut1) ^ " then " - ^ (string_of_utast ut2) ^ " else " ^ (string_of_utast ut3) ^ ")" - | UTFunction(_) -> "(function ...)" - | UTFinishHeaderFile -> "finish" - | UTPatternMatch(ut, pmcons) -> "(match " ^ (string_of_utast ut) ^ " with" ^ (string_of_pmcons pmcons) ^ ")" - | UTItemize(itmz) -> "(itemize " ^ string_of_itemize 0 itmz ^ ")" -(* | UTDeclareVariantIn() *) - | UTInputVert(utivlst) -> "(textV " ^ (String.concat " " (List.map string_of_utiv utivlst)) ^ ")" - | UTInputHorz(utihlst) -> "(textH " ^ (String.concat " " (List.map string_of_utih utihlst)) ^ ")" - | _ -> "OTHER" -*) - -(* -let rec string_of_utiv (_, utivmain) = - match utivmain with - | UTInputVertEmbedded(utastcmd, utastlst) -> - "(embV " ^ (string_of_utast utastcmd) ^ " " ^ (String.concat " " (List.map string_of_utast utastlst)) ^ ")" - | UTInputVertContent(utast0) -> - "(embVC " ^ (string_of_utast utast0) ^ ")" - -and string_of_utih (_, utihmain) = - match utihmain with - | UTInputHorzEmbedded(utastcmd, utastlst) -> - "(embH " ^ (string_of_utast utastcmd) ^ " " ^ (String.concat " " (List.map string_of_utast utastlst)) ^ ")" - | UTInputHorzText(s) -> "\"" ^ s ^ "\"" - | UTInputHorzContent(utast0) -> - "(embHC " ^ (string_of_utast utast0) ^ ")" - | UTInputHorzEmbeddedMath(utastmath) -> - "(embHM " ^ (string_of_utast utastmath) ^ ")" - -and string_of_itemize dp (UTItem(utast, itmzlst)) = - "(" ^ (String.make dp '*') ^ " " ^ (string_of_utast utast) - ^ (List.fold_left (fun x y -> x ^ " " ^ y) "" (List.map (string_of_itemize (dp + 1)) itmzlst)) ^ ")" - -and string_of_pmcons pmcons = - match pmcons with - | [] -> "" - | UTPatternBranch(pat, ut) :: tail - -> " | " ^ (string_of_utpat pat) ^ " -> " ^ (string_of_utast ut) ^ (string_of_pmcons tail) - | UTPatternBranchWhen(pat, utb, ut) :: tail - -> " | " ^ (string_of_utpat pat) ^ " when " ^ (string_of_utast utb) - ^ " -> " ^ (string_of_utast ut) ^ (string_of_pmcons tail) - -and string_of_utpat (_, pat) = - match pat with - | UTPIntegerConstant(nc) -> string_of_int nc - | UTPBooleanConstant(bc) -> string_of_bool bc - | UTPStringConstant(ut) -> string_of_utast ut - | UTPUnitConstant -> "()" - | UTPListCons(hd, tl) -> (string_of_utpat hd) ^ " :: " ^ (string_of_utpat tl) - | UTPEndOfList -> "[]" - | UTPTupleCons(hd, tl) -> "(" ^ (string_of_utpat hd) ^ ", " ^ (string_of_utpat tl) ^ ")" - | UTPEndOfTuple -> "$" - | UTPWildCard -> "_" - | UTPVariable(varnm) -> varnm - | UTPAsVariable(varnm, p) -> "(" ^ (string_of_utpat p) ^ " as " ^ varnm ^ ")" - | UTPConstructor(cnm,p) -> "(" ^ cnm ^ " " ^ (string_of_utpat p) ^ ")" -*) let escape_letters str = let rec aux str index = @@ -426,76 +339,3 @@ let escape_letters str = let string_of_ast (ast : abstract_tree) = show_abstract_tree ast - -(* -let rec string_of_ast (ast : abstract_tree) = - match ast with - | LambdaAbstract(x, m) -> "(" ^ (EvalVarID.show_direct x) ^ " -> " ^ (string_of_ast m) ^ ")" - | FuncWithEnvironment(x, m, _) -> "(" ^ (EvalVarID.show_direct x) ^ " *-> " ^ (string_of_ast m) ^ ")" - | ContentOf(rng, x) -> EvalVarID.show_direct x - | Apply(m, n) -> "(" ^ (string_of_ast m) ^ " " ^ (string_of_ast n) ^ ")" - | Concat(s, t) -> "(" ^ (string_of_ast s) ^ " ^ " ^ (string_of_ast t) ^ ")" - | StringEmpty -> "\"\"" - | StringConstant(sc) -> "\"" ^ (escape_letters sc) ^ "\"" - | IntegerConstant(nc) -> string_of_int nc - | FloatConstant(nc) -> string_of_float nc - | BooleanConstant(bc) -> string_of_bool bc - | IfThenElse(b, t, f) -> - "(if " ^ (string_of_ast b) ^ " then " ^ (string_of_ast t) ^ " else " ^ (string_of_ast f) ^ ")" -(* - | ApplyClassAndID(c, i, m) -> - "(apply-class-and-id " ^ (string_of_ast c) ^ " " ^ (string_of_ast i) ^ " " ^ (string_of_ast m) ^ ")" -*) - | Dereference(a) -> "(!" ^ (string_of_ast a) ^ ")" -(* - | ReferenceFinal(a) -> "(!!" ^ (string_of_ast a) ^ ")" -*) - | Overwrite(x, n) -> "(" ^ (EvalVarID.show_direct x) ^ " <- " ^ (string_of_ast n) ^ ")" - | Location(loc) -> "" - | UnitConstant -> "()" - | LetMutableIn(x, d, f) -> "(let-mutable " ^ (EvalVarID.show_direct x) ^ " <- " ^ (string_of_ast d) ^ " in " ^ (string_of_ast f) ^ ")" - | ListCons(a, cons) -> "(" ^ (string_of_ast a) ^ " :: " ^ (string_of_ast cons) ^ ")" - | EndOfList -> "[]" - | TupleCons(a, cons) -> "(" ^ (string_of_ast a) ^ ", " ^ (string_of_ast cons) ^ ")" - | EndOfTuple -> "end-of-tuple" -(* - | BreakAndIndent -> "break" -*) - | FinishHeaderFile -> "finish-header-file" - | EvaluatedEnvironment(_) -> "evaluated-environment" -(* - | DeeperIndent(m) -> "(deeper " ^ (string_of_ast m) ^ ")" -*) - | Constructor(c, m) -> "(constructor " ^ c ^ " " ^ (string_of_ast m) ^ ")" - | PatternMatch(_, _) -> "(match ...)" - | LetIn(_, m) -> "(let ... in " ^ (string_of_ast m) ^ ")" - | WhileDo(m, n) -> "(while " ^ (string_of_ast m) ^ " do " ^ (string_of_ast n) ^ ")" -(* - | DeclareGlobalHash(m, n) -> "(declare-global-hash " ^ (string_of_ast m) ^ " <<- " ^ (string_of_ast n) ^ ")" - | OverwriteGlobalHash(m, n) -> "(overwrite-global-hash " ^ (string_of_ast m) ^ " <<- " ^ (string_of_ast n) ^ ")" -*) - | Module(m, n) -> "(module " ^ (string_of_ast m) ^ " end in " ^ (string_of_ast n) ^ ")" - | Sequential(m, n) -> "(sequential " ^ (string_of_ast m) ^ " ; " ^ (string_of_ast n) ^ ")" - | PrimitiveSame(m, n) -> "(same " ^ (string_of_ast m) ^ " " ^ (string_of_ast n) ^ ")" - | PrimitiveStringSub(m, n, o) -> - "(string-sub " ^ (string_of_ast m) ^ " " ^ (string_of_ast n) ^ " " ^ (string_of_ast o) ^ ")" - | PrimitiveStringLength(m) -> "(string-length " ^ (string_of_ast m) ^ ")" - | PrimitiveArabic(m) -> "(arabic " ^ (string_of_ast m) ^ ")" - | Record(asc) -> "(| ... |)" - | AccessField(r, f) -> (string_of_ast r) ^ "#" ^ f - | InputHorz(_) -> "(input-horz ...)" - | InputVert(_) -> "(input-vert ...)" - | Horz(_) -> "(horz ...)" - | Vert(_) -> "(vert ...)" - | HorzConcat(ast1, ast2) -> "(horz-concat " ^ (string_of_ast ast1) ^ " " ^ (string_of_ast ast2) ^ ")" - | VertConcat(ast1, ast2) -> "(vert-concat " ^ (string_of_ast ast1) ^ " " ^ (string_of_ast ast2) ^ ")" - | HorzLex(ast1, ast2) -> "(horz-lex " ^ (string_of_ast ast1) ^ " " ^ (string_of_ast ast2) ^ ")" - | VertLex(ast1, ast2) -> "(vert-lex " ^ (string_of_ast ast1) ^ " " ^ (string_of_ast ast2) ^ ")" - | LambdaHorz(_, ast1) -> "(lambda-horz _. " ^ (string_of_ast ast1) ^ ")" - | LambdaVert(_, ast1) -> "(lambda-vert _. " ^ (string_of_ast ast1) ^ ")" - | LambdaHorzWithEnvironment(_, ast1, _) -> "(lambda-horz! _. " ^ (string_of_ast ast1) ^ ")" - | LambdaVertWithEnvironment(_, ast1, _) -> "(lambda-vert! _. " ^ (string_of_ast ast1) ^ ")" - | Context(_) -> "(context)" - | FontDesignation(_) -> "(font-designation)" - | _ -> "OTHER" -*) From b2201ec228355801d850f4014e81da38de46cb3d Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 08:51:37 +0900 Subject: [PATCH 43/78] start to support text mode --- Makefile | 2 +- gen_code.rb | 2 +- src/backend/optionState.ml | 9 +++ src/backend/optionState.mli | 4 + src/frontend/bytecomp/vminstdef.yaml | 35 ++++++++- src/frontend/main.ml | 106 ++++++++++++++++++++++----- src/frontend/primitives_.cppo.ml | 6 +- src/frontend/typechecker.ml | 40 ++++++++-- 8 files changed, 171 insertions(+), 33 deletions(-) diff --git a/Makefile b/Makefile index 410e9f354..275511c28 100644 --- a/Makefile +++ b/Makefile @@ -55,7 +55,7 @@ $(PRIM_PDF_GEN): $(INSTDEF) $(GENCODE) $(RUBY) $(GENCODE) --gen-pdf-mode-prims $(INSTDEF) > $@ $(PRIM_TEXT_GEN): $(INSTDEF) $(GENCODE) - $(RUBY) $(GENCODE) --gen-pdf-mode-prims $(INSTDEF) > $@ + $(RUBY) $(GENCODE) --gen-text-mode-prims $(INSTDEF) > $@ install: $(TARGET) mkdir -p $(BINDIR) diff --git a/gen_code.rb b/gen_code.rb index e2b89fd7f..1261ac0b0 100644 --- a/gen_code.rb +++ b/gen_code.rb @@ -31,7 +31,7 @@ def default_false b def gen_prims tag YAML.load_stream(ARGF.read) do |inst| - if inst[tag] && inst["name"] != nil then + if default_false(inst[tag]) && inst["name"] != nil then len = inst["params"].length args = [] for i in 1..len diff --git a/src/backend/optionState.ml b/src/backend/optionState.ml index 75697999b..6d39161f8 100644 --- a/src/backend/optionState.ml +++ b/src/backend/optionState.ml @@ -7,6 +7,7 @@ type state = { mutable show_full_path : bool; mutable debug_show_bbox : bool; mutable debug_show_space : bool; + mutable mode : (string list) option; } @@ -18,6 +19,7 @@ let state = { show_full_path = false; debug_show_bbox = false; debug_show_space = false; + mode = None; } let set_input_file srcpath = state.input_file <- Some(srcpath) @@ -40,3 +42,10 @@ let debug_show_bbox () = state.debug_show_bbox let set_debug_show_space () = state.debug_show_space <- true let debug_show_space () = state.debug_show_space + +let set_text_mode lst = state.mode <- Some(lst) +let get_mode () = state.mode +let is_text_mode () = + match state.mode with + | Some(_) -> true + | None -> false diff --git a/src/backend/optionState.mli b/src/backend/optionState.mli index 3329fa039..9cb2df058 100644 --- a/src/backend/optionState.mli +++ b/src/backend/optionState.mli @@ -19,3 +19,7 @@ val debug_show_bbox : unit -> bool val set_debug_show_space : unit -> unit val debug_show_space : unit -> bool + +val set_text_mode : string list -> unit +val get_mode : unit -> (string list) option +val is_text_mode : unit -> bool diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 4deba5b82..248920f8f 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1343,6 +1343,7 @@ code-interp: | | InputVertWithEnvironment(imivlst, envi) -> interpret_pdf_mode_intermediate_input_vert envi valuectx imivlst | _ -> report_bug_value "VertLex" value1 +--- inst: TextHorzLex is-text-mode-primitive: yes name: "stringify-inline" @@ -1368,7 +1369,7 @@ inst: TextVertLex is-text-mode-primitive: yes name: "stringify-block" type: | - ~% (tTCTX @-> tBT @-> ts) + ~% (tTCTX @-> tBT @-> tS) separated: yes params: @@ -1384,6 +1385,38 @@ code-interp: | | InputVertWithEnvironment(imivlst, envi) -> interpret_text_mode_intermediate_input_vert envi valuetctx imivlst | _ -> report_bug_value "TextVertLex" value1 +--- +inst: TextDeepenIndent +is-text-mode-primitive: yes +name: "deepen-indent" +type: | + ~% (tI @-> tTCTX @-> tTCTX) + +params: +- i : int +- tctx : text_mode_context +code: | + let tctx = tctx |> TextBackend.deepen_indent i in + TextModeContext(tctx) + +--- +inst: TextGetInitialTextModeContext +is-text-mode-primitive: yes +name: "get-initial-text-info" +params: +- value1 +type: | + ~% (tU @-> tTCTX) + +code: | + match value1 with + | UnitConstant -> + let tctx = TextBackend.get_initial_text_mode_context () in + TextModeContext(tctx) + + | _ -> + report_bug_value "TextGetInitialTextModeContext" value1 + --- inst: PrimitiveEmbeddedVertBreakable is-pdf-mode-primitive: yes diff --git a/src/frontend/main.ml b/src/frontend/main.ml index 5d569203b..e17dcee77 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -15,6 +15,8 @@ exception NoInputFileDesignation exception CyclicFileDependency of file_path list exception NotALibraryFile of file_path * Typeenv.t * mono_type exception NotADocumentFile of file_path * Typeenv.t * mono_type +exception NotAStringFile of file_path * Typeenv.t * mono_type +exception ShouldSpecifyOutputFile type line = @@ -145,10 +147,13 @@ let eval_library_file (tyenv : Typeenv.t) (env : environment) (file_name_in : fi (* -- initialization that should be performed before every cross-reference-solving loop -- *) let reset () = - begin - FontInfo.initialize (); - ImageInfo.initialize (); - end + if OptionState.is_text_mode () then + () + else + begin + FontInfo.initialize (); + ImageInfo.initialize (); + end (* -- initialization that should be performed before typechecking -- *) @@ -160,7 +165,12 @@ let initialize (dump_file : file_path) = EvalVarID.initialize (); StoreID.initialize (); let dump_file_exists = CrossRef.initialize dump_file in - let (tyenv, env) = Primitives.make_pdf_mode_environments () in + let (tyenv, env) = + if OptionState.is_text_mode () then + Primitives.make_text_mode_environments () + else + Primitives.make_pdf_mode_environments () + in begin if OptionState.bytecomp_mode () then Bytecomp.compile_environment env @@ -217,6 +227,26 @@ let register_document_file (dg : file_info FileDependencyGraph.t) (file_path_in end +let eval_main i env_freezed ast = + Logging.start_evaluation i; + reset (); + let env = unfreeze_environment env_freezed in + let valuedoc = + if OptionState.bytecomp_mode () then + Bytecomp.compile_and_exec env ast + else + Evaluator.interpret env ast + in + Logging.end_evaluation (); + valuedoc + + +let output_text file_path_out s = + let outc = open_out file_path_out in + output_string outc s; + close_out outc + + let eval_document_file (tyenv : Typeenv.t) (env : environment) (file_path_in : file_path) (utast : untyped_abstract_tree) (file_path_out : file_path) (file_path_dump : file_path) = Logging.begin_to_read_file file_path_in; let (ty, _, ast) = Typechecker.main tyenv utast in @@ -224,19 +254,37 @@ let eval_document_file (tyenv : Typeenv.t) (env : environment) (file_path_in : f if OptionState.type_check_only () then () else let env_freezed = freeze_environment env in + if OptionState.is_text_mode () then + match ty with + | (_, BaseType(StringType)) -> + let rec aux i = + let valuestr = eval_main i env_freezed ast in + let s = EvalUtil.get_string valuestr in + match CrossRef.needs_another_trial file_path_dump with + | CrossRef.NeedsAnotherTrial -> + Logging.needs_another_trial (); + aux (i + 1); + + | CrossRef.CountMax -> + Logging.achieve_count_max (); + output_text file_path_out s; + Logging.end_output file_path_out; + + | CrossRef.CanTerminate unresolved_crossrefs -> + Logging.achieve_fixpoint unresolved_crossrefs; + output_text file_path_out s; + Logging.end_output file_path_out; + + in + aux 1 + + | _ -> + raise (NotAStringFile(file_path_in, tyenv, ty)) + else match ty with | (_, BaseType(DocumentType)) -> let rec aux i = - Logging.start_evaluation i; - reset (); - let env = unfreeze_environment env_freezed in - let valuedoc = - if OptionState.bytecomp_mode () then - Bytecomp.compile_and_exec env ast - else - Evaluator.interpret env ast - in - Logging.end_evaluation (); + let valuedoc = eval_main i env_freezed ast in begin match valuedoc with | DocumentValue(pagesize, pagecontf, pagepartsf, imvblst) -> @@ -309,6 +357,17 @@ let error_log_environment suspended = DisplayLine(string_of_mono_type tyenv ty); ] + | NotAStringFile(file_name_in, tyenv, ty) -> + report_error Typechecker [ + NormalLine("file '" ^ file_name_in ^ "' is not a file for generating text; it is of type"); + DisplayLine(string_of_mono_type tyenv ty); + ] + + | ShouldSpecifyOutputFile -> + report_error Interface [ + NormalLine("should specify output file for text mode."); + ] + | CrossRef.InvalidYOJSON(dumpfile, msg) -> report_error Interface [ NormalLine("dump file '" ^ dumpfile ^ "' is NOT a valid YOJSON file:"); @@ -722,6 +781,11 @@ let handle_anonimous_arg (curdir : file_path) (s : file_path) = OptionState.set_input_file file_path +let text_mode s = + let slst = String.split_on_char ',' s in + OptionState.set_text_mode slst + + let arg_spec_list curdir = [ ("-o" , Arg.String(arg_output curdir) , " Specify output file" ); @@ -735,6 +799,7 @@ let arg_spec_list curdir = ("--type-check-only" , Arg.Unit(OptionState.set_type_check_only) , " Stops after type checking" ); ("-b" , Arg.Unit(OptionState.set_bytecomp_mode) , " Use bytecode compiler" ); ("--bytecomp" , Arg.Unit(OptionState.set_bytecomp_mode) , " Use bytecode compiler" ); + ("--text-mode" , Arg.String(text_mode) , " Set text mode" ); ] @@ -779,10 +844,13 @@ let () = v | None -> - begin - try (Filename.chop_extension input_file) ^ ".pdf" with - | Invalid_argument(_) -> input_file ^ ".pdf" - end + if OptionState.is_text_mode () then + raise ShouldSpecifyOutputFile + else + begin + try (Filename.chop_extension input_file) ^ ".pdf" with + | Invalid_argument(_) -> input_file ^ ".pdf" + end in Logging.target_file output_file; let dump_file = (Filename.remove_extension output_file) ^ ".satysfi-aux" in diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 15e17ef3b..16722c749 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -548,13 +548,13 @@ let make_environments table = ) (tyenvinit, envinit, Alist.empty) in locacc |> Alist.to_list |> List.iter (fun (loc, deff) -> loc := deff envfinal); - default_font_scheme_ref := SetDefaultFont.main (); - default_hyphen_dictionary := LoadHyph.main "english.satysfi-hyph"; - (* temporary; should depend on the current language -- *) (tyenvfinal, envfinal) let make_pdf_mode_environments () = + default_font_scheme_ref := SetDefaultFont.main (); + default_hyphen_dictionary := LoadHyph.main "english.satysfi-hyph"; + (* temporary; should depend on the current language -- *) make_environments pdf_mode_table diff --git a/src/frontend/typechecker.ml b/src/frontend/typechecker.ml index ca90cb841..e67fa635b 100644 --- a/src/frontend/typechecker.ml +++ b/src/frontend/typechecker.ml @@ -638,17 +638,29 @@ let rec typecheck (Concat(e1, e2), (rng, BaseType(TextRowType))) | UTLambdaHorz(varrng, varnmctx, utast1) -> + let (bstyvar, bstyret) = + if OptionState.is_text_mode () then + (TextInfoType, StringType) + else + (ContextType, BoxRowType) + in let evid = EvalVarID.fresh (varrng, varnmctx) in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in + let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(bstyvar)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in - let () = unify tyret (Range.dummy "lambda-horz-return", BaseType(BoxRowType)) in + let () = unify tyret (Range.dummy "lambda-horz-return", BaseType(bstyret)) in (abstraction evid e1, (rng, HorzCommandType(cmdargtylist))) | UTLambdaVert(varrng, varnmctx, utast1) -> + let (bstyvar, bstyret) = + if OptionState.is_text_mode () then + (TextInfoType, StringType) + else + (ContextType, BoxColType) + in let evid = EvalVarID.fresh (varrng, varnmctx) in - let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(ContextType)), evid)) utast1 in + let (e1, ty1) = typecheck_iter (Typeenv.add tyenv varnmctx (Poly(varrng, BaseType(bstyvar)), evid)) utast1 in let (cmdargtylist, tyret) = flatten_type ty1 in - let () = unify tyret (Range.dummy "lambda-vert-return", BaseType(BoxColType)) in + let () = unify tyret (Range.dummy "lambda-vert-return", BaseType(bstyret)) in (abstraction evid e1, (rng, VertCommandType(cmdargtylist))) | UTLambdaMath(utastF) -> @@ -876,16 +888,28 @@ let rec typecheck | UTLexHorz(utastctx, utasth) -> let (ectx, tyctx) = typecheck_iter tyenv utastctx in let (eh, tyh) = typecheck_iter tyenv utasth in - let () = unify tyctx (Range.dummy "ut-lex-horz-1", BaseType(ContextType)) in + let (eret, bstyctx, bstyret) = + if OptionState.is_text_mode () then + (TextHorzLex(ectx, eh), TextInfoType, StringType) + else + (HorzLex(ectx, eh), ContextType, BoxRowType) + in + let () = unify tyctx (Range.dummy "ut-lex-horz-1", BaseType(bstyctx)) in let () = unify tyh (Range.dummy "ut-lex-horz-2", BaseType(TextRowType)) in - (HorzLex(ectx, eh), (rng, BaseType(BoxRowType))) + (eret, (rng, BaseType(bstyret))) | UTLexVert(utastctx, utastv) -> let (ectx, tyctx) = typecheck_iter tyenv utastctx in let (ev, tyv) = typecheck_iter tyenv utastv in - let () = unify tyctx (Range.dummy "ut-lex-vert-1", BaseType(ContextType)) in + let (eret, bstyctx, bstyret) = + if OptionState.is_text_mode () then + (TextVertLex(ectx, ev), TextInfoType, StringType) + else + (VertLex(ectx, ev), ContextType, BoxColType) + in + let () = unify tyctx (Range.dummy "ut-lex-vert-1", BaseType(bstyctx)) in let () = unify tyv (Range.dummy "ut-lex-vert-2", BaseType(TextColType)) in - (HorzLex(ectx, ev), (rng, BaseType(BoxColType))) + (eret, (rng, BaseType(bstyret))) and typecheck_command_arguments (ecmd : abstract_tree) (tycmd : mono_type) (rngcmdapp : Range.t) qtfbl lev tyenv (utcmdarglst : untyped_command_argument list) (cmdargtylst : mono_command_argument_type list) : abstract_tree = From ef3afc1f5f042180a9161766e24f4f7bb217ccc6 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 09:02:37 +0900 Subject: [PATCH 44/78] add text mode primitive 'break' --- src/frontend/bytecomp/vminstdef.yaml | 14 ++++++++++++++ src/text-mode/textBackend.ml | 4 ++++ 2 files changed, 18 insertions(+) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 248920f8f..4f772ce60 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1399,6 +1399,20 @@ code: | let tctx = tctx |> TextBackend.deepen_indent i in TextModeContext(tctx) +--- +inst: TextBreak +is-text-mode-primitive: yes +name: "break" +params: +- tctx : text_mode_context +type: | + ~% (tTCTX @-> tS) + +code: | + let i = TextBackend.get_indent tctx in + let s = "\n" ^ (String.make i ' ') in + StringConstant(s) + --- inst: TextGetInitialTextModeContext is-text-mode-primitive: yes diff --git a/src/text-mode/textBackend.ml b/src/text-mode/textBackend.ml index 0127ffc6f..de2ff4893 100644 --- a/src/text-mode/textBackend.ml +++ b/src/text-mode/textBackend.ml @@ -17,6 +17,10 @@ let deepen_indent i tctx = { tctx with indent = tctx.indent + (max i 0); } +let get_indent tctx = + tctx.indent + + let set_escape_list elst tctx = { tctx with escape_list = elst; } From 51536614bbaa1d258bdfc2489b3e8193927cc948 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 10:57:22 +0900 Subject: [PATCH 45/78] modify 'Config' for allowing text mode --- src/backend/loadFont.ml | 7 ++----- src/backend/loadHyph.ml | 3 +-- src/backend/setDefaultFont.ml | 3 +-- src/config.ml | 38 ++++++++++++++++++++++++++--------- src/config.mli | 4 +++- src/frontend/fontInfo.ml | 13 ++++++------ src/frontend/main.ml | 13 ++++++++---- src/myUtil.ml | 16 +++++++++++++++ src/myUtil.mli | 2 ++ 9 files changed, 68 insertions(+), 31 deletions(-) diff --git a/src/backend/loadFont.ml b/src/backend/loadFont.ml index 1b5526c9a..33a61c9f7 100644 --- a/src/backend/loadFont.ml +++ b/src/backend/loadFont.ml @@ -1,4 +1,4 @@ -open Config + open MyUtil type file_path = string @@ -95,10 +95,7 @@ let read_assoc (srcpath : file_path) assoc = let main (filename : file_path) = -(* - Format.printf "LoadFont> main %s\n" filename; (* for debug *) -*) - let srcpath = resolve_dist_path (Filename.concat "dist/hash" filename) in + let srcpath = Config.resolve_dist_file (Filename.concat "dist/hash" filename) in try let json = Yojson.Safe.from_file srcpath in (* -- may raise 'Sys_error', or 'Yojson.Json_error' -- *) diff --git a/src/backend/loadHyph.ml b/src/backend/loadHyph.ml index f336b29fc..962e70f2c 100644 --- a/src/backend/loadHyph.ml +++ b/src/backend/loadHyph.ml @@ -1,7 +1,6 @@ open MyUtil open CharBasis -open Config type dir_path = string @@ -160,7 +159,7 @@ let read_assoc (srcpath : file_path) (assoc : (string * Yojson.Safe.json) list) let main (filename : file_path) : t = - let srcpath = resolve_dist_path (Filename.concat "dist/hyph" filename) in + let srcpath = Config.resolve_dist_file (Filename.concat "dist/hyph" filename) in try let json = Yojson.Safe.from_file srcpath in (* -- may raise 'Sys_error', or 'Yojson.Json_error' -- *) diff --git a/src/backend/setDefaultFont.ml b/src/backend/setDefaultFont.ml index 0ef51e1e7..d97cdcd6e 100644 --- a/src/backend/setDefaultFont.ml +++ b/src/backend/setDefaultFont.ml @@ -1,7 +1,6 @@ open MyUtil open CharBasis -open Config type dir_path = string type file_path = string @@ -84,7 +83,7 @@ let read_assoc srcpath assoc = let main () : (font_abbrev * float * float) ScriptSchemeMap.t = - let srcpath = resolve_dist_path "dist/hash/default-font.satysfi-hash" in + let srcpath = Config.resolve_dist_file "dist/hash/default-font.satysfi-hash" in try let json = Yojson.Safe.from_file srcpath in (* -- may raise 'Sys_error', or 'Yojson.Json_error' -- *) diff --git a/src/config.ml b/src/config.ml index 214d6f9b3..63676451d 100644 --- a/src/config.ml +++ b/src/config.ml @@ -9,14 +9,32 @@ let initialize root_dirs = satysfi_root_dirs := root_dirs -let resolve_dist_path filename = - let dirlst = !satysfi_root_dirs in - let rec go = function - | [] -> - raise (DistFileNotFound(filename, dirlst)) - - | d :: ds -> - let fn = Filename.concat d filename in - if Sys.file_exists fn then fn else go ds +let resolve fn = + if Sys.file_exists fn then Some(fn) else None + + +let resolve_dist_file filename = + let dirs = !satysfi_root_dirs in + let pathcands = + dirs |> List.map (fun dir -> Filename.concat dir filename) + in + match MyUtil.first_some resolve pathcands with + | None -> raise (DistFileNotFound(filename, pathcands)) + | Some(fn) -> fn + + +let resolve_dist_package package extcands = + let withexts = + extcands |> List.map (fun extcand -> package ^ extcand) + in + let dirs = !satysfi_root_dirs in + let pathcands = + dirs |> List.map (fun dir -> + withexts |> List.map (fun withext -> + Filename.concat dir withext + ) + ) |> List.concat in - go dirlst + match MyUtil.first_some resolve pathcands with + | None -> raise (DistFileNotFound(package, pathcands)) + | Some(fn) -> fn diff --git a/src/config.mli b/src/config.mli index 9b7f5c118..255a53365 100644 --- a/src/config.mli +++ b/src/config.mli @@ -3,4 +3,6 @@ exception DistFileNotFound of string * string list val initialize : string list -> unit -val resolve_dist_path : string -> string +val resolve_dist_file : string -> string + +val resolve_dist_package : string -> string list -> string diff --git a/src/frontend/fontInfo.ml b/src/frontend/fontInfo.ml index 2a734eabb..f22e7bdc1 100644 --- a/src/frontend/fontInfo.ml +++ b/src/frontend/fontInfo.ml @@ -5,7 +5,6 @@ open LengthInterface open HorzBox open CharBasis open Types -open Config exception InvalidFontAbbrev of font_abbrev @@ -84,7 +83,7 @@ module FontAbbrevHashTable match !storeref with | UnusedSingle(srcpath) -> (* -- if this is the first access to the single font -- *) - let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + let srcpath = Config.resolve_dist_file (Filename.concat "dist/fonts" srcpath) in begin match FontFormat.get_decoder_single (abbrev ^ "-Composite") (* temporary *) srcpath with | None -> @@ -101,7 +100,7 @@ module FontAbbrevHashTable | UnusedTTC(srcpath, i) -> (* -- if this is the first access to the TrueTypeCollection -- *) - let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + let srcpath = Config.resolve_dist_file (Filename.concat "dist/fonts" srcpath) in begin match FontFormat.get_decoder_ttc (abbrev ^ "-Composite") (* temporary *) srcpath i with | None -> @@ -263,7 +262,7 @@ module MathFontAbbrevHashTable match !storeref with | UnusedMath(srcpath) -> (* -- if this is the first access to the math font -- *) - let srcpath = resolve_dist_path (Filename.concat "dist/fonts" srcpath) in + let srcpath = Config.resolve_dist_file (Filename.concat "dist/fonts" srcpath) in begin match FontFormat.get_math_decoder (mfabbrev ^ "-Composite-Math") (* temporary *) srcpath with | None -> @@ -432,10 +431,10 @@ let get_font_dictionary (pdf : Pdf.t) : Pdf.pdfobject = let initialize () = FontAbbrevHashTable.initialize (); MathFontAbbrevHashTable.initialize (); - let filename_S = resolve_dist_path "dist/unidata/Scripts.txt" in - let filename_EAW = resolve_dist_path "dist/unidata/EastAsianWidth.txt" in + let filename_S = Config.resolve_dist_file "dist/unidata/Scripts.txt" in + let filename_EAW = Config.resolve_dist_file "dist/unidata/EastAsianWidth.txt" in ScriptDataMap.set_from_file filename_S filename_EAW; - LineBreakDataMap.set_from_file (resolve_dist_path "dist/unidata/LineBreak.txt"); + LineBreakDataMap.set_from_file (Config.resolve_dist_file "dist/unidata/LineBreak.txt"); let font_hash = LoadFont.main "fonts.satysfi-hash" in font_hash |> List.iter (fun (abbrev, data) -> match data with diff --git a/src/frontend/main.ml b/src/frontend/main.ml index e17dcee77..4a432fe50 100644 --- a/src/frontend/main.ml +++ b/src/frontend/main.ml @@ -99,8 +99,13 @@ type file_info = let make_absolute_path curdir headerelem = + let extcands = + match OptionState.get_mode () with + | None -> [".satyh"; ".satyg"] + | Some(lst) -> List.append (lst |> List.map (fun s -> ".satyh-" ^ s)) [".satyg"] + in match headerelem with - | HeaderRequire(s) -> Config.resolve_dist_path (Filename.concat "dist/packages" s ^ ".satyh") + | HeaderRequire(s) -> Config.resolve_dist_package (Filename.concat "dist/packages" s) extcands | HeaderImport(s) -> Filename.concat curdir (s ^ ".satyh") @@ -338,12 +343,12 @@ let error_log_environment suspended = (cycle |> List.map (fun s -> DisplayLine(s))) ) - | Config.DistFileNotFound(file_name, dirlst) -> + | Config.DistFileNotFound(file_name, pathcands) -> report_error Interface (List.append [ NormalLine("package file not found:"); DisplayLine(file_name); - NormalLine("candidate directories for the SATySFi library root:"); - ] (dirlst |> List.map (fun dir -> DisplayLine(dir)))) + NormalLine("candidate paths:"); + ] (pathcands |> List.map (fun pathcand -> DisplayLine(pathcand)))) | NotALibraryFile(file_name_in, tyenv, ty) -> report_error Typechecker [ diff --git a/src/myUtil.ml b/src/myUtil.ml index 3fb4105be..018c91d48 100644 --- a/src/myUtil.ml +++ b/src/myUtil.ml @@ -101,3 +101,19 @@ let ( @|> ) = ( |> ) right-associative version; `y @|> x @|> f ` is equivalent to `f x y` ---- *) + + +let first_some f lst = + let rec aux = function + | [] -> + None + + | x :: xs -> + let opt = f x in + begin + match opt with + | Some(_) -> opt + | None -> aux xs + end + in + aux lst diff --git a/src/myUtil.mli b/src/myUtil.mli index 610f1d2a9..5053cea5d 100644 --- a/src/myUtil.mli +++ b/src/myUtil.mli @@ -34,3 +34,5 @@ end val ( += ) : int ref -> int -> unit val ( @|> ) : 'a -> ('a -> 'b) -> 'b + +val first_some : ('a -> 'b option) -> 'a list -> 'b option From ec97875b9679f895a287a4b6e06b8ed3fc556f3e Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 11:02:01 +0900 Subject: [PATCH 46/78] rename packages 'list' and 'option' --- lib-satysfi/dist/packages/{list.satyh => list.satyg} | 0 lib-satysfi/dist/packages/{option.satyh => option.satyg} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename lib-satysfi/dist/packages/{list.satyh => list.satyg} (100%) rename lib-satysfi/dist/packages/{option.satyh => option.satyg} (100%) diff --git a/lib-satysfi/dist/packages/list.satyh b/lib-satysfi/dist/packages/list.satyg similarity index 100% rename from lib-satysfi/dist/packages/list.satyh rename to lib-satysfi/dist/packages/list.satyg diff --git a/lib-satysfi/dist/packages/option.satyh b/lib-satysfi/dist/packages/option.satyg similarity index 100% rename from lib-satysfi/dist/packages/option.satyh rename to lib-satysfi/dist/packages/option.satyg From 38bffecbf7322fc7206be792223287dace570b48 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 17 Aug 2018 12:21:00 +0900 Subject: [PATCH 47/78] add package 'html-base.satyh-html' --- .../dist/packages/html-base.satyh-html | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 lib-satysfi/dist/packages/html-base.satyh-html diff --git a/lib-satysfi/dist/packages/html-base.satyh-html b/lib-satysfi/dist/packages/html-base.satyh-html new file mode 100644 index 000000000..334e56590 --- /dev/null +++ b/lib-satysfi/dist/packages/html-base.satyh-html @@ -0,0 +1,25 @@ +@require: option +@require: list + +module HTMLBase : sig + + val tag : (string * string) list?-> bool?-> int?-> text-info -> string -> (text-info -> string) -> string + +end = struct + + let make-props props = + props |> List.fold-left (fun sacc (k, v) -> ( + sacc ^ #` `# ^ k ^ `="` ^ v ^ `"` + )) ` ` + + + let tag ?:propsopt ?:bropt ?:indentopt tinfo s sf = + let props = Option.from [] propsopt in + let br = Option.from true bropt in + let indent = Option.from 2 indentopt in + let tinfo-inner = tinfo |> deepen-indent indent in + `<` ^ s ^ (make-props props) ^ `>` ^ (if br then break tinfo-inner else ` `) + ^ (sf tinfo-inner) + ^ (if br then break tinfo else ` `) ^ `` + +end From 505900e91d7f8c6d2bae4a95eab9811db960e597 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 18 Aug 2018 18:27:09 +0900 Subject: [PATCH 48/78] update packages ('footnote-scheme' etc.) --- lib-satysfi/dist/packages/code.satyh | 18 ++++- .../dist/packages/footnote-scheme.satyh | 77 +++++++++++++++++++ lib-satysfi/dist/packages/pervasives.satyh | 20 +++-- lib-satysfi/dist/packages/stdjabook.satyh | 70 ++--------------- 4 files changed, 117 insertions(+), 68 deletions(-) create mode 100644 lib-satysfi/dist/packages/footnote-scheme.satyh diff --git a/lib-satysfi/dist/packages/code.satyh b/lib-satysfi/dist/packages/code.satyh index fff2b527e..7ce2c6021 100644 --- a/lib-satysfi/dist/packages/code.satyh +++ b/lib-satysfi/dist/packages/code.satyh @@ -7,6 +7,8 @@ module Code : sig direct +code : [string] block-cmd direct +console : [string] block-cmd + direct \code : [string] inline-cmd + direct \d-code : [string] inline-cmd end = struct @@ -59,11 +61,15 @@ end = struct (deco, deco, deco, deco) + let set-code-font ctx = + ctx |> set-font Latin (`lmmono`, 1., 0.) + + let code-scheme decoset txtcolor ctx code = let pads = (5pt, 5pt, 5pt, 5pt) in block-frame-breakable ctx pads decoset (fun ctx -> ( let fontsize = get-font-size ctx in - let ctx = ctx |> set-font Latin (`lmmono`, 1., 0.) in + let ctx = ctx |> set-code-font in let charwid = get-natural-width (read-inline ctx {0}) in let ctx-code = ctx |> set-space-ratio (charwid /' fontsize) 0. 0. @@ -103,4 +109,14 @@ end = struct let-block ctx +console code = code-scheme decoset-console Color.white ctx code + + let-inline ctx \d-code code = + inline-fil ++ embed-block-breakable ctx + (read-block ctx '<+code(code);>) + + + let-inline ctx \code code = + script-guard Latin + (read-inline (ctx |> set-code-font) (embed-string code)) + end diff --git a/lib-satysfi/dist/packages/footnote-scheme.satyh b/lib-satysfi/dist/packages/footnote-scheme.satyh new file mode 100644 index 000000000..a1f74296c --- /dev/null +++ b/lib-satysfi/dist/packages/footnote-scheme.satyh @@ -0,0 +1,77 @@ +@require: color +@require: gr + + +module FootnoteScheme : sig + + val start-page : unit -> unit + val main : context -> (int -> inline-boxes) -> (int -> block-boxes) -> inline-boxes + +end = struct + + let-mutable footnote-ref <- 0 + let-mutable first-footnote <- true + + + let start-page () = + first-footnote <- true + + + let generate-footnote-label n = + `footnote:` ^ (arabic n) + + + let promote-another-trial () = + register-cross-reference `changed` `T` + + + let main ctx ibf bbf = + let () = footnote-ref <- !footnote-ref + 1 in + let num = !footnote-ref in + let label = generate-footnote-label num in + let it-num = embed-string (arabic num) in + let size = get-font-size ctx in + let ib-num = ibf num in + let bb = bbf num in + let bb-before = + match get-cross-reference label with + | Some(`T`) -> + let () = display-message (`'` ^ label ^ `': T`) in % for debug + let bar-top-margin = size in + let bar-bottom-margin = size *' 0.125 in + let wid = get-text-width ctx in + let ib = + inline-graphics wid bar-top-margin bar-bottom-margin (fun (x, y) -> + [ stroke 0.5pt Color.black (Gr.line (x, y) (x +' wid, y)); ] + ) + in + line-break false false (ctx |> set-paragraph-margin 0pt 0pt) ib + + | _ -> + let () = display-message (`'` ^ label ^ `': F`) in % for debug + block-skip (size *' 0.5) + in + no-break + (add-footnote (bb-before +++ bb) ++ ib-num + ++ hook-page-break (fun _ _ -> ( + let () = + if !first-footnote then + match get-cross-reference label with + | Some(`T`) -> + () + + | _ -> + let () = promote-another-trial () in + register-cross-reference label `T` + else + match get-cross-reference label with + | Some(`F`) -> + () + + | _ -> + let () = promote-another-trial () in + register-cross-reference label `F` + in + first-footnote <- false))) + +end diff --git a/lib-satysfi/dist/packages/pervasives.satyh b/lib-satysfi/dist/packages/pervasives.satyh index 4cd766151..da103ec31 100644 --- a/lib-satysfi/dist/packages/pervasives.satyh +++ b/lib-satysfi/dist/packages/pervasives.satyh @@ -20,6 +20,14 @@ let-inline ctx \hskip len = inline-skip len +let no-break ib = + inline-frame-outer (0pt, 0pt, 0pt, 0pt) (fun _ _ _ _ -> []) ib + + +let-inline ctx \no-break inner = + no-break (read-inline ctx inner) + + let-inline ctx \SATySFi = let size = get-font-size ctx in let f = read-inline ctx in @@ -27,7 +35,7 @@ let-inline ctx \SATySFi = let ib = f {SAT} ++ kern (size *' 0.15) ++ fd {Y} ++ f {SF} ++ kern (size *' 0.05) ++ fd {I} in - script-guard Latin ib + script-guard Latin (no-break ib) let-inline ctx \LaTeX = @@ -40,8 +48,11 @@ let-inline ctx \LaTeX = let fE = ctx |> set-manual-rising (0pt -' (size *' 0.25)) |> read-inline in + let ib = f {L} ++ kern (size *' 0.2) ++ fA {A} ++ f {T} ++ kern (size *' 0.125) ++ fE {E} ++ f {X} + in + script-guard Latin (no-break ib) let-inline ctx \TeX = @@ -50,7 +61,10 @@ let-inline ctx \TeX = let fE = ctx |> set-manual-rising (0pt -' (size *' 0.25)) |> read-inline in + let ib = f {T} ++ kern (size *' 0.125) ++ fE {E} ++ f {X} + in + script-guard Latin (no-break ib) let length-max len1 len2 = @@ -65,10 +79,6 @@ let length-abs len = if len <' 0pt then 0pt -' len else len -let-inline ctx \no-break inner = - inline-frame-outer (0pt, 0pt, 0pt, 0pt) (fun _ _ _ _ -> []) (read-inline ctx inner) - - let-inline ctx \fil = discretionary 0 inline-nil inline-fil inline-nil diff --git a/lib-satysfi/dist/packages/stdjabook.satyh b/lib-satysfi/dist/packages/stdjabook.satyh index 6fb681d5c..d4f5a9e94 100644 --- a/lib-satysfi/dist/packages/stdjabook.satyh +++ b/lib-satysfi/dist/packages/stdjabook.satyh @@ -4,6 +4,7 @@ @require: list @require: math @require: color +@require: footnote-scheme module StdJaBook : sig @@ -303,10 +304,6 @@ let title-deco = inline-fil ++ (repeat-inline n ib) - let-mutable footnote-ref <- 0 - let-mutable first-footnote <- true - - let document record inner = % -- constants -- let title = record#title in @@ -387,7 +384,7 @@ let title-deco = % -- page settings -- let pagecontf pbinfo = - let () = first-footnote <- true in + let () = FootnoteScheme.start-page () in let hgtfb = height-of-float-boxes pbinfo#page-number in let (txtorgx, txtorgy) = txtorg in (| @@ -543,78 +540,27 @@ let title-deco = read-inline ctx-emph inner - let generate-footnote-label n = - `footnote:` ^ (arabic n) - - - let promote-another-trial () = - register-cross-reference `changed` `T` - - let-inline ctx \footnote it = - let () = footnote-ref <- !footnote-ref + 1 in - let num = !footnote-ref in - let label = generate-footnote-label num in - let it-num = embed-string (arabic num) in let size = get-font-size ctx in - let ib-num = + let ibf num = + let it-num = embed-string (arabic num) in let ctx = ctx |> set-font-size (size *' 0.75) |> set-manual-rising (size *' 0.25) in read-inline ctx {\*#it-num;} in - let (bb-before, top-margin) = - match get-cross-reference label with - | Some(`T`) -> - let () = display-message (`'` ^ label ^ `': T`) in % for debug - let bar-top-margin = size in - let bar-bottom-margin = 2pt in - let wid = get-text-width ctx in - let ib = - inline-graphics wid bar-top-margin bar-bottom-margin (fun (x, y) -> - [ stroke 0.5pt Color.black (Gr.line (x, y) (x +' wid, y)); ] - ) - in - (line-break false false (ctx |> set-paragraph-margin 0pt 0pt) ib, 0pt) - - | _ -> - let () = display-message (`'` ^ label ^ `': F`) in % for debug - (block-skip 0pt, size *' 0.5) - in - let bb = + let bbf num = + let it-num = embed-string (arabic num) in let ctx = ctx |> set-font-size (size *' 0.9) |> set-leading (size *' 1.2) - |> set-paragraph-margin top-margin (size *' 0.5) + |> set-paragraph-margin (size *' 0.5) (size *' 0.5) %temporary in line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil) in - let pads = (0pt, 0pt, 0pt, 0pt) in - let deco _ _ _ _ = [] in - inline-frame-inner pads deco - (add-footnote (bb-before +++ bb) ++ ib-num - ++ hook-page-break (fun _ _ -> ( - let () = - if !first-footnote then - match get-cross-reference label with - | Some(`T`) -> - () - - | _ -> - let () = promote-another-trial () in - register-cross-reference label `T` - else - match get-cross-reference label with - | Some(`F`) -> - () - - | _ -> - let () = promote-another-trial () in - register-cross-reference label `F` - in - first-footnote <- false))) + FootnoteScheme.main ctx ibf bbf end From e4d1d3fedf8c3f8eb04327eea2c4e923c1c7a1da Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 18 Aug 2018 22:54:45 +0900 Subject: [PATCH 49/78] update package 'code.satyh' --- lib-satysfi/dist/packages/code.satyh | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lib-satysfi/dist/packages/code.satyh b/lib-satysfi/dist/packages/code.satyh index 7ce2c6021..1d9d4623d 100644 --- a/lib-satysfi/dist/packages/code.satyh +++ b/lib-satysfi/dist/packages/code.satyh @@ -8,6 +8,7 @@ module Code : sig direct +code : [string] block-cmd direct +console : [string] block-cmd direct \code : [string] inline-cmd + direct \console : [string] inline-cmd direct \d-code : [string] inline-cmd end = struct @@ -106,13 +107,18 @@ end = struct code-scheme decoset-code Color.black ctx code + let-inline ctx \d-code code = + inline-fil ++ embed-block-breakable ctx + (read-block ctx '<+code(code);>) + + let-block ctx +console code = code-scheme decoset-console Color.white ctx code - let-inline ctx \d-code code = + let-inline ctx \console code = inline-fil ++ embed-block-breakable ctx - (read-block ctx '<+code(code);>) + (read-block ctx '<+console(code);>) let-inline ctx \code code = From 81e7061170339cf11463f3c7b4ecd667f1a94176 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 23 Aug 2018 17:21:26 +0900 Subject: [PATCH 50/78] update 'math.satyh' --- lib-satysfi/dist/packages/math.satyh | 73 +++++++++++++++++++++++++--- 1 file changed, 66 insertions(+), 7 deletions(-) diff --git a/lib-satysfi/dist/packages/math.satyh b/lib-satysfi/dist/packages/math.satyh index 3840ea7b6..f32b7cc16 100644 --- a/lib-satysfi/dist/packages/math.satyh +++ b/lib-satysfi/dist/packages/math.satyh @@ -395,8 +395,8 @@ module Math : sig val paren-left : paren val paren-right : paren - val angle-left : paren - val angle-right : paren + val angle-left : length -> paren + val angle-right : length -> paren val brace-left : paren val brace-right : paren val sqbracket-left : paren @@ -410,6 +410,8 @@ module Math : sig val norm-left : paren val norm-right : paren val empty-paren : paren + val bar-middle : paren + val slash-middle : paren % -- temporary -- direct \synteq : [] math-cmd @@ -1011,7 +1013,7 @@ end = struct let lenappend = fontsize *' 0.1 in length-max minhalflen ((length-max (hgt -' hgtaxis) (hgtaxis +' dpt)) +' lenappend) - let angle-left hgt dpt hgtaxis fontsize color = + let angle-left thk hgt dpt hgtaxis fontsize color = let halflen = half-length hgt dpt hgtaxis fontsize in let widparen = halflen *' 0.375 in let wid = widparen +' fontsize *' 0.1 in @@ -1021,7 +1023,7 @@ end = struct |> line-to (xpos +' wid, ypos +' hgtaxis -' halflen) |> terminate-path in - let graphics point = [ stroke 0.5pt color (path point); ] in + let graphics point = [ stroke thk color (path point); ] in let kerninfo y = let widkern = widparen in let r = 0. in @@ -1033,7 +1035,7 @@ end = struct in (inline-graphics wid (hgtaxis +' halflen) (halflen -' hgtaxis) graphics, kerninfo) - let angle-right hgt dpt hgtaxis fontsize color = + let angle-right thk hgt dpt hgtaxis fontsize color = let halflen = half-length hgt dpt hgtaxis fontsize in let widparen = halflen *' 0.375 in let wid = widparen +' fontsize *' 0.1 in @@ -1043,7 +1045,7 @@ end = struct |> line-to (xpos, ypos +' hgtaxis -' halflen) |> terminate-path in - let graphics point = [ stroke 0.5pt color (path point); ] in + let graphics point = [ stroke thk color (path point); ] in let kerninfo y = let widkern = widparen in let r = 0. in @@ -1056,7 +1058,7 @@ end = struct (inline-graphics wid (hgtaxis +' halflen) (halflen -' hgtaxis) graphics, kerninfo) let-math \angle-bracket = - math-paren angle-left angle-right + math-paren (angle-left 0.5pt) (angle-right 0.5pt) let paren-left hgt dpt hgtaxis fontsize color = let halflen = half-length hgt dpt hgtaxis fontsize in @@ -1296,6 +1298,53 @@ end = struct (inline-graphics x4 (hgtaxis +' halflen) (halflen -' hgtaxis) graphics, kerninfo) + let brace-left-long hgt dpt hgtaxis fontsize color = + let halflen = half-length hgt dpt hgtaxis fontsize in + + let t0B = fontsize *' 0.05 in + let t1A = fontsize *' 0.05 in + let t1B = fontsize *' 0.025 in + let t2A = halflen *' 0.1 in + let t2B = halflen *' 0.15 in + let t3A = fontsize *' 0.05 in + + let (x0, y0) = (fontsize *' 0.005, fontsize *' 0.005) in + let (p0B, q0B) = (x0 +' t0B, y0) in + + let (x1, y1) = (fontsize *' 0.2, fontsize *' 0.2) in + let (p1A, q1A) = (x1, y1 -' t1A) in + let (p1B, q1B) = (x1, y1 +' t1B) in + + let theta = atan2 (x1 /' 1pt) (halflen /' 1pt) in + + let (x2, y2) = (fontsize *' 0.175, halflen *' 0.5) in + + let (p2A, q2A) = (x2 +' t2A *' (sin theta), y2 -' t2A *' (cos theta)) in + let (p2B, q2B) = (x2 -' t2B *' (sin theta), y2 +' t2B *' (cos theta)) in + + let (x3, y3) = (fontsize *' 0.15, halflen -' fontsize *' 0.2) in + + let (p3A, q3A) = (x3, y3 -' t3A) in + + let path (xpos, ypos) = + let ycenter = ypos +' hgtaxis in + let fP (x, y) = (xpos +' x, ycenter +' y) in + let fN (x, y) = (xpos +' x, ycenter -' y) in +% start-path (fP (x0, y0)) +% |> bezier-to (fP (p0B, q0B)) (fP (p1A, q1A)) (fP (x1, y1)) +% |> bezier-to (fP (p1B, q1B)) (fP (p2A, q2A)) (fP (x2, y2)) +% |> close-with-line + Gr.poly-line (fP (x0, y0)) [ + fP (p0B, q0B); fP (p1A, q1A); fP (x1, y1); + fP (p1B, q1B); fP (p2A, q2A); fP (x2, y2); + fP (p2B, q2B); fP (p3A, q3A); fP (x3, y3); + ] + in + let graphics point = [ fill color (path point); ] in + let kerninfo _ = 0pt in + (inline-graphics (x2) (hgtaxis +' halflen) (halflen -' hgtaxis) graphics, kerninfo) + + let-math \brace = math-paren brace-left brace-right @@ -1314,6 +1363,16 @@ end = struct math-paren-with-middle brace-left brace-right bar-middle [m1; m2] + let slash-middle hgt dpt hgtaxis fontsize color = + let halflen = half-length hgt dpt hgtaxis fontsize in + let halfwid = halflen *' 0.5 in + let graphics (x, y) = + [ stroke 0.5pt color (Gr.line (x, y +' hgtaxis -' halflen) (x +' halfwid *' 2., y +' hgtaxis +' halflen)); ] + in + let kerninfo _ = 0pt in + (inline-graphics (halfwid *' 2.) (hgtaxis +' halflen) (halflen -' hgtaxis) graphics, kerninfo) + + let bracket-metrics fontsize halflen = let w0 = fontsize *' 0.1 in let w1 = fontsize *' 0.05 +' halflen *' 0.005 in From 9c784df0ec6142ae9964cae8b29597d9466bda4f Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 23 Aug 2018 17:22:10 +0900 Subject: [PATCH 51/78] extend 'itemize.satyh' --- lib-satysfi/dist/packages/itemize.satyh | 68 +++++++++++++++++++------ 1 file changed, 53 insertions(+), 15 deletions(-) diff --git a/lib-satysfi/dist/packages/itemize.satyh b/lib-satysfi/dist/packages/itemize.satyh index 665d95a18..421904e7f 100644 --- a/lib-satysfi/dist/packages/itemize.satyh +++ b/lib-satysfi/dist/packages/itemize.satyh @@ -1,10 +1,12 @@ +@require: pervasives @require: list +@require: option @require: gr module Itemize : sig - direct +listing : [itemize] block-cmd - direct \listing : [itemize] inline-cmd + direct +listing : [bool?; itemize] block-cmd + direct \listing : [bool?; itemize] inline-cmd direct +enumerate : [itemize] block-cmd direct \enumerate : [itemize] inline-cmd @@ -28,31 +30,67 @@ end = struct let-rec listing-item : context -> int -> itemize -> block-boxes | ctx depth (Item(parent, children)) = let color = get-text-color ctx in - let br-bullet = (inline-graphics 8pt 8pt 0pt (bullet color)) ++ (inline-skip 8pt) in - let bullet-width = get-natural-width br-bullet in + let ib-bullet = inline-graphics 8pt 8pt 0pt (bullet color) ++ inline-skip 8pt in + let bullet-width = get-natural-width ib-bullet in let parent-indent = item-indent *' (float depth) in - let br-parent = + let ib-parent = embed-block-top ctx ((get-text-width ctx) -' parent-indent -' bullet-width) (fun ctx -> form-paragraph (ctx |> set-paragraph-margin item-gap item-gap) (read-inline ctx parent ++ inline-fil) ) in - let bc-parent = + let bb-parent = form-paragraph (ctx |> set-paragraph-margin item-gap item-gap) - ((inline-skip parent-indent) ++ br-bullet ++ br-parent) + ((inline-skip parent-indent) ++ ib-bullet ++ ib-parent) in - let bclst-children = List.map (listing-item ctx (depth + 1)) children in - bc-parent +++> bclst-children + let bblst-children = List.map (listing-item ctx (depth + 1)) children in + bb-parent +++> bblst-children - let-block ctx +listing (Item(_, itmzlst)) = - let bclst = List.map (listing-item ctx 0) itmzlst in - block-skip item-gap-top +++ (block-nil +++> bclst) + let-rec listing-item-breakable + | ctx depth (Item(parent, children)) = + let color = get-text-color ctx in + let ib-bullet = inline-graphics 8pt 8pt 0pt (bullet color) ++ inline-skip 8pt in + let bullet-width = get-natural-width ib-bullet in + let parent-indent = item-indent *' (float depth) in + let pads = (parent-indent +' bullet-width, 0pt, 0pt, 0pt) in + let decos = + let deco _ _ _ _ = [] in + (deco, deco, deco, deco) + in + let bb-parent = + block-nil +++> [ +% line-break true false (ctx |> set-paragraph-margin item-gap 0pt) inline-fil; + block-frame-breakable ctx pads decos (fun ctx -> + form-paragraph ctx + (inline-skip (0pt -' bullet-width) ++ ib-bullet + ++ read-inline ctx parent ++ inline-fil) + ); +% line-break true false (ctx |> set-paragraph-margin 0pt item-gap) inline-fil; + ] + in + let bblst-children = List.map (listing-item ctx (depth + 1)) children in + bb-parent +++> bblst-children - let-inline ctx \listing item = - inline-fil ++ - embed-block-breakable ctx (read-block ctx '<+listing(item);>) + let listing break ctx (Item(_, itmzlst)) = + if break then + let bblst = List.map (listing-item-breakable ctx 0) itmzlst in + block-skip item-gap-top +++ (block-nil +++> bblst) + else + let bblst = List.map (listing-item ctx 0) itmzlst in + block-skip item-gap-top +++ (block-nil +++> bblst) + + + let-block ctx +listing ?:breakopt item = + let break = Option.from false breakopt in + listing break ctx item + + + let-inline ctx \listing ?:breakopt item = + let break = Option.from false breakopt in + inline-fil ++ + embed-block-breakable ctx (listing break ctx item) let-rec enumerate-item : int -> context -> int -> itemize -> block-boxes From 4609dd56ca178c020f280fde9b4a0673425a6eb3 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 23 Aug 2018 17:30:10 +0900 Subject: [PATCH 52/78] update 'itemize.satyh' --- lib-satysfi/dist/packages/itemize.satyh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib-satysfi/dist/packages/itemize.satyh b/lib-satysfi/dist/packages/itemize.satyh index 421904e7f..d197d23e8 100644 --- a/lib-satysfi/dist/packages/itemize.satyh +++ b/lib-satysfi/dist/packages/itemize.satyh @@ -61,7 +61,7 @@ end = struct let bb-parent = block-nil +++> [ % line-break true false (ctx |> set-paragraph-margin item-gap 0pt) inline-fil; - block-frame-breakable ctx pads decos (fun ctx -> + block-frame-breakable (ctx |> set-paragraph-margin item-gap item-gap) pads decos (fun ctx -> form-paragraph ctx (inline-skip (0pt -' bullet-width) ++ ib-bullet ++ read-inline ctx parent ++ inline-fil) From b5d5e956e763db82e1d2d406cd40b2f136f72196 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 25 Aug 2018 15:40:42 +0900 Subject: [PATCH 53/78] update 'tabular.satyh' and add 'tabularx.satyh' --- doc/tabular.satyh | 46 ++++++++++++++++++++---- lib-satysfi/dist/packages/tabularx.satyh | 41 +++++++++++++++++++++ 2 files changed, 81 insertions(+), 6 deletions(-) create mode 100644 lib-satysfi/dist/packages/tabularx.satyh diff --git a/doc/tabular.satyh b/doc/tabular.satyh index 32419574c..ee94c3a8b 100644 --- a/doc/tabular.satyh +++ b/doc/tabular.satyh @@ -1,7 +1,41 @@ +@require: option -let-inline ctx \tabular lstf = - let pads = (5pt, 5pt, 2pt, 10pt) in - let cellf it = NormalCell(pads, inline-fil ++ (read-inline ctx it) ++ inline-fil) in - let multif nr nc it = MultiCell(nr, nc, pads, inline-fil ++ (read-inline ctx it) ++ inline-fil) in - let empty = EmptyCell in - tabular (lstf cellf multif empty) +type cell-record = + (| + left : bool; + right : bool; + |) + + +module Tabular : sig + + direct \tabular : [ + (cell-record option -> inline-text -> cell) -> + (cell-record option -> int -> int -> inline-text -> cell) -> + cell -> + (cell list) list; + length list -> length list -> graphics list; + ] inline-cmd + +end = struct + + let make-alignments ropt = + let r = Option.from (| right = true; left = true; |) ropt in + let f b = if b then inline-fil else inline-nil in + (f r#left, f r#right) + + + let-inline ctx \tabular lstf = + let pads = (5pt, 5pt, 2pt, 10pt) in + let cellf ropt it = + let (alignL, alignR) = make-alignments ropt in + NormalCell(pads, alignL ++ read-inline ctx it ++ alignR) + in + let multif ropt nr nc it = + let (alignL, alignR) = make-alignments ropt in + MultiCell(nr, nc, pads, alignL ++ (read-inline ctx it) ++ alignR) + in + let empty = EmptyCell in + tabular (lstf cellf multif empty) + +end diff --git a/lib-satysfi/dist/packages/tabularx.satyh b/lib-satysfi/dist/packages/tabularx.satyh new file mode 100644 index 000000000..9fac6fef7 --- /dev/null +++ b/lib-satysfi/dist/packages/tabularx.satyh @@ -0,0 +1,41 @@ +@require: option + +type cell-record = + (| + left : bool; + right : bool; + |) + + +module Tabular : sig + + direct \tabular : [ + (cell-record option -> inline-text -> cell) -> + (cell-record option -> int -> int -> inline-text -> cell) -> + cell -> + (cell list) list; + length list -> length list -> graphics list; + ] inline-cmd + +end = struct + + let make-alignments ropt = + let r = Option.from (| right = true; left = true; |) ropt in + let f b = if b then inline-fil else inline-nil in + (f r#left, f r#right) + + + let-inline ctx \tabular lstf = + let pads = (5pt, 5pt, 2pt, 2pt) in + let cellf ropt it = + let (alignL, alignR) = make-alignments ropt in + NormalCell(pads, alignL ++ read-inline ctx it ++ alignR) + in + let multif ropt nr nc it = + let (alignL, alignR) = make-alignments ropt in + MultiCell(nr, nc, pads, alignL ++ (read-inline ctx it) ++ alignR) + in + let empty = EmptyCell in + tabular (lstf cellf multif empty) + +end From 07bccc1d91bdf45cc54f47f0cc6cd0d9d55fc626 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 28 Aug 2018 21:37:50 +0900 Subject: [PATCH 54/78] add math primitives and types to the text mode --- src/frontend/bytecomp/vminstdef.yaml | 21 +++++++++++++ src/frontend/primitives_.cppo.ml | 44 ++++++++++++++-------------- 2 files changed, 43 insertions(+), 22 deletions(-) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 4f772ce60..1fa738173 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -636,6 +636,7 @@ code: | --- inst: PrimitiveSetMathVariantToChar is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "set-math-variant-char" type: | ~% (tMCCLS @-> tI @-> tI @-> tCTX @-> tCTX) @@ -685,6 +686,7 @@ code: | --- inst: BackendMathVariantCharDirect is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-variant-char" type: | ~% (tMATHCLS @-> tMCSTY @-> tMATH) @@ -700,6 +702,7 @@ code: | --- inst: BackendGetLeftMathClass is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "get-left-math-class" type: | ~% (tCTX @-> tMATH @-> tOPT tMATHCLS) @@ -719,6 +722,7 @@ code: | --- inst: BackendGetRightMathClass is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "get-right-math-class" type: | ~% (tCTX @-> tMATH @-> tOPT tMATHCLS) @@ -756,6 +760,7 @@ code: | --- inst: BackendMathConcat is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-concat" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -769,6 +774,7 @@ code: | --- inst: BackendMathGroup is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-group" type: | ~% (tMATHCLS @-> tMATHCLS @-> tMATH @-> tMATH) @@ -783,6 +789,7 @@ code: | --- inst: BackendMathSuperscript is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-sup" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -796,6 +803,7 @@ code: | --- inst: BackendMathSubscript is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-sub" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -809,6 +817,7 @@ code: | --- inst: BackendMathFraction is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-frac" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -822,6 +831,7 @@ code: | --- inst: BackendMathRadical is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-radical" type: | ~% (tOPT tMATH @-> tMATH @-> tMATH) @@ -839,6 +849,7 @@ code: | --- inst: BackendMathParen is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-paren" type: | ~% (tPAREN @-> tPAREN @-> tMATH @-> tMATH) @@ -856,6 +867,7 @@ code: | --- inst: BackendMathParenWithMiddle is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-paren-with-middle" type: | ~% (tPAREN @-> tPAREN @-> tPAREN @-> tL tMATH @-> tMATH) @@ -875,6 +887,7 @@ code: | --- inst: BackendMathUpperLimit is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-upper" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -888,6 +901,7 @@ code: | --- inst: BackendMathLowerLimit is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-lower" type: | ~% (tMATH @-> tMATH @-> tMATH) @@ -901,6 +915,7 @@ code: | --- inst: BackendMathPullInScripts is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-pull-in-scripts" type: | ~% (tMATHCLS @-> tMATHCLS @-> (tOPT tMATH @-> tOPT tMATH @-> tMATH) @-> tMATH) @@ -918,6 +933,7 @@ code: | --- inst: BackendMathChar is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-char" type: | ~% (tMATHCLS @-> tS @-> tMATH) @@ -932,6 +948,7 @@ code: | --- inst: BackendMathBigChar is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-big-char" type: | ~% (tMATHCLS @-> tS @-> tMATH) @@ -946,6 +963,7 @@ code: | --- inst: BackendMathCharWithKern is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-char-with-kern" type: | let mckf = tLN @-> tLN @-> tLN in @@ -966,6 +984,7 @@ code: | --- inst: BackendMathBigCharWithKern is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-big-char-with-kern" type: | let mckf = tLN @-> tLN @-> tLN in @@ -1004,6 +1023,7 @@ code: | --- inst: BackendMathColor is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-color" type: | ~% (tCLR @-> tMATH @-> tMATH) @@ -1017,6 +1037,7 @@ code: | --- inst: BackendMathCharClass is-pdf-mode-primitive: yes +is-text-mode-primitive: yes name: "math-char-class" type: | ~% (tMCCLS @-> tMATH @-> tMATH) diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 16722c749..e2cd21c4e 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -152,6 +152,28 @@ let add_general_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.register_type "itemize" tyid_itemize (Typeenv.Data(0)) |> Typeenv.Raw.add_constructor "Item" ([], Poly(tPROD [tIT; tL (tITMZ ())])) tyid_itemize + |> Typeenv.Raw.register_type "math-class" tyid_mathcls (Typeenv.Data(0)) + |> Typeenv.Raw.add_constructor "MathOrd" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathBin" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathRel" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathOp" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathPunct" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathOpen" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathClose" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathPrefix" ([], Poly(tU)) tyid_mathcls + |> Typeenv.Raw.add_constructor "MathInner" ([], Poly(tU)) tyid_mathcls + + |> Typeenv.Raw.register_type "math-char-class" tyid_mccls (Typeenv.Data(0)) + |> Typeenv.Raw.add_constructor "MathItalic" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathBoldItalic" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathRoman" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathBoldRoman" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathScript" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathBoldScript" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathFraktur" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathBoldFraktur" ([], Poly(tU)) tyid_mccls + |> Typeenv.Raw.add_constructor "MathDoubleStruck" ([], Poly(tU)) tyid_mccls + let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = @@ -183,28 +205,6 @@ let add_pdf_mode_default_types (tyenvmid : Typeenv.t) : Typeenv.t = |> Typeenv.Raw.add_constructor "USLegal" ([], Poly(tU)) tyid_page |> Typeenv.Raw.add_constructor "UserDefinedPaper" ([], Poly(tPROD [tLN; tLN])) tyid_page - |> Typeenv.Raw.register_type "math-class" tyid_mathcls (Typeenv.Data(0)) - |> Typeenv.Raw.add_constructor "MathOrd" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathBin" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathRel" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathOp" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathPunct" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathOpen" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathClose" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathPrefix" ([], Poly(tU)) tyid_mathcls - |> Typeenv.Raw.add_constructor "MathInner" ([], Poly(tU)) tyid_mathcls - - |> Typeenv.Raw.register_type "math-char-class" tyid_mccls (Typeenv.Data(0)) - |> Typeenv.Raw.add_constructor "MathItalic" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathBoldItalic" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathRoman" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathBoldRoman" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathScript" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathBoldScript" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathFraktur" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathBoldFraktur" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.add_constructor "MathDoubleStruck" ([], Poly(tU)) tyid_mccls - |> Typeenv.Raw.register_type "cell" tyid_cell (Typeenv.Data(0)) |> Typeenv.Raw.add_constructor "NormalCell" ([], Poly(tPROD [tPADS; tIB])) tyid_cell |> Typeenv.Raw.add_constructor "EmptyCell" ([], Poly(tU)) tyid_cell From a8e7dd44696582699577c8f3d5dc9a96a370dab0 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 28 Aug 2018 22:16:14 +0900 Subject: [PATCH 55/78] change interface of 'GraphicD' --- src/backend/graphicD.ml | 4 ++-- src/backend/graphicD.mli | 2 +- src/backend/handlePdf.ml | 19 ++++++++++++++----- 3 files changed, 17 insertions(+), 8 deletions(-) diff --git a/src/backend/graphicD.ml b/src/backend/graphicD.ml index 80a9d80fb..9de1bf2a5 100644 --- a/src/backend/graphicD.ml +++ b/src/backend/graphicD.ml @@ -258,10 +258,10 @@ let pdfops_test_box color (xpos, ypos) wid hgt = (* -- 'pdfops_test_frame': output bounding box of horizontal elements for debugging -- *) -let pdfops_test_frame (xpos, yposbaseline) wid hgt dpt = +let pdfops_test_frame color (xpos, yposbaseline) wid hgt dpt = [ op_q; - op_RG (1.0, 0.5, 0.5); + pdfop_of_stroke_color color; op_w (Length.of_pdf_point 0.1); op_m (xpos, yposbaseline); op_l (xpos +% wid, yposbaseline); diff --git a/src/backend/graphicD.mli b/src/backend/graphicD.mli index e46608880..e5d841f7b 100644 --- a/src/backend/graphicD.mli +++ b/src/backend/graphicD.mli @@ -33,6 +33,6 @@ val pdfops_of_image : point -> float -> float -> string -> Pdfops.t list val pdfops_test_box : color -> point -> length -> length -> Pdfops.t list -val pdfops_test_frame : point -> length -> length -> length -> Pdfops.t list +val pdfops_test_frame : color -> point -> length -> length -> length -> Pdfops.t list val to_pdfops : 'a t -> (point -> 'a -> Pdfops.t list) -> Pdfops.t list diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index bf0f8b801..c16007791 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -8,13 +8,18 @@ type t = | PDF of Pdf.t * Pdfpage.t Alist.t * file_path +let color_show_space = GraphicBase.DeviceRGB(0., 0., 1.) +let color_show_bbox = GraphicBase.DeviceRGB(1.0, 0.5, 0.5) + + let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, opacc) (evhb : evaled_horz_box) = let (wid, evhbmain) = evhb in match evhbmain with | EvHorzEmpty -> let opaccnew = if OptionState.debug_show_space () then - Alist.append opacc (GraphicD.pdfops_test_box (GraphicBase.DeviceRGB(0., 0., 1.)) (xpos, yposbaseline) wid (Length.of_pdf_point 2.)) + let opsgr = GraphicD.pdfops_test_box color_show_space (xpos, yposbaseline) wid (Length.of_pdf_point 2.) in + Alist.append opacc opsgr else opacc in @@ -25,7 +30,8 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op deco (xpos, yposbaseline) wid hgt_frame dpt_frame (* -- depth values are nonpositive -- *) in - let opaccinit = Alist.append opacc (GraphicD.to_pdfops gr_background (pdfops_of_intermediate_horz_box_list pbinfo)) in + let opsgr = GraphicD.to_pdfops gr_background (pdfops_of_intermediate_horz_box_list pbinfo) in + let opaccinit = Alist.append opacc opsgr in let (xposnew, opaccsub) = imhblst @|> (xpos, opaccinit) @|> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) in @@ -41,7 +47,8 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op hsinfo.rising tag hsinfo.text_font_size hsinfo.text_color otxt in if OptionState.debug_show_bbox () then - List.append (GraphicD.pdfops_test_frame (xpos, yposbaseline) wid hgt dpt) opsmain + let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + List.append opsgr opsmain else opsmain in @@ -56,7 +63,8 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op Length.zero tag msinfo.math_font_size msinfo.math_color otxt in if OptionState.debug_show_bbox () then - List.append (GraphicD.pdfops_test_frame (xpos, yposbaseline) wid hgt dpt) opsmain + let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + List.append opsgr opsmain else opsmain in @@ -88,7 +96,8 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op let opaccsub = Alist.append opacc (pdfops_of_graphics pbinfo gr) in let opaccnew = if OptionState.debug_show_bbox () then - Alist.append opaccsub (GraphicD.pdfops_test_frame (xpos, yposbaseline) wid hgt dpt) + let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + Alist.append opaccsub opsgr else opaccsub in From f50964291044abfa9d0989a9b2df52b92f799692 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 28 Aug 2018 22:47:39 +0900 Subject: [PATCH 56/78] abstract implementation of 'HandlePdf' by using 'op_funcs' --- src/backend/handlePdf.ml | 88 ++++++++++++++++++++++++---------------- 1 file changed, 53 insertions(+), 35 deletions(-) diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index c16007791..a8606ebc2 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -1,6 +1,7 @@ open MyUtil open LengthInterface +open GraphicBase open HorzBox @@ -8,17 +9,35 @@ type t = | PDF of Pdf.t * Pdfpage.t Alist.t * file_path -let color_show_space = GraphicBase.DeviceRGB(0., 0., 1.) -let color_show_bbox = GraphicBase.DeviceRGB(1.0, 0.5, 0.5) +type 'o op_funcs = { + graphics : (intermediate_horz_box list) GraphicD.t -> (point -> intermediate_horz_box list -> 'o list) -> 'o list; + text : point -> length -> string -> length -> color -> OutputText.t -> 'o list; + image : point -> float -> float -> string -> 'o list; + test_box : color -> point -> length -> length -> 'o list; + test_frame : color -> point -> length -> length -> length -> 'o list; +} -let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, opacc) (evhb : evaled_horz_box) = +let fs_pdf = { + graphics = GraphicD.to_pdfops; + text = GraphicD.pdfops_of_text; + image = GraphicD.pdfops_of_image; + test_box = GraphicD.pdfops_test_box; + test_frame = GraphicD.pdfops_test_frame; +} + + +let color_show_space = DeviceRGB(0.0, 0.0, 1.0) +let color_show_bbox = DeviceRGB(1.0, 0.5, 0.5) + + +let rec ops_of_evaled_horz_box (fs : 'o op_funcs) (pbinfo : page_break_info) yposbaseline (xpos, opacc) (evhb : evaled_horz_box) = let (wid, evhbmain) = evhb in match evhbmain with | EvHorzEmpty -> let opaccnew = if OptionState.debug_show_space () then - let opsgr = GraphicD.pdfops_test_box color_show_space (xpos, yposbaseline) wid (Length.of_pdf_point 2.) in + let opsgr = fs.test_box color_show_space (xpos, yposbaseline) wid (Length.of_pdf_point 2.) in Alist.append opacc opsgr else opacc @@ -30,10 +49,10 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op deco (xpos, yposbaseline) wid hgt_frame dpt_frame (* -- depth values are nonpositive -- *) in - let opsgr = GraphicD.to_pdfops gr_background (pdfops_of_intermediate_horz_box_list pbinfo) in + let opsgr = fs.graphics gr_background (pdfops_of_intermediate_horz_box_list fs pbinfo) in let opaccinit = Alist.append opacc opsgr in let (xposnew, opaccsub) = - imhblst @|> (xpos, opaccinit) @|> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) + imhblst @|> (xpos, opaccinit) @|> List.fold_left (ops_of_evaled_horz_box fs pbinfo yposbaseline) in let ops_foreground = [] in (* temporary *) let opaccnew = Alist.append opaccsub ops_foreground in @@ -43,11 +62,11 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op let tag = FontInfo.get_font_tag hsinfo.font_abbrev in let ops = let opsmain = - GraphicD.pdfops_of_text (xpos, yposbaseline) + fs.text (xpos, yposbaseline) hsinfo.rising tag hsinfo.text_font_size hsinfo.text_color otxt in if OptionState.debug_show_bbox () then - let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + let opsgr = fs.test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in List.append opsgr opsmain else opsmain @@ -59,11 +78,11 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op let tag = FontInfo.get_math_tag msinfo.math_font_abbrev in let ops = let opsmain = - GraphicD.pdfops_of_text (xpos, yposbaseline) + fs.text (xpos, yposbaseline) Length.zero tag msinfo.math_font_size msinfo.math_color otxt in if OptionState.debug_show_bbox () then - let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + let opsgr = fs.test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in List.append opsgr opsmain else opsmain @@ -73,7 +92,7 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op | EvHorzRising(hgt, dpt, lenrising, evhblst) -> let (_, opaccsub) = - evhblst |> List.fold_left (ops_of_evaled_horz_box pbinfo (yposbaseline +% lenrising)) (xpos, opacc) + evhblst |> List.fold_left (ops_of_evaled_horz_box fs pbinfo (yposbaseline +% lenrising)) (xpos, opacc) in let opaccnew = (* @@ -86,17 +105,18 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op (xpos +% wid, opaccnew) | EvHorzEmbeddedVert(hgt, dpt, evvblst) -> - let ((_, _), opaccnew) = ops_of_evaled_vert_box_list pbinfo (xpos, yposbaseline +% hgt) opacc evvblst in + let ((_, _), opaccnew) = ops_of_evaled_vert_box_list fs pbinfo (xpos, yposbaseline +% hgt) opacc evvblst in (xpos +% wid, opaccnew) | EvHorzInlineGraphics(hgt, dpt, graphics) -> let gr = graphics (xpos, yposbaseline) in - let opaccsub = Alist.append opacc (pdfops_of_graphics pbinfo gr) in + let opsgr = pdfops_of_graphics fs pbinfo gr in + let opaccsub = Alist.append opacc opsgr in let opaccnew = if OptionState.debug_show_bbox () then - let opsgr = GraphicD.pdfops_test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in + let opsgr = fs.test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in Alist.append opaccsub opsgr else opaccsub @@ -105,7 +125,7 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op | EvHorzInlineTabular(hgt, dpt, evtabular, widlst, lenlst, rulesf) -> let ops_tabular = - ops_of_evaled_tabular pbinfo (xpos, yposbaseline +% hgt) evtabular + ops_of_evaled_tabular fs pbinfo (xpos, yposbaseline +% hgt) evtabular in let (xacc, _) = widlst |> List.fold_left (fun (xacc, x) w -> @@ -121,7 +141,7 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op ) (Alist.extend Alist.empty yinit, yinit) in let gr = rulesf (Alist.to_list xacc) (Alist.to_list yacc) in - let ops_rules = pdfops_of_graphics pbinfo gr in + let ops_rules = pdfops_of_graphics fs pbinfo gr in let opaccnew = Alist.append (Alist.append opacc ops_tabular) ops_rules in (xpos +% wid, opaccnew) @@ -129,10 +149,7 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op let tag = ImageInfo.get_tag imgkey in let (xratio, yratio) = ImageInfo.get_ratio imgkey wid hgt in let ops_image = -(* - List.append (GraphicD.pdfops_test_frame (xpos, yposbaseline) wid hgt Length.zero) -*) - (GraphicD.pdfops_of_image (xpos, yposbaseline) xratio yratio tag) + fs.image (xpos, yposbaseline) xratio yratio tag in let opaccnew = Alist.append opacc ops_image in (xpos +% wid, opaccnew) @@ -142,7 +159,7 @@ let rec ops_of_evaled_horz_box (pbinfo : page_break_info) yposbaseline (xpos, op (xpos +% wid, opacc) -and ops_of_evaled_tabular (pbinfo : page_break_info) point evtabular = +and ops_of_evaled_tabular (fs : 'o op_funcs) (pbinfo : page_break_info) point evtabular = let (opaccnew, _) = evtabular |> List.fold_left (fun (opacc, (xpos, ypos)) (vlen, evcelllst) -> let (opaccnew, _) = @@ -154,7 +171,7 @@ and ops_of_evaled_tabular (pbinfo : page_break_info) point evtabular = | EvNormalCell((wid, hgt, dpt), evhblst) -> let yposbaseline = ypos -% hgt in let (_, opaccsub) = - evhblst |> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) (xpos, opacc) + evhblst |> List.fold_left (ops_of_evaled_horz_box fs pbinfo yposbaseline) (xpos, opacc) in let opaccnew = (* @@ -167,7 +184,7 @@ and ops_of_evaled_tabular (pbinfo : page_break_info) point evtabular = | EvMultiCell((_, _, widsingle, widcell, hgt, dpt), evhblst) -> let yposbaseline = ypos -% hgt in let (_, opaccsub) = - evhblst |> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) (xpos, opacc) + evhblst |> List.fold_left (ops_of_evaled_horz_box fs pbinfo yposbaseline) (xpos, opacc) in let opaccnew = (* @@ -185,7 +202,7 @@ and ops_of_evaled_tabular (pbinfo : page_break_info) point evtabular = Alist.to_list opaccnew -and ops_of_evaled_vert_box_list pbinfo (xinit, yinit) opaccinit evvblst = +and ops_of_evaled_vert_box_list (fs : 'o op_funcs) pbinfo (xinit, yinit) opaccinit evvblst = evvblst @|> ((xinit, yinit), opaccinit) @|> List.fold_left (fun ((xpos, ypos), opacc) evvb -> match evvb with | EvVertFixedEmpty(vskip) -> @@ -203,7 +220,7 @@ and ops_of_evaled_vert_box_list pbinfo (xinit, yinit) opaccinit evvblst = | EvVertLine(hgt, dpt, evhblst) -> let yposbaseline = ypos -% hgt in let (_, opaccend) = - evhblst @|> (xpos, opacc) @|> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) + evhblst @|> (xpos, opacc) @|> List.fold_left (ops_of_evaled_horz_box fs pbinfo yposbaseline) in (* (* begin: for debug *) @@ -219,25 +236,26 @@ and ops_of_evaled_vert_box_list pbinfo (xinit, yinit) opaccinit evvblst = | EvVertFrame(pads, _, deco, wid, evvblstsub) -> let xpossubinit = xpos +% pads.paddingL in let ypossubinit = ypos -% pads.paddingT in - let ((_, ypossub), opaccsub) = ops_of_evaled_vert_box_list pbinfo (xpossubinit, ypossubinit) Alist.empty evvblstsub in + let ((_, ypossub), opaccsub) = ops_of_evaled_vert_box_list fs pbinfo (xpossubinit, ypossubinit) Alist.empty evvblstsub in let yposend = ypossub -% pads.paddingB in let gr = deco (xpos, yposend) wid (ypos -% yposend) Length.zero in - let opaccframe = Alist.append opacc (pdfops_of_graphics pbinfo gr) in + let opsgr = pdfops_of_graphics fs pbinfo gr in + let opaccframe = Alist.append opacc opsgr in let opaccnew = Alist.append opaccframe (Alist.to_list opaccsub) in ((xpos, yposend), opaccnew) ) -and pdfops_of_intermediate_horz_box_list (pbinfo : page_break_info) ((xpos, yposbaseline) : point) (imhblst : intermediate_horz_box list) : Pdfops.t list = +and pdfops_of_intermediate_horz_box_list (fs : 'o op_funcs) (pbinfo : page_break_info) ((xpos, yposbaseline) : point) (imhblst : intermediate_horz_box list) : 'o list = let (evhblst, _) = PageInfo.embed_page_info pbinfo imhblst in let (_, opacc) = - evhblst |> List.fold_left (ops_of_evaled_horz_box pbinfo yposbaseline) (xpos, Alist.empty) + evhblst |> List.fold_left (ops_of_evaled_horz_box fs pbinfo yposbaseline) (xpos, Alist.empty) in Alist.to_list opacc -and pdfops_of_graphics (pbinfo : page_break_info) gr = - GraphicD.to_pdfops gr (pdfops_of_intermediate_horz_box_list pbinfo) +and pdfops_of_graphics (fs : 'o op_funcs) (pbinfo : page_break_info) gr = + fs.graphics gr (pdfops_of_intermediate_horz_box_list fs pbinfo) type contents = Pdfops.t Alist.t @@ -273,14 +291,14 @@ let make_page (pagesize : page_size) (pbinfo : page_break_info) (pagecontsch : p let (_, opaccbody) = let pt_init = invert_coordinate paper_height pagecontsch.page_content_origin in - ops_of_evaled_vert_box_list pbinfo pt_init Alist.empty evvblstbody + ops_of_evaled_vert_box_list fs_pdf pbinfo pt_init Alist.empty evvblstbody in let (_, opaccfootnote) = let hgtfootnote = get_height_of_evaled_vert_box_list evvblstfootnote in let (xorg, yorg) = pagecontsch.page_content_origin in let hgtreq = pagecontsch.page_content_height in let pt_init = invert_coordinate paper_height (xorg, yorg +% hgtreq -% hgtfootnote) in - ops_of_evaled_vert_box_list pbinfo pt_init Alist.empty evvblstfootnote + ops_of_evaled_vert_box_list fs_pdf pbinfo pt_init Alist.empty evvblstfootnote in let opaccpage = Alist.cat opaccbody opaccfootnote in Page(paper, pagecontsch, opaccpage, pbinfo) @@ -293,11 +311,11 @@ let write_page (Page(paper, pagecontsch, opaccpage, pbinfo) : page) (pagepartsf let pagepartssch = pagepartsf pbinfo in (* -- invokes the page-parts function -- *) let (evvblst_header, _) = pagepartssch.header_content |> PageInfo.embed_page_info_vert pbinfo in let pt_header = invert_coordinate paper_height pagepartssch.header_origin in - let (_, opacc_header) = ops_of_evaled_vert_box_list pbinfo pt_header opaccpage evvblst_header in + let (_, opacc_header) = ops_of_evaled_vert_box_list fs_pdf pbinfo pt_header opaccpage evvblst_header in let (evvblst_footer, _) = pagepartssch.footer_content |> PageInfo.embed_page_info_vert pbinfo in let pt_footer = invert_coordinate paper_height pagepartssch.footer_origin in - let (_, opacc_footer) = ops_of_evaled_vert_box_list pbinfo pt_footer opacc_header evvblst_footer in + let (_, opacc_footer) = ops_of_evaled_vert_box_list fs_pdf pbinfo pt_footer opacc_header evvblst_footer in let oplst = Alist.to_list opacc_footer in From 79ce730b376539c3bdab45ef4cd03c3ff8385164 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Wed, 29 Aug 2018 15:44:43 +0900 Subject: [PATCH 57/78] refactor 'HandlePdf' and 'GraphicD' --- src/backend/graphicD.ml | 7 +++---- src/backend/graphicD.mli | 2 +- src/backend/handlePdf.ml | 38 +++++++++++++++++++++++++------------- 3 files changed, 29 insertions(+), 18 deletions(-) diff --git a/src/backend/graphicD.ml b/src/backend/graphicD.ml index 9de1bf2a5..c4fe97c46 100644 --- a/src/backend/graphicD.ml +++ b/src/backend/graphicD.ml @@ -195,17 +195,17 @@ let pdfops_of_fill (fill_color : color) (pathlst : path list) : Pdfops.t list = List.concat [[op_q; op_fill_color]; ops_path; [op_draw; op_Q]] -let pdfops_of_text (pt : point) (rising : length) (tag : string) (fontsize : length) (color : color) (otxt : OutputText.t) = +let pdfops_of_text (pt : point) (tag : string) (fontsize : length) (color : color) (otxt : OutputText.t) = let pdfopstxt = (OutputText.to_TJ_arguments otxt) |> List.fold_left (fun acc (hopt, pdfobjs) -> let optxt = op_TJ (Pdf.Array(pdfobjs)) in match hopt with | None -> - Alist.append acc [op_Ts rising; optxt] + Alist.append acc [op_Ts Length.zero; optxt] | Some(FontFormat.PerMille(h)) -> let r = fontsize *% (float_of_int h *. 0.001) in - Alist.append acc [op_Ts (rising +% r); optxt] + Alist.append acc [op_Ts r; optxt] ) Alist.empty |> Alist.to_list in @@ -217,7 +217,6 @@ let pdfops_of_text (pt : point) (rising : length) (tag : string) (fontsize : len op_BT; op_Tm_translate pt; op_Tf tag fontsize; - op_Ts rising; ]; pdfopstxt; [ diff --git a/src/backend/graphicD.mli b/src/backend/graphicD.mli index e5d841f7b..25d60d7b1 100644 --- a/src/backend/graphicD.mli +++ b/src/backend/graphicD.mli @@ -27,7 +27,7 @@ val make_dashed_stroke : length -> dash -> color -> path list -> 'a element val make_text : point -> 'a -> 'a element -val pdfops_of_text : point -> length -> string -> length -> color -> OutputText.t -> Pdfops.t list +val pdfops_of_text : point -> string -> length -> color -> OutputText.t -> Pdfops.t list val pdfops_of_image : point -> float -> float -> string -> Pdfops.t list diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index a8606ebc2..9c0d12d18 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -11,17 +11,35 @@ type t = type 'o op_funcs = { graphics : (intermediate_horz_box list) GraphicD.t -> (point -> intermediate_horz_box list -> 'o list) -> 'o list; - text : point -> length -> string -> length -> color -> OutputText.t -> 'o list; - image : point -> float -> float -> string -> 'o list; + text : horz_string_info -> point -> OutputText.t -> 'o list; + math : math_string_info -> point -> OutputText.t -> 'o list; + image : ImageInfo.key -> point -> length -> length -> 'o list; test_box : color -> point -> length -> length -> 'o list; test_frame : color -> point -> length -> length -> length -> 'o list; } +let pdfops_of_text hsinfo pt otxt = + let tag = FontInfo.get_font_tag hsinfo.font_abbrev in + GraphicD.pdfops_of_text pt tag hsinfo.text_font_size hsinfo.text_color otxt + + +let pdfops_of_math msinfo pt otxt = + let tag = FontInfo.get_math_tag msinfo.math_font_abbrev in + GraphicD.pdfops_of_text pt tag msinfo.math_font_size msinfo.math_color otxt + + +let pdfops_of_image imgkey pt wid hgt = + let tag = ImageInfo.get_tag imgkey in + let (xratio, yratio) = ImageInfo.get_ratio imgkey wid hgt in + GraphicD.pdfops_of_image pt xratio yratio tag + + let fs_pdf = { graphics = GraphicD.to_pdfops; - text = GraphicD.pdfops_of_text; - image = GraphicD.pdfops_of_image; + text = pdfops_of_text; + math = pdfops_of_math; + image = pdfops_of_image; test_box = GraphicD.pdfops_test_box; test_frame = GraphicD.pdfops_test_frame; } @@ -59,11 +77,9 @@ let rec ops_of_evaled_horz_box (fs : 'o op_funcs) (pbinfo : page_break_info) ypo (xposnew, opaccnew) | EvHorzString(hsinfo, hgt, dpt, otxt) -> - let tag = FontInfo.get_font_tag hsinfo.font_abbrev in let ops = let opsmain = - fs.text (xpos, yposbaseline) - hsinfo.rising tag hsinfo.text_font_size hsinfo.text_color otxt + fs.text hsinfo (xpos, yposbaseline +% hsinfo.rising) otxt in if OptionState.debug_show_bbox () then let opsgr = fs.test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in @@ -75,11 +91,9 @@ let rec ops_of_evaled_horz_box (fs : 'o op_funcs) (pbinfo : page_break_info) ypo (xpos +% wid, opaccnew) | EvHorzMathGlyph(msinfo, hgt, dpt, otxt) -> - let tag = FontInfo.get_math_tag msinfo.math_font_abbrev in let ops = let opsmain = - fs.text (xpos, yposbaseline) - Length.zero tag msinfo.math_font_size msinfo.math_color otxt + fs.math msinfo (xpos, yposbaseline) otxt in if OptionState.debug_show_bbox () then let opsgr = fs.test_frame color_show_bbox (xpos, yposbaseline) wid hgt dpt in @@ -146,10 +160,8 @@ let rec ops_of_evaled_horz_box (fs : 'o op_funcs) (pbinfo : page_break_info) ypo (xpos +% wid, opaccnew) | EvHorzInlineImage(hgt, imgkey) -> - let tag = ImageInfo.get_tag imgkey in - let (xratio, yratio) = ImageInfo.get_ratio imgkey wid hgt in let ops_image = - fs.image (xpos, yposbaseline) xratio yratio tag + fs.image imgkey (xpos, yposbaseline) wid hgt in let opaccnew = Alist.append opacc ops_image in (xpos +% wid, opaccnew) From a3741ea8ba582f7c8dfd6ded743170940b250e6b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 31 Aug 2018 14:55:58 +0900 Subject: [PATCH 58/78] fix normalization as to spaces and breaks --- src/chardecoder/lineBreakDataMap.ml | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index 9fa1b03dd..f61ca9e4e 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -142,11 +142,17 @@ type 'a rule = line_break_regexp * 'a * line_break_regexp (* -- the rules for normalizing texts about spaces, break letters, etc. -- *) let normalization_rule : (((Uchar.t * line_break_class) list) rule) list = [ - (* -- ignore spaces or break letters *) + (* -- ignore spaces or breaks between a nonspaced character and spaced one -- *) ([nonspaced; set [SP; INBR]], [], [spaced]); ([spaced; set [SP; INBR]], [], [nonspaced]); - (* -- ignore break letters between nonspaced characters -- *) + (* -- ignore breaks between nonspaced characters -- *) ([nonspaced; exact INBR], [], [nonspaced]); + (* -- preserve spaces between nonspaced characters -- *) + ([nonspaced; exact SP], [bispace], [nonspaced]); + (* -- ignore spaces before and after a nonspaced characters -- *) + ([nonspaced; exact SP], [], []); + ([exact SP], [], [nonspaced]); + (* -- convert breaks into spaces -- *) ([exact INBR], [bispace], []); ] From 4848b149def000668bcd00c7f51f520ca4cbb79b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sat, 1 Sep 2018 05:46:08 +0900 Subject: [PATCH 59/78] fix normalization of spaces and breaks --- src/chardecoder/lineBreakDataMap.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index f61ca9e4e..10edf74c6 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -150,8 +150,8 @@ let normalization_rule : (((Uchar.t * line_break_class) list) rule) list = (* -- preserve spaces between nonspaced characters -- *) ([nonspaced; exact SP], [bispace], [nonspaced]); (* -- ignore spaces before and after a nonspaced characters -- *) - ([nonspaced; exact SP], [], []); - ([exact SP], [], [nonspaced]); + ([nonspaced; set [SP; INBR]], [], []); + ([set [SP; INBR]], [], [nonspaced]); (* -- convert breaks into spaces -- *) ([exact INBR], [bispace], []); ] From 4ce0041e11f20287749ea525b374975d128f4bd0 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 6 Sep 2018 14:18:33 +0900 Subject: [PATCH 60/78] update packages --- lib-satysfi/dist/packages/code.satyh | 9 ++++++--- lib-satysfi/dist/packages/footnote-scheme.satyh | 7 +++++-- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/lib-satysfi/dist/packages/code.satyh b/lib-satysfi/dist/packages/code.satyh index 1d9d4623d..94750169e 100644 --- a/lib-satysfi/dist/packages/code.satyh +++ b/lib-satysfi/dist/packages/code.satyh @@ -1,3 +1,4 @@ +@require: pervasives @require: list @require: color @require: gr @@ -5,6 +6,7 @@ module Code : sig + val scheme : deco-set -> color -> context -> string -> block-boxes direct +code : [string] block-cmd direct +console : [string] block-cmd direct \code : [string] inline-cmd @@ -64,9 +66,10 @@ end = struct let set-code-font ctx = ctx |> set-font Latin (`lmmono`, 1., 0.) + |> set-hyphen-penalty 100000 - let code-scheme decoset txtcolor ctx code = + let scheme decoset txtcolor ctx code = let pads = (5pt, 5pt, 5pt, 5pt) in block-frame-breakable ctx pads decoset (fun ctx -> ( let fontsize = get-font-size ctx in @@ -104,7 +107,7 @@ end = struct let-block ctx +code code = - code-scheme decoset-code Color.black ctx code + scheme decoset-code Color.black ctx code let-inline ctx \d-code code = @@ -113,7 +116,7 @@ end = struct let-block ctx +console code = - code-scheme decoset-console Color.white ctx code + scheme decoset-console Color.white ctx code let-inline ctx \console code = diff --git a/lib-satysfi/dist/packages/footnote-scheme.satyh b/lib-satysfi/dist/packages/footnote-scheme.satyh index a1f74296c..2254c9c13 100644 --- a/lib-satysfi/dist/packages/footnote-scheme.satyh +++ b/lib-satysfi/dist/packages/footnote-scheme.satyh @@ -13,6 +13,9 @@ end = struct let-mutable first-footnote <- true + let bar-ratio = 0.5 + + let start-page () = first-footnote <- true @@ -39,11 +42,11 @@ end = struct let () = display-message (`'` ^ label ^ `': T`) in % for debug let bar-top-margin = size in let bar-bottom-margin = size *' 0.125 in - let wid = get-text-width ctx in + let wid = get-text-width ctx *' bar-ratio in let ib = inline-graphics wid bar-top-margin bar-bottom-margin (fun (x, y) -> [ stroke 0.5pt Color.black (Gr.line (x, y) (x +' wid, y)); ] - ) + ) ++ inline-fil in line-break false false (ctx |> set-paragraph-margin 0pt 0pt) ib From 5463ae17490a736d2f93ab5fb38cdf63ea48edcb Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 6 Sep 2018 15:06:37 +0900 Subject: [PATCH 61/78] add 'PHGOuterFilGraphics' etc. --- src/backend/handlePdf.ml | 4 +++- src/backend/horzBox.ml | 15 ++++++++++++--- src/backend/lineBreak.ml | 18 +++++++++++++++++- src/backend/lineBreakBox.ml | 3 ++- 4 files changed, 34 insertions(+), 6 deletions(-) diff --git a/src/backend/handlePdf.ml b/src/backend/handlePdf.ml index 9c0d12d18..f7e25ce9f 100644 --- a/src/backend/handlePdf.ml +++ b/src/backend/handlePdf.ml @@ -124,7 +124,9 @@ let rec ops_of_evaled_horz_box (fs : 'o op_funcs) (pbinfo : page_break_info) ypo | EvHorzInlineGraphics(hgt, dpt, graphics) -> let gr = - graphics (xpos, yposbaseline) + match graphics with + | ImGraphicsFixed(grff) -> grff (xpos, yposbaseline) + | ImGraphicsVariable(grvf) -> grvf wid (xpos, yposbaseline) in let opsgr = pdfops_of_graphics fs pbinfo gr in let opaccsub = Alist.append opacc opsgr in diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index 0c5503312..b40805e5a 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -225,6 +225,10 @@ and decoration = point -> length -> length -> length -> (intermediate_horz_box l and rules_func = length list -> length list -> (intermediate_horz_box list) GraphicD.t +and fixed_graphics = point -> (intermediate_horz_box list) GraphicD.t + +and outer_fil_graphics = length -> point -> (intermediate_horz_box list) GraphicD.t + and pure_horz_box = (* -- spaces inserted before text processing -- *) | PHSOuterEmpty of length * length * length @@ -241,7 +245,8 @@ and pure_horz_box = | PHGInnerFrame of paddings * decoration * horz_box list | PHGOuterFrame of paddings * decoration * horz_box list | PHGEmbeddedVert of length * length * length * intermediate_vert_box list - | PHGFixedGraphics of length * length * length * (point -> (intermediate_horz_box list) GraphicD.t) + | PHGFixedGraphics of length * length * length * fixed_graphics + | PHGOuterFilGraphics of length * length * outer_fil_graphics | PHGFixedTabular of length * length * length * intermediate_row list * length list * length list * rules_func | PHGFixedImage of length * length * ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "@[PHGFixedImage(...)@]")] @@ -256,13 +261,17 @@ and horz_box = | HorzFrameBreakable of paddings * length * length * decoration * decoration * decoration * decoration * horz_box list | HorzScriptGuard of CharBasis.script * horz_box list +and intermediate_graphics = + | ImGraphicsFixed of fixed_graphics + | ImGraphicsVariable of outer_fil_graphics + and intermediate_horz_box = | ImHorz of evaled_horz_box | ImHorzRising of length * length * length * length * intermediate_horz_box list | ImHorzFrame of length * length * length * decoration * intermediate_horz_box list | ImHorzInlineTabular of length * length * length * intermediate_row list * length list * length list * rules_func | ImHorzEmbeddedVert of length * length * length * intermediate_vert_box list - | ImHorzInlineGraphics of length * length * length * (point -> (intermediate_horz_box list) GraphicD.t) + | ImHorzInlineGraphics of length * length * length * intermediate_graphics | ImHorzHookPageBreak of (page_break_info -> point -> unit) | ImHorzFootnote of intermediate_vert_box list @@ -288,7 +297,7 @@ and evaled_horz_box_main = | EvHorzEmpty | EvHorzFrame of length * length * decoration * evaled_horz_box list | EvHorzEmbeddedVert of length * length * evaled_vert_box list - | EvHorzInlineGraphics of length * length * (point -> (intermediate_horz_box list) GraphicD.t) + | EvHorzInlineGraphics of length * length * intermediate_graphics | EvHorzInlineTabular of length * length * evaled_row list * length list * length list * rules_func | EvHorzInlineImage of length * ImageInfo.key [@printer (fun fmt _ -> Format.fprintf fmt "EvHorzInlineImage(...)")] diff --git a/src/backend/lineBreak.ml b/src/backend/lineBreak.ml index 084e0530d..d945a156c 100644 --- a/src/backend/lineBreak.ml +++ b/src/backend/lineBreak.ml @@ -32,6 +32,16 @@ let get_metrics (lphb : lb_pure_box) : metrics = | LBFixedTabular(wid, hgt, dpt, _, _, _, _) -> (natural wid, hgt, dpt) | LBFixedImage(wid, hgt, _) -> (natural wid, hgt, Length.zero) + | LBOuterFilGraphics(hgt, dpt, _) -> + let widinfo = + { + natural = Length.zero; + shrinkable = Length.zero; + stretchable = Fils(1); + } + in + (widinfo, hgt, dpt) + | LBHookPageBreak(_) | LBFootnote(_) -> (widinfo_zero, Length.zero, Length.zero) @@ -153,6 +163,9 @@ let convert_pure_box_for_line_breaking_scheme (type a) (listf : horz_box list -> | PHGFixedGraphics(wid, hgt, dpt, graphics) -> puref (LBFixedGraphics(wid, hgt, dpt, graphics)) + | PHGOuterFilGraphics(hgt, dpt, graphics) -> + puref (LBOuterFilGraphics(hgt, dpt, graphics)) + | PHGFixedTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf) -> puref (LBFixedTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf)) @@ -528,7 +541,10 @@ let rec determine_widths (widreqopt : length option) (lphblst : lb_pure_box list ImHorzEmbeddedVert(wid, hgt, dpt, imvblst) | LBFixedGraphics(wid, hgt, dpt, graphics) -> - ImHorzInlineGraphics(wid, hgt, dpt, graphics) + ImHorzInlineGraphics(wid, hgt, dpt, ImGraphicsFixed(graphics)) + + | LBOuterFilGraphics(hgt, dpt, graphics) -> + ImHorzInlineGraphics(widperfil, hgt, dpt, ImGraphicsVariable(graphics)) | LBFixedTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf) -> ImHorzInlineTabular(wid, hgt, dpt, imtabular, widlst, lenlst, rulesf) diff --git a/src/backend/lineBreakBox.ml b/src/backend/lineBreakBox.ml index 469a93304..ae1dc711c 100644 --- a/src/backend/lineBreakBox.ml +++ b/src/backend/lineBreakBox.ml @@ -12,7 +12,8 @@ type lb_pure_box = | LBOuterFrame of metrics * decoration * lb_pure_box list | LBFixedFrame of length * length * length * decoration * lb_pure_box list | LBEmbeddedVert of length * length * length * intermediate_vert_box list - | LBFixedGraphics of length * length * length * (point -> (intermediate_horz_box list) GraphicD.t) + | LBFixedGraphics of length * length * length * fixed_graphics + | LBOuterFilGraphics of length * length * outer_fil_graphics | LBFixedTabular of length * length * length * intermediate_row list * length list * length list * rules_func | LBFixedImage of length * length * ImageInfo.key | LBHookPageBreak of (page_break_info -> point -> unit) From cf8c6d6eac8cdd8d872c92316b2ae208cd99fb6c Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 6 Sep 2018 15:48:28 +0900 Subject: [PATCH 62/78] add primitive 'inline-graphics-outer' --- src/frontend/bytecomp/vminstdef.yaml | 16 ++++++++++++++++ src/frontend/evalUtil.ml | 11 ++++++++++- src/frontend/primitives_.cppo.ml | 4 ++++ 3 files changed, 30 insertions(+), 1 deletion(-) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 1fa738173..8ecab5c08 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -2137,6 +2137,22 @@ code: | let graphics = make_inline_graphics reducef valueg in Horz(HorzBox.([HorzPure(PHGFixedGraphics(wid, hgt, Length.negate dpt, graphics))])) +--- +inst: BackendInlineGraphicsOuter +is-pdf-mode-primitive: yes +name: "inline-graphics-outer" +type: | + ~% (tLN @-> tLN @-> tIGRO @-> tIB) + +needs-reducef: yes +params: +- hgt : length +- dpt : length +- valueg +code: | + let graphics = make_inline_graphics_outer reducef valueg in + Horz(HorzBox.([HorzPure(PHGOuterFilGraphics(hgt, Length.negate dpt, graphics))])) + --- inst: BackendScriptGuard is-pdf-mode-primitive: yes diff --git a/src/frontend/evalUtil.ml b/src/frontend/evalUtil.ml index 52b34cb9f..9371d6ea0 100644 --- a/src/frontend/evalUtil.ml +++ b/src/frontend/evalUtil.ml @@ -626,7 +626,7 @@ let make_math_char_kern_func reducef valuekernf : HorzBox.math_char_kern_func = ) -let make_inline_graphics reducef valueg = +let make_inline_graphics reducef valueg : HorzBox.fixed_graphics = (fun (xpos, ypos) -> let valuepos = TupleCons(LengthConstant(xpos), TupleCons(LengthConstant(ypos), EndOfTuple)) in let valueret = reducef valueg [valuepos] in @@ -634,6 +634,15 @@ let make_inline_graphics reducef valueg = ) +let make_inline_graphics_outer reducef valueg : HorzBox.outer_fil_graphics = + (fun wid (xpos, ypos) -> + let valuepos = TupleCons(LengthConstant(xpos), TupleCons(LengthConstant(ypos), EndOfTuple)) in + let valuewid = LengthConstant(wid) in + let valueret = reducef valueg [valuewid; valuepos] in + graphics_of_list valueret + ) + + let make_length_list lenlst = List.fold_right (fun l acc -> ListCons(LengthConstant(l), acc) diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index e2cd21c4e..7d665340d 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -21,6 +21,7 @@ let tyid_image = Typeenv.Raw.fresh_type_id "image" let tyid_deco = Typeenv.Raw.fresh_type_id "deco" let tyid_decoset = Typeenv.Raw.fresh_type_id "deco-set" let tyid_igraf = Typeenv.Raw.fresh_type_id "inline-graphics" +let tyid_igrafo = Typeenv.Raw.fresh_type_id "inline-graphics-outer" let ( ~! ) = Range.dummy @@ -76,6 +77,9 @@ let tDECOSET = (~! "deco-set", SynonymType([], tyid_decoset, tDECOSET_raw)) let tIGR_raw = tPT @-> (tL tGR) let tIGR = (~! "igraf", SynonymType([], tyid_igraf, tIGR_raw)) +let tIGRO_raw = tLN @-> tPT @-> (tL tGR) +let tIGRO = (~! "igrafo", SynonymType([], tyid_igrafo, tIGRO_raw)) + let tPAREN = tLN @-> tLN @-> tLN @-> tLN @-> tCLR @-> tPROD [tIB; tLN @-> tLN] let tCMD = (~! "cmd", HorzCommandType([MandatoryArgumentType(tMATH)])) From cd57b5fae2a74c7808d9a9bf27723001ce371bcb Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 6 Sep 2018 17:25:52 +0900 Subject: [PATCH 63/78] add 'VDecoSet.paper' --- lib-satysfi/dist/packages/vdecoset.satyh | 64 ++++++++++++++++++++++++ 1 file changed, 64 insertions(+) diff --git a/lib-satysfi/dist/packages/vdecoset.satyh b/lib-satysfi/dist/packages/vdecoset.satyh index 6db3940af..bbc2b5bd1 100644 --- a/lib-satysfi/dist/packages/vdecoset.satyh +++ b/lib-satysfi/dist/packages/vdecoset.satyh @@ -1,3 +1,4 @@ +@require: color @require: gr module VDecoSet : sig @@ -5,6 +6,7 @@ module VDecoSet : sig val empty : deco-set val simple-frame-stroke : length -> color -> deco-set val simple-frame : length -> color -> color -> deco-set + val paper : deco-set end = struct @@ -71,4 +73,66 @@ end = struct in (decoS, decoH, decoM, decoT) + + let paper = + let xshift = 2pt in + let yshift = 1pt in + let shadow-color = Gray(0.5) in + let edge-color = Color.black in + let thk = 0.5pt in + let shadowL (x, y) w h d = + fill shadow-color + (Gr.polygon (x +' w, y +' h) [ + (x +' w +' xshift, y +' h -' yshift); + (x +' w +' xshift, y -' d -' yshift); + (x +' xshift, y -' d -' yshift); + (x, y -' d); + (x +' w, y -' d); + ]) + in + let shadowI (x, y) w h d = + fill shadow-color + (Gr.polygon (x +' w, y -' d) [ + (x +' w +' xshift, y -' d); + (x +' w +' xshift, y +' h -' yshift); + (x +' w, y +' h); + ]) + in + let decoS (x, y) w h d = + [ + shadowL (x, y) w h d; + stroke thk edge-color (Gr.rectangle (x, y -' d) (x +' w, y +' h)); + ] + in + let decoH (x, y) w h d = + [ + shadowI (x, y) w h d; + stroke thk edge-color + (Gr.poly-line (x, y -' d) [ + (x, y +' h); + (x +' w, y +' h); + (x +' w, y -' d); + ]); + ] + in + let decoM (x, y) w h d = + [ + shadowI (x, y) w h d; + stroke thk edge-color (Gr.line (x, y -' d) (x, y +' h)); + stroke thk edge-color (Gr.line (x +' w, y -' d) (x +' w, y +' h)); + ] + in + let decoT (x, y) w h d = + [ + shadowL (x, y) w h d; + stroke thk edge-color + (Gr.poly-line (x, y +' h) [ + (x, y -' d); + (x +' w, y -' d); + (x +' w, y +' h); + ]); + ] + in + (decoS, decoH, decoM, decoT) + end From e02bb58adbbd671c43ac6faee62669db3cd7c0fa Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 9 Sep 2018 00:03:07 +0900 Subject: [PATCH 64/78] add optional parameters/arguments for math commands --- src/frontend/lexer.mll | 3 +++ src/frontend/parser.mly | 33 +++++++++++++++++++++++++++------ 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/src/frontend/lexer.mll b/src/frontend/lexer.mll index 2d46f81e5..e2c7fe619 100644 --- a/src/frontend/lexer.mll +++ b/src/frontend/lexer.mll @@ -444,6 +444,9 @@ and mathexpr stack = parse comment lexbuf; mathexpr stack lexbuf } + | "?:" { + OPTIONAL(get_pos lexbuf) + } | "!{" { Stack.push HorizontalState stack; skip_spaces lexbuf; diff --git a/src/frontend/parser.mly b/src/frontend/parser.mly index 446c032af..cbc56035d 100644 --- a/src/frontend/parser.mly +++ b/src/frontend/parser.mly @@ -623,10 +623,10 @@ nxvertdec: } ; nxmathdec: - | mcmdtok=HORZCMD; argpatlst=argpats; DEFEQ; utast=nxlet { + | mcmdtok=HORZCMD; cmdarglst=list(arg); DEFEQ; utast=nxlet { let (rngcs, _) = mcmdtok in let rng = make_range (Tok rngcs) (Ranged utast) in - let curried = curry_lambda_abstract_pattern rngcs argpatlst utast in + let curried = curry_lambda_abstract Alist.empty rngcs cmdarglst utast in (None, mcmdtok, (rng, UTLambdaMath(curried))) } ; @@ -1130,10 +1130,31 @@ mathbot: | tok=VARINMATH { let (rng, mdlnmlst, varnm) = tok in (rng, UTMEmbed((rng, UTContentOf(mdlnmlst, varnm)))) } ; matharg: - | opn=BMATHGRP; utast=mathblock; cls=EMATHGRP { let (_, utastmain) = utast in UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) } - | opn=BHORZGRP; utast=sxsep; cls=EHORZGRP { let (_, utastmain) = utast in UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) } - | opn=BVERTGRP; utast=vxblock; cls=EVERTGRP { let (_, utastmain) = utast in UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) } - | utcmdarg=narg { utcmdarg } + | opn=BMATHGRP; utast=mathblock; cls=EMATHGRP { + let (_, utastmain) = utast in + UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) + } + | opn=BHORZGRP; utast=sxsep; cls=EHORZGRP { + let (_, utastmain) = utast in + UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) + } + | opn=BVERTGRP; utast=vxblock; cls=EVERTGRP { + let (_, utastmain) = utast in + UTMandatoryArgument(make_standard (Tok opn) (Tok cls) utastmain) + } + | opt=OPTIONAL; BMATHGRP; utast=mathblock; cls=EMATHGRP { + let (_, utastmain) = utast in + UTOptionalArgument(make_standard (Tok opt) (Tok cls) utastmain) + } + | opt=OPTIONAL; BHORZGRP; utast=sxsep; cls=EHORZGRP { + let (_, utastmain) = utast in + UTOptionalArgument(make_standard (Tok opt) (Tok cls) utastmain) + } + | opt=OPTIONAL; BVERTGRP; utast=vxblock; cls=EVERTGRP { + let (_, utastmain) = utast in + UTOptionalArgument(make_standard (Tok opt) (Tok cls) utastmain) + } + | utcmdarg=narg { utcmdarg } ; sxblock: | ih=ih { let rng = make_range_from_list ih in (rng, UTInputHorz(ih)) } From 803f8ef082c17fc3e4474a8e9cffd4903d7f0b63 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Sun, 9 Sep 2018 00:04:01 +0900 Subject: [PATCH 65/78] add label name option to '\derive' --- lib-satysfi/dist/packages/proof.satyh | 31 ++++++++++++++++++++------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/lib-satysfi/dist/packages/proof.satyh b/lib-satysfi/dist/packages/proof.satyh index 2db14ee68..e85cb7868 100644 --- a/lib-satysfi/dist/packages/proof.satyh +++ b/lib-satysfi/dist/packages/proof.satyh @@ -2,8 +2,8 @@ module Proof : sig - direct \derive : [math list; math] math-cmd - direct \derive-multi : [length; math list; math] math-cmd + direct \derive : [math?; math list; math] math-cmd + direct \derive-multi : [math?; length; math list; math] math-cmd end = struct @@ -15,7 +15,7 @@ end = struct if len1 <' len2 then len2 else len1 - let derive widopt mlst1 m2 = + let derive nameopt widopt mlst1 m2 = let ib-space = match widopt with | None -> inline-skip 30pt @@ -44,17 +44,32 @@ end = struct let color = get-text-color ctx in let thickness = 0.5pt in let gap = 2pt in + let (glnamef, wname) = + match nameopt with + | None -> + ((fun _ -> []), 0pt) + + | Some(name) -> + let ib = embed-math ctx name in + let (wname, _, _) = get-natural-metrics ib in + ((fun pt -> [Gr.text-rightward pt ib]), wname) + in let bar = - inline-graphics w (thickness +' gap) gap (fun (x, y) -> - [ fill color (Gr.rectangle (x, y) (x +' w, y +' thickness)); ] - ) + inline-graphics w (thickness +' gap) gap (fun (x, y) -> + List.append + [ fill color (Gr.rectangle (x, y) (x +' w, y +' thickness)); ] + (glnamef (x +' w, y -' (get-axis-height ctx))) + ) in line-stack-bottom [ib1; bar; ib2] + ++ inline-skip wname )) - let-math \derive = derive None + let-math \derive ?:nameopt mlst m = + derive nameopt None mlst m - let-math \derive-multi w = derive (Some(w)) + let-math \derive-multi ?:nameopt w = + derive nameopt (Some(w)) end From c761c61dce105d3cd08a8b105136fab78774e516 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 10 Sep 2018 16:36:54 +0900 Subject: [PATCH 66/78] add 'set-word-break-penalty' and 'get-every-word-break' --- src/backend/horzBox.ml | 2 +- src/chardecoder/convertText.ml | 4 ++-- src/frontend/bytecomp/vminstdef.yaml | 31 +++++++++++++++++++++++++++- src/frontend/primitives_.cppo.ml | 2 +- 4 files changed, 34 insertions(+), 5 deletions(-) diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index b40805e5a..0d2d35d9e 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -203,7 +203,7 @@ type context_main = { min_gap_of_lines : length; text_color : color; manual_rising : length; - badness_space : pure_badness; + space_badness : pure_badness; math_variant_char_map : Uchar.t MathVariantCharMap.t; [@printer (fun fmt _ -> Format.fprintf fmt "")] math_class_map : (Uchar.t list * math_kind) MathClassMap.t; diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index 4a135d5a4..449dad3eb 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -104,7 +104,7 @@ let breakable_space lphbf ctx () : lb_box = let dscrid = DiscretionaryID.fresh () in let lphb1 = lphbf ctx.before_word_break in let lphb2 = lphbf ctx.after_word_break in - LBDiscretionary(ctx.badness_space, dscrid, [pure_space ctx], lphb1, lphb2) + LBDiscretionary(ctx.space_badness, dscrid, [pure_space ctx], lphb1, lphb2) let unbreakable_space ctx : lb_box = @@ -202,7 +202,7 @@ let pure_space_between_classes (ctx1, script1, lbc1) (ctx2, script2, lbc2) = let space_between_chunks info1 alw info2 : lb_box list = let (ctx1, script1, lbc1) = info1 in let (ctx2, script2, lbc2) = info2 in - let badns = max ctx1.badness_space ctx2.badness_space in + let badns = max ctx1.space_badness ctx2.space_badness in if not (script_equal script1 script2) then let size = Length.max ctx1.font_size ctx2.font_size in match pure_space_between_scripts size script1 lbc1 script2 lbc2 with diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 8ecab5c08..2ca2bb177 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -2946,9 +2946,24 @@ params: code : | exec (func :: (List.rev_append lst stack)) env code dump +--- +inst: PrimitiveSetWordBreakPenalty +is-pdf-mode-primitive: yes +name: "set-word-break-penalty" +type: | + ~% (tI @-> tCTX @-> tCTX) + +params: +- pnlty : int +- (ctx, valuecmd) : context +code: | + Context(HorzBox.{ ctx with + space_badness = pnlty; + }, valuecmd) + --- inst: PrimitiveSetEveryWordBreak -is-pdf-mode-primitive : yes +is-pdf-mode-primitive: yes name: "set-every-word-break" type: | ~% (tIB @-> tIB @-> tCTX @-> tCTX) @@ -2963,6 +2978,20 @@ code: | after_word_break = hblst2; }), valuecmd) +--- +inst: PrimitiveGetEveryWordBreak +is-pdf-mode-primitive: yes +name: "get-every-word-break" +type: | + ~% (tCTX @-> tPROD [tIB; tIB]) + +params: +- (ctx, _) : context +code: | + let hblst1 = ctx.HorzBox.before_word_break in + let hblst2 = ctx.HorzBox.after_word_break in + TupleCons(Horz(hblst1), TupleCons(Horz(hblst2), EndOfTuple)) + --- inst: BackendProbeCrossReference is-pdf-mode-primitive : yes diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 7d665340d..30c60e700 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -475,7 +475,7 @@ let get_pdf_mode_initial_context wid = min_gap_of_lines = pdfpt 2.; text_color = DeviceGray(0.); manual_rising = pdfpt 0.; - badness_space = 100; + space_badness = 100; math_variant_char_map = default_math_variant_char_map; math_class_map = default_math_class_map; math_char_class = MathItalic; From befb4a56a278397c56ca6ac4917475d4a8562a18 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Thu, 13 Sep 2018 21:17:25 +0900 Subject: [PATCH 67/78] modify 'doc/local.satyh' and update 'proof.satyh' --- doc/local.satyh | 6 +++--- lib-satysfi/dist/packages/proof.satyh | 20 +++++++++++++------- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/doc/local.satyh b/doc/local.satyh index d7f25f0ff..922306862 100644 --- a/doc/local.satyh +++ b/doc/local.satyh @@ -1,8 +1,8 @@ @require: pervasives @require: math @require: stdja -@import: vdecoset -@import: decoset +@require: vdecoset +@require: hdecoset type type-syntax = @@ -178,7 +178,7 @@ let-inline ctx \meta m = let-inline ctx \code inner = let pads-code = (2pt, 2pt, 2pt, 2pt) in - let decoset-code = DecoSet.rectangle-round-fill 4pt 2pt (Color.gray 0.9) in + let decoset-code = HDecoSet.rectangle-round-fill 4pt 2pt (Color.gray 0.9) in let ctx-code = name-context ctx |> set-math-command (command \meta) in diff --git a/lib-satysfi/dist/packages/proof.satyh b/lib-satysfi/dist/packages/proof.satyh index e85cb7868..b29169d04 100644 --- a/lib-satysfi/dist/packages/proof.satyh +++ b/lib-satysfi/dist/packages/proof.satyh @@ -2,8 +2,8 @@ module Proof : sig - direct \derive : [math?; math list; math] math-cmd - direct \derive-multi : [math?; length; math list; math] math-cmd + direct \derive : [math?; bool?; math list; math] math-cmd + direct \derive-multi : [math?; bool?; length; math list; math] math-cmd end = struct @@ -15,7 +15,7 @@ end = struct if len1 <' len2 then len2 else len1 - let derive nameopt widopt mlst1 m2 = + let derive nameopt bopt widopt mlst1 m2 = let ib-space = match widopt with | None -> inline-skip 30pt @@ -52,6 +52,12 @@ end = struct | Some(name) -> let ib = embed-math ctx name in let (wname, _, _) = get-natural-metrics ib in + let wname = + match bopt with + | None -> wname + | Some(false) -> wname + | Some(true) -> 0pt + in ((fun pt -> [Gr.text-rightward pt ib]), wname) in let bar = @@ -66,10 +72,10 @@ end = struct )) - let-math \derive ?:nameopt mlst m = - derive nameopt None mlst m + let-math \derive ?:nameopt ?:bopt mlst m = + derive nameopt bopt None mlst m - let-math \derive-multi ?:nameopt w = - derive nameopt (Some(w)) + let-math \derive-multi ?:nameopt ?:bopt w = + derive nameopt bopt (Some(w)) end From a6c7bba627ffc7a94cb846c911f781a129bfc6c1 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 18 Sep 2018 19:54:45 +0900 Subject: [PATCH 68/78] add candidate change to 'pageBreak.ml' --- src/backend/pageBreak.ml | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/src/backend/pageBreak.ml b/src/backend/pageBreak.ml index 229e4fe10..359299b63 100644 --- a/src/backend/pageBreak.ml +++ b/src/backend/pageBreak.ml @@ -147,10 +147,15 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst match ans.rest with | None -> let evvbaccnew = - let decosub = + let (decosub, pads) = +(* + match midway with + | Midway -> (decoT, { pads with paddingT = Length.zero; }) + | Beginning -> (decoS, pads) +*) match midway with - | Midway -> decoT - | Beginning -> decoS + | Midway -> (decoT, pads) + | Beginning -> (decoS, pads) in Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertFrame(pads, pbinfo, decosub, wid, ans.body)) @@ -166,10 +171,15 @@ let chop_single_page (pbinfo : page_break_info) (area_height : length) (pbvblst | Some(pbvbrestsub) -> let evvbaccret = - let decosub = + let (decosub, pads) = +(* + match midway with + | Midway -> (decoM, { pads with paddingT = Length.zero; paddingB = Length.zero; }) + | Beginning -> (decoH, { pads with paddingB = Length.zero; }) +*) match midway with - | Midway -> decoM - | Beginning -> decoH + | Midway -> (decoM, pads) + | Beginning -> (decoH, pads) in Alist.extend (Alist.cat evvbacc evvbaccdiscardable) (EvVertFrame(pads, pbinfo, decosub, wid, ans.body)) From 0e986f9d8d442a8120c42c625640b424bf100430 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 21 Sep 2018 18:42:18 +0900 Subject: [PATCH 69/78] change specing between different scripts --- CHANGELOG.md | 5 +++++ src/chardecoder/charBasis.ml | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 70f4502b3..df5a7978e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). ## [Unreleased] +### Fixed +- Does NOT insert spacing between different scripts when the line breaking class of the posterior charcter is CL, CP, QU, NS, JLCP, JLNS, JLCM, or JLFS + +# Changed +- Supports the application of math commands to optional arguments ## [0.0.2] - 2018-08-09 ### Fixed diff --git a/src/chardecoder/charBasis.ml b/src/chardecoder/charBasis.ml index 5cec4d184..eda9b95ea 100644 --- a/src/chardecoder/charBasis.ml +++ b/src/chardecoder/charBasis.ml @@ -128,7 +128,7 @@ let is_open_punctuation = function let is_close_punctuation = function - | CL | CP | QU | JLCP + | CL | CP | QU | NS | JLCP | JLNS | JLCM | JLFS -> true | _ -> false From 0837c28815b7f0171d95f657954bb67c88b9c084 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 21 Sep 2018 18:42:32 +0900 Subject: [PATCH 70/78] update packages --- lib-satysfi/dist/packages/math.satyh | 1 + lib-satysfi/dist/packages/table.satyh | 40 +++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 lib-satysfi/dist/packages/table.satyh diff --git a/lib-satysfi/dist/packages/math.satyh b/lib-satysfi/dist/packages/math.satyh index f32b7cc16..c2f90b88b 100644 --- a/lib-satysfi/dist/packages/math.satyh +++ b/lib-satysfi/dist/packages/math.satyh @@ -19,6 +19,7 @@ module Math : sig direct \math-skip : [length] math-cmd direct \math-color : [color; math] math-cmd val join : math -> math list -> math + val half-length : length -> length -> length -> length -> length direct \mathord : [math] math-cmd direct \mathbin : [math] math-cmd diff --git a/lib-satysfi/dist/packages/table.satyh b/lib-satysfi/dist/packages/table.satyh new file mode 100644 index 000000000..e68d33ced --- /dev/null +++ b/lib-satysfi/dist/packages/table.satyh @@ -0,0 +1,40 @@ + +module Table : sig + + direct \tabular : [ + (| + l : inline-text -> cell; + r : inline-text -> cell; + c : inline-text -> cell; + m : int -> int -> inline-text -> cell; + e : cell; + |) -> (cell list) list; + length list -> length list -> graphics list; + ] inline-cmd + +end = struct + + let table-scheme ctx pads cellssf decof = + let nc ib = NormalCell(pads, ib) in + let mc i j ib = MultiCell(i, j, pads, ib) in + let cellss = + cellssf (| + l = (fun it -> + nc (read-inline ctx it ++ inline-fil)); + r = (fun it -> + nc (inline-fil ++ read-inline ctx it)); + c = (fun it -> + nc (inline-fil ++ read-inline ctx it ++ inline-fil)); + m = (fun i j it -> + mc i j (inline-fil ++ read-inline ctx it ++ inline-fil)); + e = EmptyCell; + |) + in + tabular cellss decof + + + let-inline ctx \tabular = + let pads = (2pt, 2pt, 2pt, 2pt) in + table-scheme ctx pads + +end From 58f167d88afbd4a887ea3904f083d20f5b6be2a8 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 21 Sep 2018 22:15:02 +0900 Subject: [PATCH 71/78] add '(set|get)-space-ratio-between-scripts' --- CHANGELOG.md | 1 + src/backend/horzBox.ml | 2 ++ src/chardecoder/charBasis.ml | 9 ++++++ src/chardecoder/convertText.ml | 26 ++++++++++++++--- src/frontend/bytecomp/vminstdef.yaml | 43 ++++++++++++++++++++++++++++ src/frontend/primitives_.cppo.ml | 24 ++++++++++++++++ 6 files changed, 101 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index df5a7978e..2381d0b85 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,7 @@ and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0. # Changed - Supports the application of math commands to optional arguments +- Add `set-space-ratio-between-scripts` and `get-space-ratio-between-scripts` ## [0.0.2] - 2018-08-09 ### Fixed diff --git a/src/backend/horzBox.ml b/src/backend/horzBox.ml index 0d2d35d9e..7041d56f2 100644 --- a/src/backend/horzBox.ml +++ b/src/backend/horzBox.ml @@ -190,6 +190,8 @@ type context_main = { math_font : math_font_abbrev; dominant_wide_script : CharBasis.script; dominant_narrow_script : CharBasis.script; + script_space_map : (float * float * float) CharBasis.ScriptSpaceMap.t; + [@printer (fun fmt _ -> Format.fprintf fmt "")] space_natural : float; space_shrink : float; space_stretch : float; diff --git a/src/chardecoder/charBasis.ml b/src/chardecoder/charBasis.ml index eda9b95ea..67a19315a 100644 --- a/src/chardecoder/charBasis.ml +++ b/src/chardecoder/charBasis.ml @@ -17,12 +17,21 @@ type script = (* temporary; should add more scripts *) | OtherScript + module ScriptSchemeMap = Map.Make (struct type t = script let compare = Pervasives.compare end) + +module ScriptSpaceMap = Map.Make + (struct + type t = script * script + let compare = Pervasives.compare + end) + + type east_asian_width = | EAWHalfWidth | EAWFullWidth diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index 449dad3eb..d46c9e0f3 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -27,10 +27,28 @@ let half_kern (hsinfo : horz_string_info) : lb_pure_box = LBAtom((natural (hsinfo.text_font_size *% -0.5), Length.zero, Length.zero), EvHorzEmpty) -let pure_space_between_scripts size (script1 : script) (lbc1 : line_break_class) (script2 : script) (lbc2 : line_break_class) = +let pure_space_between_scripts ctx1 ctx2 size (script1 : script) (lbc1 : line_break_class) (script2 : script) (lbc2 : line_break_class) = if is_open_punctuation lbc1 || is_close_punctuation lbc2 then None else + match + (ctx1.script_space_map |> ScriptSpaceMap.find_opt (script1, script2), + ctx2.script_space_map |> ScriptSpaceMap.find_opt (script1, script2)) + with + | (None, None) -> + None + + | (Some(tuple), None) + | (None, Some(tuple)) -> + let (r0, r1, r2) = tuple in + Some(LBAtom((natural (size *% r0), size *% r1, size *% r2), EvHorzEmpty)) + + | (Some(tuple1), Some(tuple2)) -> + let (r10, r11, r12) = tuple1 in + let (r20, r21, r22) = tuple2 in + let (r0, r1, r2) = (max r10 r20, max r11 r21, max r12 r22) in + Some(LBAtom((natural (size *% r0), size *% r1, size *% r2), EvHorzEmpty)) +(* match (script1, script2) with | (HanIdeographic , Latin ) | (Latin , HanIdeographic ) @@ -40,7 +58,7 @@ let pure_space_between_scripts size (script1 : script) (lbc1 : line_break_class) Some(LBAtom((natural (size *% 0.24), size *% 0.08, size *% 0.16), EvHorzEmpty)) (* temporary; shold refer to the context for spacing information between two scripts *) | _ -> None - +*) let space_width_info ctx : length_info = let size = ctx.font_size in @@ -205,7 +223,7 @@ let space_between_chunks info1 alw info2 : lb_box list = let badns = max ctx1.space_badness ctx2.space_badness in if not (script_equal script1 script2) then let size = Length.max ctx1.font_size ctx2.font_size in - match pure_space_between_scripts size script1 lbc1 script2 lbc2 with + match pure_space_between_scripts ctx1 ctx2 size script1 lbc1 script2 lbc2 with | Some(lphb) -> [discretionary_if_breakable alw badns lphb ()] @@ -228,7 +246,7 @@ let space_between_chunks_pure info1 info2 : lb_pure_box list = let (ctx2, script2, lbc2) = info2 in if not (script_equal script1 script2) then let size = Length.max ctx1.font_size ctx2.font_size in - match pure_space_between_scripts size script1 lbc1 script2 lbc2 with + match pure_space_between_scripts ctx1 ctx2 size script1 lbc1 script2 lbc2 with | Some(lphb) -> [lphb] diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index 2ca2bb177..ca29e0925 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -1714,6 +1714,49 @@ code: | space_stretch = max 0. ratio_stretch; }), valuecmd) +--- +inst: PrimitiveSetSpaceRatioBetweenScripts +is-pdf-mode-primitive: yes +name: "set-space-ratio-between-scripts" +type: | + ~% (tFL @-> tFL @-> tFL @-> tSCR @-> tSCR @-> tCTX @-> tCTX) + +params: +- ratio_natural : float +- ratio_shrink : float +- ratio_stretch : float +- script1 : script +- script2 : script +- (ctx, valuecmd) : context +code: | + Context(HorzBox.({ ctx with + script_space_map = + ctx.script_space_map |> CharBasis.ScriptSpaceMap.add + (script1, script2) + (max 0. ratio_natural, max 0. ratio_shrink, max 0. ratio_stretch) + }), valuecmd) + +--- +inst: PrimitiveGetSpaceRatioBetweenScripts +is-pdf-mode-primitive: yes +name: "get-space-ratio-between-scripts" +type: | + ~% (tCTX @-> tSCR @-> tSCR @-> tOPT (tPROD [tFL; tFL; tFL])) + +params: +- (ctx, _) : context +- script1 : script +- script2 : script +code: | + match ctx.script_space_map |> CharBasis.ScriptSpaceMap.find_opt (script1, script2) with + | None -> + Constructor("None", UnitConstant) + + | Some((r0, r1, r2)) -> + Constructor("Some", TupleCons(FloatConstant(r0), + TupleCons(FloatConstant(r1), + TupleCons(FloatConstant(r2), EndOfTuple)))) + --- inst: PrimitiveSetParagraphMargin is-pdf-mode-primitive: yes diff --git a/src/frontend/primitives_.cppo.ml b/src/frontend/primitives_.cppo.ml index 30c60e700..240a99c87 100644 --- a/src/frontend/primitives_.cppo.ml +++ b/src/frontend/primitives_.cppo.ml @@ -272,6 +272,18 @@ let rec lambda5 astf env = | [a1;a2;a3;a4;a5] -> astf a1 a2 a3 a4 a5 | _ -> failwith "internal error") +let rec lambda6 astf env = + let evid1 = EvalVarID.fresh (dr, "(dummy:lambda6-1)") in + let evid2 = EvalVarID.fresh (dr, "(dummy:lambda6-2)") in + let evid3 = EvalVarID.fresh (dr, "(dummy:lambda6-3)") in + let evid4 = EvalVarID.fresh (dr, "(dummy:lambda6-4)") in + let evid5 = EvalVarID.fresh (dr, "(dummy:lambda6-5)") in + let evid6 = EvalVarID.fresh (dr, "(dummy:lambda6-6)") in + lamenv env evid1 6 (lam evid2 (lam evid3 (lam evid4 (lam evid5 (lam evid6 (astf (!- evid1) (!- evid2) (!- evid3) (!- evid4) (!- evid5) (!- evid6))))))) + (fun lst -> match lst with + | [a1;a2;a3;a4;a5;a6] -> astf a1 a2 a3 a4 a5 a6 + | _ -> failwith "internal error") + let pdfpt = Length.of_pdf_point @@ -451,6 +463,17 @@ let default_font_scheme_ref = ref CharBasis.ScriptSchemeMap.empty let default_hyphen_dictionary = ref LoadHyph.empty + +let default_script_space_map = + let space_latin_cjk = (0.24, 0.08, 0.16) in + let open CharBasis in + ScriptSpaceMap.empty + |> ScriptSpaceMap.add (Latin, HiraganaOrKatakana) space_latin_cjk + |> ScriptSpaceMap.add (HiraganaOrKatakana, Latin) space_latin_cjk + |> ScriptSpaceMap.add (Latin, HanIdeographic) space_latin_cjk + |> ScriptSpaceMap.add (HanIdeographic, Latin) space_latin_cjk + + let get_pdf_mode_initial_context wid = let open HorzBox in { @@ -462,6 +485,7 @@ let get_pdf_mode_initial_context wid = dominant_wide_script = CharBasis.OtherScript; dominant_narrow_script = CharBasis.OtherScript; langsys_scheme = CharBasis.ScriptSchemeMap.empty; + script_space_map = default_script_space_map; space_natural = 0.33; space_shrink = 0.08; space_stretch = 0.16; From 4462fbc80ca44fdf95713c7c70dfa779c69b67e7 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 24 Sep 2018 10:04:21 +0900 Subject: [PATCH 72/78] fix lexer as to '`#' occurring in a literal area --- src/frontend/lexer.mll | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/frontend/lexer.mll b/src/frontend/lexer.mll index e2c7fe619..ff67f1aa6 100644 --- a/src/frontend/lexer.mll +++ b/src/frontend/lexer.mll @@ -575,7 +575,7 @@ and literal omit_pre quote_range quote_length buffer = parse | (("`"+ as tok) "#") { let len = String.length tok in if len < quote_length then begin - Buffer.add_string buffer tok; + Buffer.add_string buffer (tok ^ "#"); literal omit_pre quote_range quote_length buffer lexbuf end else if len > quote_length then report_error lexbuf "literal area was closed with too many '`'s" From 8217757d19ebf3892167d5c2e03d6a51630211a9 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Mon, 24 Sep 2018 10:05:04 +0900 Subject: [PATCH 73/78] update 'itemize.satyh' as to vertical spacing --- lib-satysfi/dist/packages/itemize.satyh | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/lib-satysfi/dist/packages/itemize.satyh b/lib-satysfi/dist/packages/itemize.satyh index d197d23e8..2f51a66ba 100644 --- a/lib-satysfi/dist/packages/itemize.satyh +++ b/lib-satysfi/dist/packages/itemize.satyh @@ -17,7 +17,7 @@ end = struct let item-indent = 16pt let item-gap = 10pt - let item-gap-top = 6pt + let item-gap-outer = 6pt let bullet color (x, y) = @@ -69,17 +69,17 @@ end = struct % line-break true false (ctx |> set-paragraph-margin 0pt item-gap) inline-fil; ] in - let bblst-children = List.map (listing-item ctx (depth + 1)) children in + let bblst-children = List.map (listing-item-breakable ctx (depth + 1)) children in bb-parent +++> bblst-children let listing break ctx (Item(_, itmzlst)) = if break then let bblst = List.map (listing-item-breakable ctx 0) itmzlst in - block-skip item-gap-top +++ (block-nil +++> bblst) + block-skip item-gap-outer +++ (block-nil +++> bblst) +++ block-skip item-gap-outer else let bblst = List.map (listing-item ctx 0) itmzlst in - block-skip item-gap-top +++ (block-nil +++> bblst) + block-skip item-gap-outer +++ (block-nil +++> bblst) +++ block-skip item-gap-outer let-block ctx +listing ?:breakopt item = @@ -112,13 +112,19 @@ end = struct ((inline-skip parent-indent) ++ ib-index ++ ib-parent) - let-block ctx +enumerate (Item(_, itmzlst)) = + let enumerate ctx (Item(_, itmzlst)) = let bblst = List.mapi (fun i -> enumerate-item (i + 1) ctx 0) itmzlst in - block-skip item-gap-top +++ (block-nil +++> bblst) + block-nil +++> bblst + + + let-block ctx +enumerate item = + enumerate ctx item let-inline ctx \enumerate item = + let bb = enumerate ctx item in inline-fil ++ - embed-block-breakable ctx (read-block ctx '<+enumerate(item);>) + embed-block-breakable ctx + (block-skip item-gap-outer +++ bb +++ block-skip item-gap-outer) end From 6bf34e6b2127f0cc7f647f7c607c0dd5d7b05b96 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 25 Sep 2018 04:46:13 +0900 Subject: [PATCH 74/78] add primitive 'show-float' --- src/frontend/bytecomp/vminstdef.yaml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/frontend/bytecomp/vminstdef.yaml b/src/frontend/bytecomp/vminstdef.yaml index ca29e0925..979c9ebe6 100644 --- a/src/frontend/bytecomp/vminstdef.yaml +++ b/src/frontend/bytecomp/vminstdef.yaml @@ -2477,6 +2477,20 @@ params: code: | StringConstant(string_of_int num) +--- +inst: PrimitiveShowFloat +is-pdf-mode-primitive: yes +is-text-mode-primitive: yes +name: "show-float" +type: | + ~% (tFL @-> tS) + +params: +- fl : float +code: | + StringConstant(string_of_float fl) + + --- inst: PrimitiveFloat is-pdf-mode-primitive: yes From 9353bb63ea6523813c1b9b9caa0f6e3f7aa8808a Mon Sep 17 00:00:00 2001 From: gfngfn Date: Fri, 28 Sep 2018 01:39:37 +0900 Subject: [PATCH 75/78] modify about 'alwlast' --- src/backend/lineBreak.ml | 12 ++++++------ src/chardecoder/convertText.ml | 8 ++++---- src/chardecoder/lineBreakDataMap.ml | 20 ++++++++++++++++++-- 3 files changed, 28 insertions(+), 12 deletions(-) diff --git a/src/backend/lineBreak.ml b/src/backend/lineBreak.ml index d945a156c..794ff97cd 100644 --- a/src/backend/lineBreak.ml +++ b/src/backend/lineBreak.ml @@ -115,10 +115,10 @@ let append_chunks (chunkacc : line_break_chunk Alist.t) (alwmid : CharBasis.brea end -let convert_pure_box_for_line_breaking_scheme (type a) (listf : horz_box list -> lb_pure_box list) (puref : lb_pure_box -> a) (chunkf : CharBasis.break_opportunity * line_break_chunk list -> a) (alw : CharBasis.break_opportunity) (phb : pure_horz_box) : a = +let convert_pure_box_for_line_breaking_scheme (type a) (listf : horz_box list -> lb_pure_box list) (puref : lb_pure_box -> a) (chunkf : CharBasis.break_opportunity * line_break_chunk list -> a) (alwlast : CharBasis.break_opportunity) (phb : pure_horz_box) : a = match phb with | PHCInnerString(ctx, uchlst) -> - chunkf (ConvertText.to_chunks ctx uchlst alw) + chunkf (ConvertText.to_chunks ctx uchlst alwlast) | PHCInnerMathGlyph(mathinfo, wid, hgt, dpt, otxt) -> puref (LBAtom((natural wid, hgt, dpt), EvHorzMathGlyph(mathinfo, hgt, dpt, otxt))) @@ -185,10 +185,10 @@ let convert_pure_box_for_line_breaking_pure listf (phb : pure_horz_box) : lb_pur convert_pure_box_for_line_breaking_scheme listf puref chunkf CharBasis.PreventBreak phb -let convert_pure_box_for_line_breaking listf alw (phb : pure_horz_box) : lb_either = +let convert_pure_box_for_line_breaking listf alwlast (phb : pure_horz_box) : lb_either = let puref p = LB(LBPure(p)) in let chunkf (alwfirst, c) = TextChunks(alwfirst, c) in - convert_pure_box_for_line_breaking_scheme listf puref chunkf alw phb + convert_pure_box_for_line_breaking_scheme listf puref chunkf alwlast phb let can_break_before tail = @@ -244,8 +244,8 @@ let rec convert_list_for_line_breaking (hblst : horz_box list) : lb_either list aux (Alist.extend lbeacc (LB(LBEmbeddedVertBreakable(dscrid, wid, vblst)))) tail | HorzPure(phb) :: tail -> - let alw = if can_break_before tail then CharBasis.AllowBreak else CharBasis.PreventBreak in - let lbe = convert_pure_box_for_line_breaking convert_list_for_line_breaking_pure alw phb in + let alwlast = if can_break_before tail then CharBasis.AllowBreak else CharBasis.PreventBreak in + let lbe = convert_pure_box_for_line_breaking convert_list_for_line_breaking_pure alwlast phb in aux (Alist.extend lbeacc lbe) tail | HorzFrameBreakable(pads, wid1, wid2, decoS, decoH, decoM, decoT, hblst) :: tail -> diff --git a/src/chardecoder/convertText.ml b/src/chardecoder/convertText.ml index d46c9e0f3..2e982311f 100644 --- a/src/chardecoder/convertText.ml +++ b/src/chardecoder/convertText.ml @@ -9,14 +9,14 @@ open LineBreakBox type chunk_info = context_main * script * line_break_class -let to_chunk_main_list ctx uchlst alw : break_opportunity * line_break_chunk_main list = - let (alwfirst, trilst) = LineBreakDataMap.append_break_opportunity uchlst alw in +let to_chunk_main_list ctx uchlst alwlast : break_opportunity * line_break_chunk_main list = + let (alwfirst, trilst) = LineBreakDataMap.append_break_opportunity uchlst alwlast in let scrlst = ScriptDataMap.divide_by_script ctx trilst in (alwfirst, scrlst) -let to_chunks ctx uchlst alw : break_opportunity * line_break_chunk list = - let (alwfirst, scrlstsp) = to_chunk_main_list ctx uchlst alw in +let to_chunks ctx uchlst alwlast : break_opportunity * line_break_chunk list = + let (alwfirst, scrlstsp) = to_chunk_main_list ctx uchlst alwlast in let chunklst = scrlstsp |> List.map (fun chunkmain -> (ctx, chunkmain)) in diff --git a/src/chardecoder/lineBreakDataMap.ml b/src/chardecoder/lineBreakDataMap.ml index 10edf74c6..64307726c 100644 --- a/src/chardecoder/lineBreakDataMap.ml +++ b/src/chardecoder/lineBreakDataMap.ml @@ -428,7 +428,7 @@ let cut_into_segment_record (bilst : (Uchar.t * line_break_class) list) : segmen let proj_segrcd segrcd = segrcd.line_break_class -let append_break_opportunity (uchlst : Uchar.t list) (alw_last : break_opportunity) : break_opportunity * line_break_element list = +let append_break_opportunity (uchlst : Uchar.t list) (alwlast : break_opportunity) : break_opportunity * line_break_element list = let should_prevent_break (trirev : line_break_element list) segrcdlst = let alwopt = find_first_match line_break_rule proj_tri proj_segrcd trirev segrcdlst in @@ -449,7 +449,23 @@ let append_break_opportunity (uchlst : Uchar.t list) (alw_last : break_opportuni begin match bitail with | [] -> - Alist.to_list (Alist.extend triacc (uchseg, lbc, alw_last)) + let alw = + match alwlast with + | PreventBreak -> + PreventBreak + + | AllowBreak -> +(* + PreventBreak +*) + if segrcd.end_with_ZWJ then + PreventBreak + else + let b = should_prevent_break ((uchseg, lbc, PreventBreak (* dummy *)) :: (Alist.to_list_rev triacc)) bitail in + if b then PreventBreak else AllowBreak + + in + Alist.to_list (Alist.extend triacc (uchseg, lbc, alw)) | _ :: _ -> let alw = From b0d56b6b36af097f1c2cc7bb746dd6c36b4abe36 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 9 Oct 2018 15:28:35 +0900 Subject: [PATCH 76/78] add 'stdjareport.satyh' --- lib-satysfi/dist/packages/stdjareport.satyh | 406 ++++++++++++++++++++ 1 file changed, 406 insertions(+) create mode 100644 lib-satysfi/dist/packages/stdjareport.satyh diff --git a/lib-satysfi/dist/packages/stdjareport.satyh b/lib-satysfi/dist/packages/stdjareport.satyh new file mode 100644 index 000000000..aa2cbfc63 --- /dev/null +++ b/lib-satysfi/dist/packages/stdjareport.satyh @@ -0,0 +1,406 @@ +% -*- coding: utf-8 -*- +@require: pervasives +@require: gr +@require: list +@require: math +@require: color +@require: footnote-scheme + + +module StdJaReport : sig + + val document : 'a -> block-text -> document + constraint 'a :: (| + title : inline-text; + author : inline-text; + |) + + val font-latin-roman : string * float * float + val font-latin-italic : string * float * float + val font-latin-sans : string * float * float + val font-latin-mono : string * float * float + val font-cjk-mincho : string * float * float + val font-cjk-gothic : string * float * float + val set-latin-font : (string * float * float) -> context -> context + val set-cjk-font : (string * float * float) -> context -> context + direct \ref : [string] inline-cmd + direct \ref-page : [string] inline-cmd + direct \figure : [string?; inline-text; block-text] inline-cmd + direct +p : [inline-text] block-cmd + direct +section : [string?; inline-text; block-text] block-cmd + direct +subsection : [string?; inline-text; block-text] block-cmd + direct \emph : [inline-text] inline-cmd + direct \dfn : [inline-text] inline-cmd + direct \footnote : [inline-text] inline-cmd + +end = struct + + type toc-element = + | TOCElementSection of string * inline-text + | TOCElementSubsection of string * inline-text + + + let generate-fresh-label = + let-mutable count <- 0 in + (fun () -> ( + let () = count <- !count + 1 in + `generated:` ^ (arabic (!count)) + )) + + + let-inline ctx \ref key = + let opt = get-cross-reference (key ^ `:num`) in + let it = + match opt with + | None -> {?} + | Some(s) -> embed-string s + in + read-inline ctx it + + + let-inline ctx \ref-page key = + let opt = get-cross-reference (key ^ `:page`) in + let it = + match opt with + | None -> {?} + | Some(s) -> embed-string s + in + read-inline ctx it + + + let font-size-normal = 12pt + let font-size-title = 18pt + let font-size-author = 16pt + let font-size-section = 18pt + let font-size-subsection = 16pt + + let section-top-margin = 20pt + let section-bottom-margin = 12pt + + let font-ratio-latin = 1. + let font-ratio-cjk = 0.88 + + let font-latin-roman = (`Junicode` , font-ratio-latin, 0.) + let font-latin-italic = (`Junicode-it`, font-ratio-latin, 0.) + let font-latin-sans = (`lmsans` , font-ratio-latin, 0.) + let font-latin-mono = (`lmmono` , font-ratio-latin, 0.) + let font-cjk-mincho = (`ipaexm` , font-ratio-cjk , 0.) + let font-cjk-gothic = (`ipaexg` , font-ratio-cjk , 0.) + + + let set-latin-font font ctx = + ctx |> set-font Latin font + + + let set-cjk-font font ctx = + ctx |> set-font HanIdeographic font + |> set-font Kana font + + + let get-standard-context wid = + get-initial-context wid (command \math) + |> set-dominant-wide-script Kana + |> set-language Kana Japanese + |> set-language HanIdeographic Japanese + |> set-dominant-narrow-script Latin + |> set-language Latin English + |> set-font Kana font-cjk-mincho + |> set-font HanIdeographic font-cjk-mincho + |> set-font Latin font-latin-roman + |> set-math-font `lmodern` + |> set-hyphen-penalty 100 + + + let-mutable ref-float-boxes <- [] + + + let height-of-float-boxes pageno = +% let () = display-message `get height` in + (!ref-float-boxes) |> List.fold-left (fun h (pn, bb) -> ( + if pn < pageno then h +' (get-natural-length bb) else h + )) 0pt + + + let-mutable ref-figure <- 0 + + + let-inline ctx \figure ?:labelopt caption inner = + let () = ref-figure <- !ref-figure + 1 in + let s-num = arabic (!ref-figure) in + let () = + match labelopt with + | Some(label) -> register-cross-reference (label ^ `:num`) s-num + | None -> () + in + let it-num = embed-string s-num in + let bb-inner = + let d (_, _) _ _ _ = [] in + block-frame-breakable ctx (2pt, 2pt, 2pt, 2pt) (d, d, d, d) (fun ctx -> ( + read-block ctx inner + +++ line-break true true ctx (inline-fil ++ read-inline ctx {図#it-num; #caption;} ++ inline-fil) + )) + in + hook-page-break (fun pbinfo _ -> ( +% let () = display-message (`register` ^ (arabic pbinfo#page-number)) in + ref-float-boxes <- (pbinfo#page-number, bb-inner) :: !ref-float-boxes + )) + + + let make-section-title ctx = + ctx |> set-font-size font-size-section + |> set-font Latin font-latin-sans + |> set-cjk-font font-cjk-gothic + + + let make-subsection-title ctx = + ctx |> set-font-size font-size-subsection + |> set-font Latin font-latin-sans + |> set-cjk-font font-cjk-gothic + + + let-mutable toc-acc-ref <- [] + + + let get-cross-reference-number label = + match get-cross-reference (label ^ `:num`) with + | None -> `?` + | Some(s) -> s + + + let get-cross-reference-page label = + match get-cross-reference (label ^ `:page`) with + | None -> `?` + | Some(s) -> s + + + let section-heading ctx ib-heading = + line-break true false + (ctx |> set-paragraph-margin section-top-margin section-bottom-margin) + ib-heading + + + let-inline ctx \dummy it = + let ib = read-inline (ctx |> set-text-color Color.white) it in + let w = get-natural-width ib in + ib ++ inline-skip (0pt -' w) + + + let document record inner = + % -- constants -- + let title = record#title in + let author = record#author in + let page = A4Paper in + let txtorg = (80pt, 100pt) in + let txtwid = 440pt in + let txthgt = 630pt in + let hdrorg = (40pt, 30pt) in + let ftrorg = (40pt, 780pt) in + let hdrwid = 520pt in + let ftrwid = 520pt in + + let () = + register-cross-reference `changed` `F` + in + + let ctx-doc = get-standard-context txtwid in + + % -- title -- + let bb-title = + let bb-title-main = + let ctx = + ctx-doc |> set-font-size font-size-title + in + line-break false false ctx + (inline-fil ++ read-inline ctx title ++ inline-fil) + in + let bb-author = + let ctx = + ctx-doc |> set-font-size font-size-author + in + line-break false false ctx + (inline-fil ++ read-inline ctx author ++ inline-fil) + in + bb-title-main +++ bb-author + in + + % -- main -- + let bb-main = read-block ctx-doc inner in + + % -- page settings -- + let pagecontf pbinfo = + let () = FootnoteScheme.start-page () in + let hgtfb = height-of-float-boxes pbinfo#page-number in + let (txtorgx, txtorgy) = txtorg in + (| + text-origin = (txtorgx, txtorgy +' hgtfb); + text-height = txthgt -' hgtfb; + |) + in + let pagepartsf pbinfo = + let pageno = pbinfo#page-number in + let header = + let ctx = + get-standard-context hdrwid + |> set-paragraph-margin 0pt 0pt + in + let ib-text = + if pageno mod 2 == 0 then + (inline-fil ++ read-inline ctx title) + else + (read-inline ctx title ++ inline-fil) + in +% let () = display-message `insert` in + let (bb-float-boxes, acc) = + (!ref-float-boxes) |> List.fold-left (fun (bbacc, acc) elem -> ( + let (pn, bb) = elem in + if pn < pageno then + let bbs = + line-break true true (ctx |> set-paragraph-margin 0pt 12pt) + (inline-fil ++ embed-block-top ctx txtwid (fun _ -> bb) ++ inline-fil) + % 'ctx' is a dummy context + in + (bbacc +++ bbs, acc) + else + (bbacc, elem :: acc) + )) (block-nil, []) + in + let () = ref-float-boxes <- acc in + bb-float-boxes + in + let footer = + let ctx = get-standard-context ftrwid in + let it-pageno = embed-string (arabic pbinfo#page-number) in + line-break true true ctx + (inline-fil ++ (read-inline ctx {— #it-pageno; —}) ++ inline-fil) + in + (| + header-origin = hdrorg; + header-content = header; + footer-origin = ftrorg; + footer-content = footer; + |) + in + page-break page pagecontf pagepartsf (bb-title +++ bb-main) + + + let-mutable needs-indentation-ref <- true + + let-mutable num-section <- 0 + let-mutable num-subsection <- 0 + + + let quad-indent ctx = + inline-skip (get-font-size ctx *' font-ratio-cjk) + + + let-block ctx +p inner = + let needs-indentation = + if !needs-indentation-ref then true else + let () = needs-indentation-ref <- true in + false + in + let ib-inner = read-inline ctx inner in + let ib-parag = + if needs-indentation then + (quad-indent ctx) ++ ib-inner ++ inline-fil + else + ib-inner ++ inline-fil + in + form-paragraph ctx ib-parag + + + let section-scheme ctx label title inner = + let ctx-title = make-section-title ctx in + let () = increment num-section in + let () = num-subsection <- 0 in + let s-num = arabic (!num-section) in + let () = register-cross-reference (`section:` ^ label ^ `:num`) s-num in + let () = toc-acc-ref <- (TOCElementSection(label, title)) :: !toc-acc-ref in + let ib-num = + read-inline ctx-title (embed-string (s-num ^ `.`)) + ++ hook-page-break (fun pbinfo _ -> ( + let pageno = pbinfo#page-number in + register-cross-reference (`section:` ^ label ^ `:page`) (arabic pageno))) + in + let ib-title = read-inline ctx-title title in + let bb-title = section-heading ctx (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil)) in + let bb-inner = read-block ctx inner in + bb-title +++ bb-inner + + + let subsection-scheme ctx label title inner = + let () = num-subsection <- !num-subsection + 1 in + let () = needs-indentation-ref <- false in + let s-num = arabic (!num-section) ^ `.` ^ arabic (!num-subsection) in + let () = register-cross-reference (label ^ `:num`) s-num in + let () = toc-acc-ref <- (TOCElementSubsection(label, title)) :: !toc-acc-ref in + let ctx-title = make-subsection-title ctx in + let ib-num = + read-inline ctx-title (embed-string (s-num ^ `.`)) + ++ hook-page-break (fun pbinfo _ -> register-cross-reference (label ^ `:page`) (arabic pbinfo#page-number)) + in + let ib-title = read-inline ctx-title title in + let bb-title = + line-break true false (ctx |> set-paragraph-margin section-top-margin section-bottom-margin) + (ib-num ++ (inline-skip 10pt) ++ ib-title ++ (inline-fil)) + in + let bb-inner = read-block ctx inner in + bb-title +++ bb-inner + + + let-block ctx +section ?:labelopt title inner = + let label = + match labelopt with + | None -> generate-fresh-label () + | Some(label) -> label + in + section-scheme ctx label title inner + + + let-block ctx +subsection ?:labelopt title inner = + let label = + match labelopt with + | None -> generate-fresh-label () + | Some(label) -> label + in + subsection-scheme ctx label title inner + + + let-inline ctx \emph inner = + let ctx = + ctx |> set-font Latin font-latin-sans + |> set-cjk-font font-cjk-gothic + in + read-inline ctx inner + + + let-inline \dfn inner = {\emph{#inner;}} + + + let-inline ctx \footnote it = + let size = get-font-size ctx in + let ibf num = + let it-num = embed-string (arabic num) in + let ctx = + ctx |> set-font-size (size *' 0.75) + |> set-manual-rising (size *' 0.25) + in + read-inline ctx {\*#it-num;} + in + let bbf num = + let it-num = embed-string (arabic num) in + let ctx = + ctx |> set-font-size (size *' 0.9) + |> set-leading (size *' 1.2) + |> set-paragraph-margin (size *' 0.5) (size *' 0.5) + %temporary + in + line-break false false ctx (read-inline ctx {#it-num; #it;} ++ inline-fil) + in + FootnoteScheme.main ctx ibf bbf + + end + + +let document = StdJaReport.document + % ad-hoc From eb5a6b5c042b48038cb4ce608c99e3999586e7f2 Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 9 Oct 2018 15:29:08 +0900 Subject: [PATCH 77/78] update 'standalone.satyh' --- lib-satysfi/dist/packages/standalone.satyh | 1 + 1 file changed, 1 insertion(+) diff --git a/lib-satysfi/dist/packages/standalone.satyh b/lib-satysfi/dist/packages/standalone.satyh index 450a9ab84..d6eb47de6 100644 --- a/lib-satysfi/dist/packages/standalone.satyh +++ b/lib-satysfi/dist/packages/standalone.satyh @@ -6,6 +6,7 @@ let standalone bt = let ctx = get-initial-context 440pt (command \math) |> set-dominant-narrow-script Latin + |> set-dominant-wide-script Kana in let bb = read-block ctx bt in page-break A4Paper From c61df7b62f282b3f18cd14203ac93601f2964f6b Mon Sep 17 00:00:00 2001 From: gfngfn Date: Tue, 9 Oct 2018 16:14:33 +0900 Subject: [PATCH 78/78] update CHANGELOG --- CHANGELOG.md | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2381d0b85..e44920054 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,16 +2,15 @@ All notable changes to this project will be documented in this file. -The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) -and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## [Unreleased] +## [0.0.3] - 2018-10-09 ### Fixed -- Does NOT insert spacing between different scripts when the line breaking class of the posterior charcter is CL, CP, QU, NS, JLCP, JLNS, JLCM, or JLFS +- Does NOT insert spacing between different scripts when the [line breaking class](http://unicode.org/reports/tr14/) of the posterior charcter is CL, CP, QU, NS, JLCP, JLNS, JLCM, or JLFS. -# Changed -- Supports the application of math commands to optional arguments -- Add `set-space-ratio-between-scripts` and `get-space-ratio-between-scripts` +# Added +- Supports the application of math commands to optional arguments. +- Provides primitives `set-space-ratio-between-scripts` and `get-space-ratio-between-scripts`. ## [0.0.2] - 2018-08-09 ### Fixed