(* CS 421 Fall 2009 MP4 *)

open Mp4common.Mp4common;;

(* Problem 1 *)
let tag_make_pair {tagname = tagname ; assignments = assignments} =
    (tagname, assignments)

(* Problem 2 *)
let tag_get_attributes {tagname = _ ; assignments = assignments} =
    List.map (fun x -> x.attribute) assignments

(* Problem 3 *)

let tag_assignments_to_set {tagname = tagname; assignments = assignments} =
    {tagname = tagname; assignments = to_set assignments}

(* Problem 4 *)

let rec check_adjacent at1 list =
    match list with [] -> None
    | {attribute = at2; value = _} :: rest ->
      if at1 = at2 then Some at1 else check_adjacent at2 rest

let tag_find_duplicate tag  = 
    match (tag_assignments_to_set tag).assignments  with [] -> None
    | {attribute = at1; value = _ } :: list -> check_adjacent at1 list

(*** XML Items ***)

(* Problem 6 *)
let rec xml_fold f_element f_chardata x =
    match x with CharData s -> f_chardata s
    | Element (tag, xs) ->
      f_element tag (List.map (xml_fold f_element f_chardata) xs)

(* Problem 5 *)
let xml_map f_tag f_chardata x =
    xml_fold (fun tag -> (fun rxs -> Element (f_tag tag, rxs)))
             (fun s -> CharData (f_chardata s))
    x

(* Problem 7 *)
let xml_uppercase_text = xml_map (fun tag -> tag) String.uppercase

(* Problem 8 *)
let xml_assignments_to_set = xml_map tag_assignments_to_set (fun s -> s)

(* Problem 9 *)
let xml_frequency tagname =
    xml_fold (fun {tagname = tn; assignments = _ } -> fun rcl ->
              let rc = List.fold_left (+) 0 rcl in
	      if tagname = tn then rc + 1 else rc)
             (fun _ -> 0)

(* Problem 10 *)
let rec xml_filter_tags tn_lst = 
    xml_fold
    (fun tag -> fun rx ->
     let tn = tag.tagname in
     if List.mem tn tn_lst
     then Some (Element(tag,
			List.fold_right
			(fun x -> fun rxs ->
			     match x with None -> rxs
			     | Some assign -> assign::rxs)
                        rx
                        []))
      else None)
    (fun s -> Some (CharData s))


(*** Supplying Default Values ***)

(* Problem 11 *)
let xml_get_tags x =
    to_set
    (xml_fold
     (fun tag -> fun rts -> tag::(List.fold_right (@) rts []))
     (fun s -> [])
     x)

(* Problem 12 *)
let xml_get_attributes tagname x =
    to_set(
    xml_fold
    (fun tag -> (fun ratll ->
      let ratl = List.fold_right (@) ratll [] in
      if tag.tagname = tagname
      then (tag_get_attributes tag) @ ratl
      else ratl))
    (fun s -> [])
    x)

(*** Extra Credit ***)

(* Problem 13 *)

let rec pad_assign assign labels =
    to_set
    (List.fold_left
     (fun asn -> fun lab ->
     (if List.exists (fun a -> a.attribute = lab) assign then asn
      else ({attribute = lab; value = "default"}::asn)))
     assign
     labels)

let xml_supply_defaults x =
    xml_map
    (fun tag -> {tagname = tag.tagname;
                 assignments = 
                 pad_assign
                  tag.assignments
                  (xml_get_attributes tag.tagname x)})
    (fun s -> s)
    x

(* Problem 14 *)
let cannonical x =
    xml_fold
    (fun tag -> fun newxs ->
     Element ({tagname = tag.tagname;
               assignments = 
               pad_assign
                (to_set tag.assignments)
                (xml_get_attributes tag.tagname x)},
              List.sort compare newxs))
    (fun s -> CharData s)
    x

let xml_reordering x1 x2 = (cannonical x1 = cannonical x2);;