util  Check-in [384965fe63]

(* [ʞ] rosshil.ml - tasshila semes sirvos
 *  ~ lexi hale <lexi@hale.su>
 *  $ ocamlopt.opt rosshil.ml -o rosshil
 *  © AGPL






 *)

(* basic units *)
type timespan  = int (* earth seconds are current tick unit *)
type timepoint = int
type quantity = int
type proportion = float

type runopt = NoOpt | NoANSI | ASCII
let optstrs = [

	NoANSI, "noansi";


	ASCII, "ascii";






]
let is_opt str = List.exists (fun (_,s) -> ("-"^s) = str) optstrs
let opt_of_str str = let (opt,_) = List.find
	(fun (_,s) -> ("-"^s) = str) optstrs in opt;

type name             = { short: string; long: string; }
let nmpair short long = { short = short; long = long   };
................................................................................
		Empire.Span.(fmt(calc span)) ^" from Creation →\n\t";
		Empire.Cal.(fmt(calc time)) ^"\n";
		League.Span.(fmt(calc span)) ^" from Creation →\n\t";
		League.Cal.(fmt(calc time)) ^"\n";
	]
*)

let usage arrow ansi hl bin = 
	let heading = "usage: " in
	let syntax = [
		"<faction> [year <year>] [day <day>] to <faction>",
			"convert a calendar date";
		"<number> <faction> (days | years [<days> days]) to <faction>",
			"convert a span of time";
	] in
	let spacing = String.make (String.length heading) ' ' in
	let mkrow (s,d) = bin ^ " " ^ (ansi "96" s) ^"\n" ^
		spacing ^ ((ansi "3;95" ("  "^arrow^" " ^ d))^"\n") in
	let space s = spacing ^ (mkrow s) in
	let fst = (hl heading) ^ (mkrow (List.hd syntax)) in
	let rst = List.map space (List.tl syntax) in
		List.fold_left (^) fst rst;;

type funcset = {
	calc : int -> date;
	fmt : date -> string;
	equiv : date -> int;
}

type funcrow = {
................................................................................
	span : funcset;
	cal : funcset;
}


let funcs : funcrow list = [
	(* Society *) {
		names=["society"; "shil"; "ranshil"; "rs"];
		fmt="92";
		span = {
			calc=Society.Span.calc;
			fmt=Society.Span.fmt;
			equiv=Society.Span.equiv;
		};
		cal = {
			calc=Society.Cal.calc;
			fmt=Society.Cal.fmt;
			equiv=Society.Cal.equiv;
		};
	};
	(* Empire *) {
		names=["empire"; "ziapha"; "zp"; "imperial"];
		fmt="91";
		span = {
			calc =Empire.Span.calc;
			fmt  =Empire.Span.fmt;
			equiv=Empire.Span.equiv;
		};
		cal = {
			calc   =Empire.Cal.calc;
			fmt    =Empire.Cal.fmt;
			equiv  =Empire.Cal.equiv;
		};
	};
	(* League *) {
		names=["league"; "ly"];
		fmt="96";
		span = {
			calc =League.Span.calc;
			fmt  =League.Span.fmt;
			equiv=League.Span.equiv;
		};
		cal = {
			calc   =League.Cal.calc;
			fmt    =League.Cal.fmt;
			equiv  =League.Cal.equiv;
		};
	};
	(* Gregorian *) {
		names=["gregorian"; "terrestrial"; "earth"; "gy"];
		fmt="95";
		span = {
			calc  = Gregorian.Span.calc;
			fmt   = Gregorian.Span.fmt;
			equiv = Gregorian.Span.equiv;
		};
		cal = {
................................................................................
			 * needs to raise an exception *)
			calc  = bad_dim;
			fmt   = bad_dim;
			equiv = bad_dim;
		};
	};
]



























































let contains ar v : bool = List.exists (fun a -> a = v) ar

let getfuncs (tag: string) : funcrow = List.find
	(* pred *) (fun (a:funcrow) -> contains a.names tag)
	(* from array *) funcs

................................................................................
	let from_sys = choosefuncs from_funcs in
	let to_sys = choosefuncs to_funcs in
	let indate = {years = years; days = days} in
	let time = from_sys.equiv indate in
	let outdate = to_sys.calc time in
	let instr = from_sys.fmt indate in
	let outstr = to_sys.fmt outdate in
		(from_funcs.fmt, instr, to_funcs.fmt, outstr)


