(*
 *  Solution to problem 2a at the BCS Programming Contest 2004.
 *
 *  Afternoon <noon at aftnn.org>, 2004.
 *)

open Genlex

(* like List.map, except for lines from a channel *)
let map_chan_lines f ch =
    let rec map_chan_lines_acc f ch result =
        try
            let line = input_line ch in
            map_chan_lines_acc f ch (result ^ (f line) ^ "\n")
        with
            End_of_file -> result
    in
    map_chan_lines_acc f ch "";;

(* Like ::, but appends the item rather than prepends it - just scratching an
 * itch *)
let tapp a l = l @ (a :: []);;

(* create a dep spec lexer and store it for later *)
let lex_dep_spec = make_lexer ["("; ")"; ","; ":"; ";"];;

(* a type for representing packages *)
type package = { name: string; installed: bool; deps: string list };;

(* who'd have thought that such short strings could be so grammatically complex
 * most of this is because the list parts need parsing recursively *)
let rec parse_line = parser
      [< 'Kwd "("; installed = parse_installed; 'Kwd ")"; 'Kwd "(";
        packs = parse_new installed; 'Kwd ")" >] -> packs
and parse_installed = parser
      [< 'Ident i; instlist = parse_installed_rest ({ name=i; installed=true;
        deps=[] } :: []) >] -> instlist
    | [< >] -> []
and parse_installed_rest acc = parser
      [< 'Kwd ","; 'Ident i; rest = parse_installed_rest (tapp { name=i;
        installed=true; deps=[] } acc) >] -> rest
    | [< >] -> acc
and parse_new instlist = parser
      [< 'Ident i; deplist = parse_deps; newlist = parse_new_rest
        (tapp { name=i; installed=false; deps=deplist } instlist) >] -> newlist
and parse_new_rest acc = parser
      [< 'Kwd ","; 'Ident i; deplist = parse_deps;
        rest = parse_new_rest (tapp { name=i; installed=false; deps=deplist }
        acc) >] -> rest
    | [< >] -> acc
and parse_deps = parser
      [< 'Kwd ":"; 'Ident i; ds = parse_deps_rest (i :: []) >] -> ds
    | [< >] -> []
and parse_deps_rest acc = parser
      [< 'Kwd ";"; 'Ident i; ds = parse_deps_rest (tapp i acc) >] -> ds
    | [< >] -> acc;;
 
(* invoke the above parser system on an input line, the result of this function
 * is of type package list *)
let parse_dep_spec input =
    parse_line(lex_dep_spec(Stream.of_string (String.uppercase input)));;
 
(* true if p is either installed or about to be installed *)
let is_known_pack spec p = 
    List.mem p (List.map (fun pa -> pa.name) spec);;

(* true if all packages named in all dependencies are known *)
let deps_ok spec =
    let depended = List.flatten (List.map (fun p -> p.deps) spec) in
    List.for_all (is_known_pack spec) depended;;

(* return a named package, for matching dep names to package records *)
let pack_with_name name spec =
    List.find (fun p -> p.name = name) spec;;
    
let has_broken_deps p spec =
    not (List.for_all (fun p -> is_known_pack spec p) p.deps);;
    
let broken_deps p spec =
    List.filter (fun d -> not (is_known_pack spec d) ||
        has_broken_deps (pack_with_name d spec) spec) p.deps;;

(* resolve package dependency problems to a string *)
let dep_failure_message spec =
    let newpacks = List.filter (fun pos -> not pos.installed) spec in
    let brokenpacks = List.filter (fun p -> has_broken_deps p spec) newpacks in
    let brokenpack_to_string p =
        p.name ^ ":" ^ (String.concat ";" (broken_deps p spec)) in
    "Dependency check failed: " ^
        String.concat ", " (List.map brokenpack_to_string (List.sort (fun a b ->
            compare a.name b.name) brokenpacks));;

let rec is_dep_of a b spec =
    List.mem a.name b.deps ||
    List.exists (fun x -> is_dep_of a (pack_with_name x spec) spec) b.deps;;
    
(* print the required installation order that will satisfy all known
 * dependencies *)
let install_order spec =
    let depcmp a b =
        if a = b then 0 else
        if is_dep_of a b spec then -1 else
        if is_dep_of b a spec then 1 else
        compare a.name b.name
    in
    let newpacks = List.filter (fun pos -> not pos.installed) spec in
    let newpacks_sorted = List.sort depcmp newpacks in
    let newnames = List.map (fun p -> p.name) newpacks_sorted in
	"Install order: " ^ (String.concat "," newnames);;

(* action! *)
let resolve_deps specstr =
    let spec = parse_dep_spec specstr in
    if deps_ok spec then install_order spec else dep_failure_message spec;;

(* invoke map_chan_lines on the data file, passing resolve_deps *)
let process datafile =
    map_chan_lines resolve_deps datafile;;

(* main driver *)
let main _ = 
    let infile = open_in "Prog2a.dat" in
    let outfile = open_out "Prog2a.out" in
    output_string outfile (process infile);;

main ();;
exit 0;;