#!/usr/bin/env cash (* # vim:ft=ocaml *) (* adobe-font-tool $Id: otftofd 7 2005-09-10 21:25:47Z geoffw $ Copyright Geoffrey Alan Washburn, 2005. You can redistribute and/or modify this software under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You may obtain the GNU General Public License by writing to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) #load "str.cma";; open Cash;; open Str;; open List;; (******************************************************************************) (* Define this here just in case, but we'll overwrite it later *) let program_name : string ref = ref "otftofd" (******************************************************************************) (* Small general helper functions *) (* Print an error message and exit with an error code *) let error (msg : string) : 'a = begin print_string ((!program_name) ^ " (error) : " ^ msg ^ "\n"); exit 1 end (* Print an warning message *) let warning (msg : string) : unit = print_string ((!program_name) ^ " (warning): " ^ msg ^ "\n") (******************************************************************************) (* Define these in case we need to change them later/dynamically *) let dirsep = "/" let pathsep = ":" (******************************************************************************) (* Check whether a programs exists in a given directory *) let prog_exists_dir (prog : string) (dir : string) = if (is_file_directory_fn dir) then is_file_executable_fn (dir ^ dirsep ^ prog) else (error ("Tried to check the existence of program " ^ prog ^ " in non-directory " ^ dir)) (* basename *) let basename (fn : string) = let parts = Str.split (regexp dirsep) fn in let rec last (l : string list) : string = (match l with | [] -> (error "Argument to basename doesn't have a basecase?!") | [base] -> base | h::t -> last t) in last (parts) (* Check whether a program exists in the users path *) let prog_exists_path (prog : string) : bool = exists (prog_exists_dir prog) (exec_path_list ()) (* Run a program and return the output as a string *) let system (prog : string) (args : string list) : string = run_with_string (fun _ -> exec_path prog args) (******************************************************************************) (* Define the various datatypes *) (* Font encodings - not entirely implemented yet FIX *) type encoding = | OML (* Original TeX math text encoding: ?? *) | OMS (* Original TeX math symbol encoding: ?? *) | OMX (* Original TeX math extended symbol encoding: ?? *) | OT1 (* Original TeX encoding: ?? *) | OT2 (* ??: ?? *) | OT4 (* ??: ?? *) | QX (* ??: ?? *) | T1 (* TeX Cork encoding: cork, tex256 *) | T2 (* ??: ?? *) | T5 (* ??: ?? *) | TS1 (* ??: ?? *) | U (* Unknown encoding: ?? *) | LY1 (* ??: texnansx *) (* NFSS Weights *) type weight = | UltraLightWeight | ExtraLightWeight | LightWeight | SemiLightWeight | MediumWeight | SemiBoldWeight | BoldWeight | ExtraBoldWeight | UltraBoldWeight (* NFSS Widths *) type width = | UltraCondensedWidth | ExtraCondensedWidth | CondensedWidth | SemiCondensedWidth | MediumWidth | SemiExpandedWidth | ExpandedWidth | ExtraExpandedWidth | UltraExpandedWidth (* NFSS Shapes *) type shape = | UprightShape | ItalicShape | SlantedShape | SmallCapsShape | UprightItalicShape | OutlineShape (* OpenType features *) type feature = | Faalt (* access all alternates *) | Fc2sc (* small captials from capitals *) | Fcalt (* contextual alternatives *) | Fcase (* case sensitive forms *) | Fcpsp (* captial spacing *) | Fcswh (* contextual swash *) | Fdlig (* discrentionary ligatures *) | Fdnom (* denominators *) | Ffina (* terminal forms *) | Ffrac (* fractions *) | Fhist (* historical forms *) | Fkern (* kerning *) | Fliga (* standard ligatures *) | Flnum (* lining figures *) | Fnumr (* numerators *) | Fonum (* old style numbers *) | Fordn (* ordinals *) | Fornm (* Ornaments *) | Fpnum (* proportional figures *) | Fsalt (* stylistic alternatives *) | Fsinf (* scientific inferiors *) | Fsize (* optical sizes *) | Fsmcp (* small caps *) | Fss of int (* Stylistic sets *) | Fsups (* superscript *) | Fswsh (* swash *) | Ftnum (* tabular figures *) | Fzero (* slashed zero *) (* Ranges used to describe optical coverage for a font *) type range = | Greater of float | Less of float | Between of (float * float) | All (******************************************************************************) (* Convert an encoding to a string *) let encodingToString (enc : encoding) = (match enc with | OML -> "OML" | OMS -> "OMS" | OMX -> "OMX" | OT1 -> "OT1" | OT2 -> "OT2" | OT4 -> "OT4" | QX -> "QX" | T1 -> "T1" | T2 -> "T2" | T5 -> "T5" | TS1 -> "TS1" | LY1 -> "LY1" | U -> "U") let parseEncoding (enc : string) : encoding = (match (String.uppercase enc) with | "OML" -> OML | "OMS" -> OMS | "OMX" -> OMX | "OT1" -> OT1 | "OT2" -> OT2 | "OT4" -> OT4 | "QX" -> QX | "T1" -> T1 | "T2" -> T2 | "T5" -> T5 | "TS1" -> TS1 | "LY1" -> LY1 | "U" -> U | _ -> error ("Unknown font encoding " ^ enc)) (* Convert an encoding name to a default encoding file, not entirely correct yet. *) let encodingToFile (enc : encoding) = let encwarn () = warning ("Presently, encoding " ^ (encodingToString enc) ^ " is not directly supported.\nTry using --encFile=file to specify an encoding file. ") in (match enc with | OML -> (encwarn (); "-") | OMS -> (encwarn (); "-") | OMX -> (encwarn (); "-") | OT1 -> (encwarn (); "-") | OT2 -> (encwarn (); "-") | OT4 -> (encwarn (); "-") | QX -> (encwarn (); "-") | T1 -> "cork" | T2 -> (encwarn (); "-") | T5 -> (encwarn (); "-") | TS1 -> (encwarn (); "-") | LY1 -> "texnansx" | U -> (encwarn (); "-")) (* Convert a feature to a string *) let featureToString (feat : feature) = (match feat with | Faalt -> "aalt" | Fc2sc -> "c2sc" | Fcalt -> "calt" | Fcase -> "case" | Fcpsp -> "cpsp" | Fcswh -> "cswh" | Fdlig -> "dlig" | Fdnom -> "dnom" | Ffina -> "fina" | Ffrac -> "frac" | Fhist -> "hist" | Fkern -> "kern" | Fliga -> "liga" | Flnum -> "lnum" | Fnumr -> "numr" | Fonum -> "onum" | Fordn -> "ordn" | Fornm -> "ornm" | Fpnum -> "pnum" | Fsalt -> "salt" | Fsinf -> "sinf" | Fsize -> "size" | Fsmcp -> "smcp" | Fss(n) -> if((n >= 1) || (n<=20)) then "ss" ^ (string_of_int n) else (error "Invalid style set") (* FIX -- this doesn't output leading zeros :-( *) | Fsups -> "sups" | Fswsh -> "swsh" | Ftnum -> "tnum" | Fzero -> "zero") (* Convert a weight to a string *) let weightToString (wght : weight) = (match wght with | UltraLightWeight -> "ul" | ExtraLightWeight -> "el" | LightWeight -> "l" | SemiLightWeight -> "sl" | MediumWeight -> "m" | SemiBoldWeight -> "sb" | BoldWeight -> "b" | ExtraBoldWeight -> "eb" | UltraBoldWeight -> "ub") (* Convert a width to a string *) let widthToString (wdth : width) = (match wdth with | UltraCondensedWidth -> "uc" | ExtraCondensedWidth -> "ec" | CondensedWidth -> "c" | SemiCondensedWidth -> "sc" | MediumWidth -> "m" | SemiExpandedWidth -> "sx" | ExpandedWidth -> "x" | ExtraExpandedWidth -> "ex" | UltraExpandedWidth -> "ux") (* Convert a shape to a string *) let shapeToString (shp : shape) = (match shp with | UprightShape -> "n" | ItalicShape -> "it" | SlantedShape -> "sl" | SmallCapsShape -> "sc" | UprightItalicShape -> (error "FIX") | OutlineShape -> (error "FIX")) (* Convert a range to a string *) let rangeToString (rng : range) : string = (match rng with | Greater f -> "<" ^ (string_of_float f) ^ "->" | Less f -> "<-" ^ (string_of_float f) ^ ">" | Between (s,e) -> "<" ^ (string_of_float s) ^ "-" ^ (string_of_float e) ^ ">" | All -> "<->" ) (* Compare to ranges -- kind of broken, but works well enough at the moment *) let compareRngs (rng1 : range) (rng2 : range) : int = (match (rng1, rng2) with (* Slapdash comparison heurisitic *) | (All, All) -> 0 | (_, All) -> -1 | (All, _) -> 1 | (Greater f1, Greater f2) -> compare f1 f2 | (Less f1, Less f2) -> compare f1 f2 | (Greater f1, Less f2) -> compare f1 f2 | (Less f1, Greater f2) -> compare f1 f2 | (Less f, Between (s,e)) -> if (f < e) then -1 else if (f >= e) then 1 else 0 | (Between (s,e), Less f) -> if (f < e) then -1 else if (f >= e) then 1 else 0 | (Greater f, Between (s,e)) -> if (f < e) then -1 else if (f >= e) then 1 else 0 | (Between (s,e), Greater f) -> if (f < e) then -1 else if (f >= e) then 1 else 0 | (Between (s1, e1), Between (s2, e2)) -> if (e1 < s1) then -1 else if (s1 >= e2) then 1 else if (e1 < e2) then -1 else if (e1 >= e2) then 1 else 0 ) (* Create a series string from width and weight *) let createSeries (wght : weight) (wdth : width) = (match wght with | MediumWeight -> (match wdth with | MediumWidth -> "m" | _ -> widthToString wdth) | _ -> (match wdth with | MediumWidth -> weightToString wght | _ -> (weightToString wght) ^ (widthToString wdth))) (******************************************************************************) (* Global configuration constants *) let encoding : encoding ref = ref T1 let encodingFile : (string option) ref = ref None (* Should we show the usage information instead of doing anything? *) let showUsage : bool ref = ref false (* Generate a version of the fonts with swashes *) let swashVersion : bool ref = ref false (* Generate a version of the fonts with just ornaments *) let ornamentVersion : bool ref = ref false (* Should we print more info about what we are doing? *) let verbose : bool ref = ref false (******************************************************************************) (* Heuristics *) (* Try to infer a weight from the attribute string in the filename *) let parseWeight (attr : string) = if (string_match (regexp ".*\\(Black\\|Bold\\|Bd\\|Semibold\\|Regular\\|ExtraLight\\|Light\\|Lt\\).*") attr 0) then (match (matched_group 1 attr) with (* We assume black is ExtraBold rather than UltraBold *) | "Black" -> Some (ExtraBoldWeight) | ("Bold"|"Bd") -> Some (BoldWeight) | "Semibold" -> Some (SemiBoldWeight) | "Regular" -> Some (MediumWeight) (* Disambiguate *) | ("Light"|"Lt") -> if (string_match (regexp ".*ExtraLight.*") attr 0) then Some (ExtraLightWeight) else Some (LightWeight) | _ -> (error "Shouldn't have matched!")) else None (* Try to infer a width from the attribute string in the filename *) let parseWidth (attr : string) = if (string_match (regexp ".*\\(Regular\\|Cond\\|SemiCn\\|Cn\\|SemiExt\\).*") attr 0) then (match (matched_group 1 attr) with | "SemiExt" -> Some (SemiExpandedWidth) | "Regular" -> Some (MediumWidth) | ("Cond"|"Cn") -> (* Disambiguate *) if (string_match (regexp ".*SemiCn.*") attr 0) then Some (SemiCondensedWidth) else Some (CondensedWidth) | _ -> (error "Shouldn't have matched!")) else None (* Try to infer a shape from the attribute string in the filename *) let parseShape (attr : string) = if (string_match (regexp ".*\\(Regular\\|It\\|Italic\\|Slanted\\).*") attr 0) then (match (matched_group 1 attr) with | ("Italic"|"It") -> Some (ItalicShape) | "Regular" -> Some (UprightShape) | "Slanted" -> Some (SlantedShape) | _ -> (error "Shouldn't have matched!")) else None (* Try to infer a design size from the attribute string in the filename *) let parseDesign (attr : string) = if (string_match (regexp ".*\\(Regular\\|Capt\\|Disp\\|Headline\\|Subh\\).*") attr 0) then (match (matched_group 1 attr) with (* otfinfo gives slightly different numbers for different fonts, so just use these as an estimate if otfinfo is unavailable or doesn't provide feedback *) | ("Disp"|"Headline") -> Some (20.1,72.0) | "Subh" -> Some (13.1, 20.0) | "Regular" -> Some (9.0, 13.0) | "Capt" -> Some (6.0, 8.9) | _ -> (error "Shouldn't have matched!")) else None (* Attempt to figure out stuff about the font just from the name *) let parseFileName (fn : string) = let parts = Str.split (regexp "[-\\.]") fn in (match parts with | [name; attr; ext] -> if (ext = "otf") then (name, parseWeight attr, parseWidth attr, parseShape attr, parseDesign attr) else error ("Filename \"" ^ fn ^ "\" does not appear to be an OpenType file") | [name; ext] -> if (ext = "otf") then (name, None, None, None, None) else error ("Filename \"" ^ fn ^ "\" does not appear to be an OpenType file") | _ -> error ("Error parsing filename \"" ^ fn ^ "\"")) (******************************************************************************) (* Constants used when optimizing ranges *) let minrange = 1.0 let maxrange = 144.0 (* Optimize font ranges *) let optRanges (rngs : (range * (string * string list)) list) : (range * (string * string list)) list = (* First sort them *) let sorted = sort (fun (rng1, _) (rng2, _) -> compareRngs rng1 rng2) rngs in (* Extend the ranges so that we have everything as small as minrange pt *) let cover_bottom rngs = (match rngs with | [] -> (error "Font must have at least one range!") | (Greater f, stf)::tl -> (Greater minrange, stf)::tl | (Less f, stf)::tl -> (Less f, stf)::tl | (Between (s,e), stf)::tl -> (Between (minrange, e), stf)::tl | (All, stf)::tl -> (All, stf)::tl) in (* Extend the ranges so that we have everything as large as maxrange pt *) let rec cover_top rngs = (match rngs with | [] -> (error "Font must have at least one range!") | [(Greater f, stf)] -> [(Greater f, stf)] | [(Less f, stf)] -> [(Less maxrange, stf)] | [(Between (s,e), stf)] -> [(Between (s, maxrange), stf)] | [(All, stf)] -> [(All, stf)] | hd::tl -> hd::(cover_top tl)) in let rec remove_gaps rngs = (match rngs with | [] -> (error "Font must have at least one range!") | [(rng, stf)] -> [(rng, stf)] | (rng1, stf1)::(rng2, stf2)::tl -> (match (rng1, rng2) with (* All can't have a gap *) | (All, _) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) (* Greater can't have a gap *) | (Greater _, _) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) (* Less followed by less or all can't have a gap *) | (Less _, Less _) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Less _, All) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Less f1, Greater f2) -> (Less f2, stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Less f, Between (s,e)) -> (Less s, stf1)::(remove_gaps ((rng2,stf2)::tl)) (* Between followed by less or all can't have a gap *) | (Between (s, e), Less f) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Between (s, e), All) -> (rng1, stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Between (s, e), Greater f) -> (Between(s, f), stf1)::(remove_gaps ((rng2,stf2)::tl)) | (Between (s1,e1), Between (s2,e2)) -> (Between (s1,s2), stf1)::(remove_gaps ((rng2,stf2)::tl)) )) in remove_gaps (cover_bottom (cover_top sorted)) (******************************************************************************) (* Feature parsing *) (* This is a list of regexps and handler functions *) let featureHandlers = [ ("aalt", (fun _ -> Faalt)); ("c2sc", (fun _ -> Fc2sc)); ("calt", (fun _ -> Fcalt)); ("case", (fun _ -> Fcase)); ("cpsp", (fun _ -> Fcpsp)); ("cswh", (fun _ -> Fcswh)); ("dlig", (fun _ -> Fdlig)); ("dnom", (fun _ -> Fdnom)); ("fina", (fun _ -> Ffina)); ("frac", (fun _ -> Ffrac)); ("hist", (fun _ -> Fhist)); ("kern", (fun _ -> Fkern)); ("liga", (fun _ -> Fliga)); ("lnum", (fun _ -> Flnum)); ("numr", (fun _ -> Fnumr)); ("onum", (fun _ -> Fonum)); ("ordn", (fun _ -> Fordn)); ("ornm", (fun _ -> Fornm)); ("pnum", (fun _ -> Fpnum)); ("salt", (fun _ -> Fsalt)); ("sinf", (fun _ -> Fsinf)); ("size", (fun _ -> Fsize)); ("smcp", (fun _ -> Fsmcp)); ("smcp", (fun _ -> Fsmcp)); ("ss[0-9][0-9]", (fun str -> let numstr = (last_chars str 2) in try let n = int_of_string numstr in if((n >= 1) || (n<=20)) then Fss(n) else (error "Invalid style set while parsing features") with Failure msg -> (error "Invalid style set while parsing features"))); ("sups", (fun _ -> Fsups)); ("swsh", (fun _ -> Fswsh)); ("tnum", (fun _ -> Ftnum)); ("zero", (fun _ -> Fzero)) ] (* Call otfinfo to obtain a list of features for the specified filename *) let parseOTFFeatures (fn : string) : feature list = let result = system "otfinfo" ["-f"; fn] in let rec buildFeatures handlers features = (match handlers with | [] -> (rev features) | (rx, handlerFun)::hs -> if (string_match (regexp ("\\(.\\|\n\\)*\\(" ^ rx ^ "\\)\\(.\\|\n\\)*")) result 0) then buildFeatures hs ((handlerFun (matched_group 2 result))::features) else buildFeatures hs features) in buildFeatures featureHandlers [] (******************************************************************************) (* Parsing design size *) (* See if otfinfo can give us a design size as well as a size range *) let parseOTFSize (fn : string) : (float * float * float) option = let result = system "otfinfo" ["-z"; fn] in (* Abstract out the regex for a decimal number *) let dec_num = "[0-9]+\\(\\.[0-9]+\\)?" in if (string_match (regexp ("design size \\(" ^ dec_num ^ "\\) pt, size range \\((\\|\\[\\)\\(" ^ dec_num ^ "\\) pt, \\(" ^ dec_num ^ "\\) pt\\()\\|\\]\\), .*")) result 0) then Some (float_of_string (matched_group 1 result), float_of_string (matched_group 4 result), float_of_string (matched_group 6 result)) else None (******************************************************************************) (* The primary datastructure that we use to construct all of the necessary output familes -- table of all the font families we have encountered shapes -- each family has a table of shapes that it supports weights -- each shape table has a table of weights it supports widths -- each weight table has a table of widths it supports ranges -- each width table has a list of optical ranges, should not overlap. impl -- each range has an associated implementation with it, that is a pair of the file that we are using to get this particular instance and the options that we need to pass to otftotfm to generate it *) (* Create one of size five, don't expect to run this on more than a couple families *) let families = Hashtbl.create 5 let allocate_family (fam : string) : unit = (* Check to see if this family already exists *) if (not (Hashtbl.mem families fam)) then (* Create seven entries for shapes, as we don't recognize any more than six at this point *) Hashtbl.add families fam (Hashtbl.create 7) else () (* Allocate an entry in the font table *) let allocate_entry (fam : string) (shp : shape) (wght : weight) (wdth : width) (rng : range) (fn : string) (opts : string list) = let shpTable = (* Check to see if this family already exists *) try Hashtbl.find families fam (* If not, create it *) with Not_found -> (* Create seven entries for shapes, as we don't recognize any more than six at this point *) let tbl = Hashtbl.create 7 in (Hashtbl.add families fam tbl; tbl) in let wghtTable = (* Check to see if this table already exists *) try Hashtbl.find shpTable shp (* If not, create it *) with Not_found -> (* Create ten entries for weights, as we don't recognize any more than nine at this point *) let tbl = Hashtbl.create 10 in (Hashtbl.add shpTable shp tbl; tbl) in let wdthTable = (* Check to see if this table already exists *) try Hashtbl.find wghtTable wght (* If not, create it *) with Not_found -> (* Create ten entries for widthd, as we don't recognize any more than nine at this point *) let tbl = Hashtbl.create 10 in (Hashtbl.add wghtTable wght tbl; tbl) in let rngList = (* Check to see if there is already a list of ranges *) try Hashtbl.replace wdthTable wdth ((rng,(fn, opts))::(Hashtbl.find wdthTable wdth)) (* If not, create it *) with Not_found -> Hashtbl.add wdthTable wdth [(rng, (fn, opts))] in () (***************************************************************************) (* Check for a specified feature *) let rec checkFeature (feat : feature) (feats : feature list) : bool = (match feats with | [] -> false | hd::tl -> if (hd = feat) then true else checkFeature feat tl) (* Given the fonts features and the shape we inferred from the filename, figure out what shapes it supports and the options necessary to generate them *) let decideShapes (shpopt : shape option) (feats : feature list) : (shape * string list) list = (* Look at what we decided from the filename *) (match shpopt with (* If it is upright we might also want to check for smallcaps *) | Some(UprightShape) -> if (checkFeature Fsmcp feats) then [(UprightShape, []); (SmallCapsShape, ["-fsmcp"])] else [(UprightShape, [])] (* OpenType allows "other" shapes to also have smallcaps shapes, but NFSS doesn't support mixing shapes like that at the moment, so we will just ignore the smallcaps capabilities *) | Some(shp) -> [(shp, [])] (* If we didn't get a shape from the filename, assume upright, and check for smallcaps *) | None -> if (checkFeature Fsmcp feats) then [(UprightShape, []); (SmallCapsShape, ["-fsmcp"])] else [(UprightShape, [])]) (* Decide the weight of a font, not very interesting because we only rely upon what we guessed from the filename *) (* FIX: Should also attempt to consult otfinfo *) let decideWeight (wghtopt : weight option) : weight = (match wghtopt with (* If we inferred a weight, use it *) | Some(wght) -> wght (* If we didn't assume that this is a medium weight font *) | None -> MediumWeight) (* Decide the width of a font, not very interesting because we only rely upon what we guessed from the filename *) (* FIX: Should also attempt to consult otfinfo *) let decideWidth (wdthopt : width option) : width = (match wdthopt with (* If we inferred a weight, use it *) | Some(wdth) -> wdth (* If we didn't assume that this is a medium weight font *) | None -> MediumWidth) (* See if we can determine an optical size *) let decideSize (dsnopt : (float * float) option) (feats : feature list) (otfsize : (float * float * float) option) : range = (* Does this font include an optical size feature? *) if (checkFeature Fsize feats) then (* Yes, use it *) (match otfsize with | Some(_, s, e) -> Between (s, e) | None -> (error "Shouldn't be possible!") ) else All (* Turn this off for now, doesn't seem to really work well (* Nope, try guessing based upon the name *) (match dsnopt with | Some (s, e) -> Between (s, e) | None -> All) *) (* Table building inner loop *) let build_table_inner (fn : string) (family : string) (wghtopt : weight option) (wdthopt : width option) (dsnopt : (float * float) option) (shp : shape) (features : feature list) (opts : string list) = let otfsize = parseOTFSize fn in (* Always add default ligatures, kerning, and terminal forms if they are available *) let opts = if (checkFeature Fliga features) then "-fliga"::opts else opts in let opts = if (checkFeature Fkern features) then "-fkern"::opts else opts in let opts = if (checkFeature Ffina features) then "-ffina"::"--boundary-char= "::opts else opts in begin (* Allocate entries in the table *) allocate_entry family shp (decideWeight wghtopt) (decideWidth wdthopt) (decideSize dsnopt features otfsize) fn opts end (* Fill in the appropriate entries in the family table for the given filename *) let build_table (swash : bool) (orn : bool) (fn : string) = let (family, wghtopt, wdthopt, shpopt, dsnopt) = parseFileName fn in let features = parseOTFFeatures fn in begin (* For each shape we have ... *) fold_left (fun _ (shp, opts) -> if swash then if ((checkFeature Fswsh features) && (checkFeature Fcswh features)) then let opts = "-fswsh"::"-fcswh"::opts in build_table_inner fn family wghtopt wdthopt dsnopt shp features opts else (* No swashes, so don't do anything *) () else if orn then if (checkFeature Fornm features) then let opts = "-fornm"::opts in build_table_inner fn family wghtopt wdthopt dsnopt shp features opts else (* No ornaments, so don't do anything *) () else build_table_inner fn family wghtopt wdthopt dsnopt shp features opts) () (decideShapes shpopt features) end (* Generate the "Texname" for a given font from the filename and options *) let genTexname (fn : string) (enc : encoding) (opts : string list) = let rec filteropts (opts : string list) : string list = (match opts with | [] -> [] | h::t -> if (string_match (regexp "-f.*") h 0) then h::(filteropts t) else (filteropts t)) in let fopts = filteropts opts in let parts = Str.split (regexp "\\.") fn in (match parts with | [name; ext] -> if (ext = "otf") then (encodingToString enc) ^ "-" ^ name ^ (String.concat "" fopts) else error ("Filename \"" ^ fn ^ "\" does not appear to be an OpenType file") | _ -> error ("Error parsing filename \"" ^ fn ^ "\"")) (******************************************************************************) (* Generate a list of NFSS font descriptor files *) let genFdFile (enc : encoding) : (string * string) list = Hashtbl.fold (fun family shpTable files -> (((encodingToString enc) ^ family ^ ".fd"), "\\DeclareFontFamily{" ^ (encodingToString enc) ^ "}{" ^ family ^ "}{}\n" ^ (Hashtbl.fold (fun shp wghtTable accum -> Hashtbl.fold (fun wght wdthTable accum -> Hashtbl.fold (fun wdth rngs accum -> ("\\DeclareFontShape{" ^ (encodingToString enc) ^ "}{" ^ family ^ "}{" ^ (createSeries wght wdth) ^ "}{" ^ (shapeToString shp) ^ "}{" ^ (fold_left (fun accum (rng, (fn, opts)) -> accum ^ " " ^ (rangeToString rng) ^ " " ^ (genTexname fn enc opts) ^ " ") "" (optRanges rngs) ) ^ "}{ }\n" ^ accum) ) wdthTable accum ) wghtTable accum ) shpTable "\n" ) )::files ) families [] (******************************************************************************) type map_special = | SlantFontSpecial of float | ExtendFontSpecial of float type std_psfont = | TimesRomanPS | TimesItalicPS | TimesBoldPS | TimesBoldItalicPS | HelveticaPS | HelveticaObliquePS | HelveticaBoldPS | HelveticaBoldObliquePS | CourierPS | CourierObliquePS | CourierBoldPS | CourierBoldObliquePS | SymbolPS type map_embed = | PartialEmbed | FullEmbed | NoEmbed (* tfmname, psbasename, fontflags, specials, encoding file *) type map_entry = | MapFile of string * string option * (* map_fontflags option * FIX *) map_special list * string option * map_embed * string | PSFile of string * std_psfont * (* map_fontflags option * FIX *) map_special list * string option (******************************************************************************) (* Generate a list of map files by running otftotfm*) let genMapFile () : (string * string) list = Hashtbl.fold (fun family shpTable files -> ((family ^ ".map"), Hashtbl.fold (fun shp wghtTable accum -> Hashtbl.fold (fun wght wdthTable accum -> Hashtbl.fold (fun wdth rngs accum -> (fold_left (fun accum (rng, (fn, opts)) -> let tname = genTexname fn (!encoding) opts in (match (!encodingFile) with | Some(file) -> let mapline = system "otftotfm" (("-e"::file::fn::opts)@[tname]) in accum ^ mapline | None -> error "should be impossible!") ) "" rngs ) ^ accum ) wdthTable accum ) wghtTable accum ) shpTable "\n" )::files ) families [] (******************************************************************************) (* Print the usage information for the program *) let usage () : 'a = print_string ("Usage: " ^ (!program_name) ^ "\n" ^ " [--help]\n" ^ " [--verbose]\n" ^ " [--swash]\n" ^ " [--ornaments]\n" ^ " [--enc=ENCODING]\n" ^ " [--encFile=FILE]\n" ^ " files ...\n\n" ^ "Construct NFSS font descriptor files and PostScript map files\n" ^ "for the specified OpenType fonts.\n\n" ^ " -h, --help print this message\n" ^ " --verbose print more information about what is happening\n" ^ " --swash generate a swashy version (experimental)\n" ^ " --ornaments generate ornaments (experimental)\n" ^ " --enc=ENCODING set the encoding type (default T1) \n" ^ " --encFile=FILE set the encoding definition (default cork)\n\n" ^ "Version $Id: otftofd 7 2005-09-10 21:25:47Z geoffw $\n" ^ "Report bugs to <washburn@acm.org>.\n") let rec parseArgs (args : string list) : string list = (match args with | [] -> [] | "--h"::t -> (showUsage := true); parseArgs t | "--verbose"::t -> (verbose := true); parseArgs t | "--help"::t -> (showUsage := true); parseArgs t | "--swash"::t -> (swashVersion := true); parseArgs t | "--ornaments"::t -> (ornamentVersion := true); parseArgs t | (h::t) when (string_match (regexp "--enc=\\(.*\\)") h 0) -> (encoding := parseEncoding (matched_group 1 h)); parseArgs t | (h::t) when (string_match (regexp "--encfile=\\(.*\\)") h 0) -> (encodingFile := Some (matched_group 1 h)); parseArgs t | h::t -> h :: (parseArgs t)) (******************************************************************************) (* Should convert to basename *) let _ = (program_name := basename (hd (command_line ()))) let options = (tl (command_line ())) let _ = map (fun prog -> if not (prog_exists_path prog) then error ("Could not find the program " ^ prog ^ " in your path!")) ["otfinfo"; "otftotfm"] (******************************************************************************) (* Do the work *) let filtered_args = (parseArgs options) in let _ = (match (!encodingFile) with | None -> (encodingFile := Some (encodingToFile (!encoding))) | _ -> ()) in if ((length filtered_args) > 0) && not (!showUsage) then begin ignore (map (build_table (!swashVersion) (!ornamentVersion)) filtered_args); ignore (map (fun (fn, contents) -> let _ = if (!verbose) then print_string ((!program_name) ^ ": creating " ^ fn ^ "\n") in let channel = open_out fn in let _ = output_string channel contents in close_out channel) (genFdFile (!encoding))); ignore (map (fun (fn, contents) -> let _ = if (!verbose) then print_string ((!program_name) ^ ": creating " ^ fn ^ "\n") in let channel = open_out fn in let _ = output_string channel contents in close_out channel) (genMapFile ())) end else usage ()