let rec parse (opts: runopt list) (args: string list) (bin: string) = let
	has_opt o = List.exists (fun a -> a = o) opts in
	let switch o a b = if has_opt o then a else b in

	let ansi (fmt: string) (str: string) = switch NoANSI str
		("\x1b["^fmt^"m"^str^"\x1b[m") in
	let hl txt = switch NoANSI txt
		("\x1b[1m" ^ txt ^ "\x1b[21m") in





	let res_fmt (inf,ind,outf,outd) =
		(ansi inf ind) ^ (switch ASCII " -> " " → ") ^ (ansi outf (hl outd)) in



	match args with
	| opt :: rst when is_opt opt -> let o = opt_of_str opt in
		(* (print_string ("running conv with flag "^opt^"!\n")); *)
		parse (o :: opts) rst bin
	| [fromcal; "to"; calendar] ->

		(res_fmt (conv Timespan fromcal calendar 1 0))^"\n" ^
		(res_fmt (conv Timespan fromcal calendar 0 1))^"\n"
	| [fromcal; "date"; date; "to"; calendar]
	| [fromcal; "year"; date; "to"; calendar] ->
		(res_fmt (conv Calendar fromcal calendar (int_of_string date) 0))^"\n"
	| [fromcal; "year"; years; "day"; days; "to"; calendar] ->
		(res_fmt (conv Calendar fromcal calendar
			(int_of_string years)
			(int_of_string days)))^"\n"





























	| [count; from; "years"; "to"; system] ->
		(res_fmt (conv Timespan from system (int_of_string count) 0))^"\n"
	| [count; from; "days"; "to"; system] ->
		(res_fmt (conv Timespan from system 0 (int_of_string count)))^"\n"
	| [years; from; "years"; days; "days"; "to"; system] ->
		(res_fmt (conv Timespan from system
			(int_of_string years)
			(int_of_string days)))^"\n"
	| _ -> (usage (switch ASCII "->" "→") ansi hl bin);;

let () = print_string (match (Array.to_list Sys.argv) with
	| bin :: rst -> parse [] rst bin
	| _ -> "buddy ya fucked up BAD");;

(* [ʞ] rosshil.ml - tasshila semes sirvos
 *  ~ lexi hale <lexi@hale.su>
 *  $ ocamlopt.opt rosshil.ml -o rosshil
 *  © GNU GPLv3
 *  ? rosshil is a tool for transforming various dates in the
 *    calendar systems of Spirals into other representations.
 *    feel free to copy it and use it for your own settings
 *    if you're as much of a perfectionist dweeb as me; just
 *    make sure you change the name of the utility so it's
 *    not in Ranuir
 *)

(* basic units *)
type timespan  = int (* earth seconds are current tick unit *)
type timepoint = int
type quantity = int
type proportion = float

type runopt = NoOpt | NoANSI | ASCII | Debug | OutOnly
let optstrs = [
	NoANSI, "-plain";
	NoANSI, "p";

	ASCII, "-ascii";
	ASCII, "a";

    Debug, "-verbose";
    Debug, "v";

    OutOnly, "-out";
    OutOnly, "o";
]
let is_opt str = List.exists (fun (_,s) -> ("-"^s) = str) optstrs
let opt_of_str str = let (opt,_) = List.find
	(fun (_,s) -> ("-"^s) = str) optstrs in opt;

type name             = { short: string; long: string; }
let nmpair short long = { short = short; long = long   };
................................................................................
		Empire.Span.(fmt(calc span)) ^" from Creation →\n\t";
		Empire.Cal.(fmt(calc time)) ^"\n";
		League.Span.(fmt(calc span)) ^" from Creation →\n\t";
		League.Cal.(fmt(calc time)) ^"\n";
	]
*)

















type funcset = {
	calc : int -> date;
	fmt : date -> string;
	equiv : date -> int;
}

type funcrow = {
................................................................................
	span : funcset;
	cal : funcset;
}


let funcs : funcrow list = [
	(* Society *) {
        names=["Society of Worlds"; "society"; "shil"; "ranshil"; "rs"];
		fmt="92";
		span = {
			calc=Society.Span.calc;
			fmt=Society.Span.fmt;
			equiv=Society.Span.equiv;
		};
		cal = {
			calc=Society.Cal.calc;
			fmt=Society.Cal.fmt;
			equiv=Society.Cal.equiv;
		};
	};
	(* Empire *) {
        names=["Heavenly Empire of a Thousand Suns"; "empire"; "imperial";"ziapha"; "zp"];
		fmt="91";
		span = {
			calc =Empire.Span.calc;
			fmt  =Empire.Span.fmt;
			equiv=Empire.Span.equiv;
		};
		cal = {
			calc   =Empire.Cal.calc;
			fmt    =Empire.Cal.fmt;
			equiv  =Empire.Cal.equiv;
		};
	};
	(* League *) {
        names=["Socialist League"; "league"; "ly"];
		fmt="96";
		span = {
			calc =League.Span.calc;
			fmt  =League.Span.fmt;
			equiv=League.Span.equiv;
		};
		cal = {
			calc   =League.Cal.calc;
			fmt    =League.Cal.fmt;
			equiv  =League.Cal.equiv;
		};
	};
	(* Gregorian *) {
        names=["Gregorian calendar"; "gregorian"; "terrestrial"; "earth"; "gy"; "ce";];
		fmt="95";
		span = {
			calc  = Gregorian.Span.calc;
			fmt   = Gregorian.Span.fmt;
			equiv = Gregorian.Span.equiv;
		};
		cal = {
................................................................................
			 * needs to raise an exception *)
			calc  = bad_dim;
			fmt   = bad_dim;
			equiv = bad_dim;
		};
	};
]


let usage arrow ansi hl bin = 
    let caltext = (
        let heading = "calendars: " in
        let desc (cal: funcrow) : string =(
            let name = List.hd cal.names in
            let aliases = List.tl cal.names in
            let append a b = if a = "" then b else (a^", "^b) in
            let fmt = cal.fmt in
                (ansi fmt (hl name)) ^
                (ansi fmt (" [" ^ (List.fold_left append "" aliases) ^"]") ^"\n"))
        in let spacing = String.make (String.length heading) ' ' in
        let space s = spacing ^ (desc s) in
        let fst = (hl heading) ^ (desc (List.hd funcs)) in
        let rst = List.map space (List.tl funcs) in
            (List.fold_left (^) fst rst)
    ) in

	let heading = "usage: " in
    let opts = " [options] " in
	let syntax = [
		"<faction> [year <year>] [day <day>] to <faction>",
			"convert a calendar date";
		"<number> <faction> (days | years [<days> days]) to <faction>",
			"convert a span of time";
        "<faction> ticks <years> years <days> days",
            "count temporal ticks corresponding to a timespan";
        "<faction> epoch <year> day <day>",
            "get the Spirals epoch for a particular date";
        "epoch <epoch> to <system>",
            "convert a Spirals epoch to a calendar date";
        "<number> ticks to <system>",
            "convert a tick count to a span of time in a given calendar";
	] in
	let spacing = String.make (String.length heading) ' ' in
	let mkrow (s,d) = bin ^ opts ^ (ansi "94" s) ^"\n" ^
		spacing ^ ((ansi "3;95" ("  "^arrow^" " ^ d))^"\n") in
	let space s = spacing ^ (mkrow s) in
    let opt_heading = "options: " in
    let optdesc = [
        "o","out", "only print what the date is converted into";
        "p","plain", "do not format output with ansi escape codes";
        "v","verbose", "output extra debugging information";
        "a","ascii", "use only ASCII in output (instead of UTF-8)";
    ] in
	let opt_spacing = String.make (String.length opt_heading) ' ' in
	let mkopt (s,l,d) = "-"^s^" "^(ansi "94" ("(--"^l^")"))^": "^(ansi "95" d)^"\n" in
	let spaceopt s = opt_spacing ^ (mkopt s) in

	let fst_opt = (hl opt_heading) ^ (mkopt (List.hd optdesc)) in
	let rst_opt = List.map spaceopt (List.tl optdesc) in
	let opt_body = List.fold_left (^) fst_opt rst_opt in

	let fst = (hl heading) ^ (mkrow (List.hd syntax)) in
	let rst = List.map space (List.tl syntax) in
        (List.fold_left (^) fst rst) ^"\n"^ opt_body ^"\n" ^ caltext;;


let contains ar v : bool = List.exists (fun a -> a = v) ar

let getfuncs (tag: string) : funcrow = List.find
	(* pred *) (fun (a:funcrow) -> contains a.names tag)
	(* from array *) funcs

................................................................................
	let from_sys = choosefuncs from_funcs in
	let to_sys = choosefuncs to_funcs in
	let indate = {years = years; days = days} in
	let time = from_sys.equiv indate in
	let outdate = to_sys.calc time in
	let instr = from_sys.fmt indate in
	let outstr = to_sys.fmt outdate in
		(from_funcs.fmt, instr, to_funcs.fmt, outstr, time)


let rec parse (opts: runopt list) (args: string list) (bin: string) = let
	has_opt o = List.exists (fun a -> a = o) opts in
	let switch o a b = if has_opt o then a else b in

	let ansi (fmt: string) (str: string) = switch NoANSI str
		("\x1b["^fmt^"m"^str^"\x1b[m") in
	let hl txt = switch NoANSI txt
		("\x1b[1m" ^ txt ^ "\x1b[21m") in
    let arrow = (switch ASCII "->" "→") in
    let dbg msg : unit = (if has_opt Debug then print_string
        (ansi "35;3" ((hl " -- ") ^ msg ^ "\n")) else ()) in
    let op msg o = dbg msg; o in

	let res_fmt (inf,ind,outf,outd,_) =

		(switch OutOnly "" ((ansi inf ind) ^" "^ arrow ^" "))^ (ansi outf (hl outd)) in
    let epoch (_,_,_,_,time) = time in

	match args with
	| opt :: rst when is_opt opt -> let o = opt_of_str opt in
        (op ("saw flag " ^opt^ ", adding to option set and restarting parse")
            parse (o :: opts) rst bin)


    (* convert timepoints between different calendars *)

	| [fromcal; "date"; date; "to"; calendar]
	| [fromcal; "year"; date; "to"; calendar] ->
		(res_fmt (conv Calendar fromcal calendar (int_of_string date) 0))^"\n"
	| [fromcal; "year"; years; "day"; days; "to"; calendar] ->
		(res_fmt (conv Calendar fromcal calendar
			(int_of_string years)
			(int_of_string days)))^"\n"

    (* absolute values - maybe useful for scripting, e.g.
     * comparing or sorting lists of dates in different
     * systems. *)
    | [cal; "epoch"; years; "day"; days;] ->
        (string_of_int (epoch (conv Calendar cal cal
            (int_of_string years)
			(int_of_string days))))^"\n"
    | [cal; "ticks"; years; "years"; days; "days"] ->
        (string_of_int (epoch (conv Timespan cal cal
            (int_of_string years)
			(int_of_string days))))^"\n"

    (* absolute values - convert timepoints/spans to dates *)
    | ["epoch"; epoch; "to"; system;] ->
        let fns = getfuncs system in
        (res_fmt ("3", "EPOCH "^epoch, fns.fmt,
            (fns.cal.fmt (fns.cal.calc (int_of_string epoch))), 0))^"\n"
    | [ticks; "ticks"; "to"; system;] ->
        let fns = getfuncs system in
        (res_fmt ("3", ticks^" TICKS", fns.fmt,
            (fns.span.fmt (fns.span.calc (int_of_string ticks))), 0))^"\n"

    (* get conversion factors between different days & years *)
	| [fromcal; "to"; calendar] ->
		(res_fmt (conv Timespan fromcal calendar 1 0))^"\n" ^
		(res_fmt (conv Timespan fromcal calendar 0 1))^"\n"

    (* convert timespans of one calendar system to another *) 
	| [count; from; "years"; "to"; system] ->
		(res_fmt (conv Timespan from system (int_of_string count) 0))^"\n"
	| [count; from; "days"; "to"; system] ->
		(res_fmt (conv Timespan from system 0 (int_of_string count)))^"\n"
	| [years; from; "years"; days; "days"; "to"; system] ->
		(res_fmt (conv Timespan from system
			(int_of_string years)
			(int_of_string days)))^"\n"
	| _ -> (usage arrow ansi hl bin);;

let () = print_string (match (Array.to_list Sys.argv) with
	| bin :: rst -> parse [] rst bin
	| _ -> "buddy ya fucked up BAD");;