open Printf

(* To the outside world, this should pretty much look like a List,
   and the map is just for speed of combining them. *)

(* This type is mushed together so that the interface can be simple *)
type card = {
    front : string;
    back : string;
    level : int;
    order : int;
}

module CardMap = Map.Make(struct 
                              type t = card
                              let compare card1 card2 = 
                                  Pervasives.compare 
                                      (card1.front, card1.back)
                                      (card2.front, card2.back)
                          end)
    
type t = card CardMap.t

type filetype = Granule | Cardflasher

let empty = CardMap.empty
                
let get_cards (deck:t) =
    let unsorted_cards =
        CardMap.fold (fun _ (card, attr) li -> (card, attr) :: li)
            deck
            []
    in
    List.sort 
        (fun (_, attr1) (_, attr2) -> compare attr1.order attr2.order)
        unsorted_cards

(* This function exists in newer O'Caml, and probably isn't O(n) *)
let map_size map = CardMap.fold (fun _ _ size -> size + 1) map 0
let max_ordinal map = CardMap.fold (fun _ (_,attr) max ->
                                        if attr.order > max then attr.order
                                        else max)
                          map 
                          0
                          
let add ?(level = 0) newcard deck = 
    let max_card_order = max_ordinal deck in
    let attr = {level = level; order = max_card_order + 1} in
    CardMap.add 
        newcard 
        (newcard, attr) 
        deck
        
let mem card deck = CardMap.mem card deck

let filter f deck = 
    CardMap.fold
        (fun _ (card,attr) newmap ->
             if f (card, attr) then
                 CardMap.add card (card, attr) newmap
             else
                 newmap)
        deck
        CardMap.empty
        
let merge (deck1:t) (deck2:t) =
    let max = max_ordinal deck1 in
    fst (
        CardMap.fold
             (fun _ (card,attr) (newmap, i) -> 
                  let newattr = {attr with order = i} in
                  CardMap.add card (card,newattr) newmap, i+1)
             deck2
             (deck1, max+1)
    )
        
let merge_scores (card_deck:t) (score_deck:t) =
    CardMap.fold
        (fun _ (card,attr) newmap -> 
             try 
                 let _,score_attr = CardMap.find card score_deck in
                 let new_attr = {attr with level = score_attr.level} in
                 CardMap.add card (card, new_attr) newmap
             with
                 | Not_found -> CardMap.add card (card,attr) newmap)
        card_deck
        CardMap.empty
        
let flip (deck:t) = 
    CardMap.map
        (fun (card, attr) ->
             {front = card.back; back = card.front}, attr)
        deck


(*
  Googled up this, which is linear and truly
  equal prob for each possibility:
  for(i = 0; i < 52; i++) {
    j = i + (random() % (52 - i));
    tmp = card[i];
	card[i] = card[j];
	card[j] = tmp;
  }

*)
let shuffle deck = 
    let size = map_size deck in
    let index_array = Array.init size (fun i -> i) in

    (* Shuffle the array of indices *)
    for i = 0 to size - 1 do
        let j = i + (Random.int (size - i)) in
        let tmp = index_array.(i) in
        index_array.(i) <- index_array.(j);
        index_array.(j) <- tmp
    done;

    (* Make a new map, assigning the cards the shuffled indices *)
    fst (
        CardMap.fold
             (fun _ (card, attr) (newmap, i) ->
                  let newattr ={attr with order = index_array.(i)} in
                  CardMap.add card (card, newattr) newmap, i+1)
             deck
             (CardMap.empty, 0)
    )
        
        
let of_list li =
    List.fold_right 
        (fun (card,level) map -> add ~level card map) 
        li
        empty

type token = BlankLine | TextLine of string | SectionEnd | CardEnd
type token_info = {
    line : int (* just a line number for now *)    
}


module SimpleFormatParser = struct
    let rec deck = parser
        | [< _ = blanks; rest = deck_body >] -> rest

    and deck_body = parser
        | [< first = card; rest = deck_tail >] -> add first rest
        | [< >] -> empty

    and deck_tail = parser
        | [< 'BlankLine, _; _ = blanks; rest = deck >] -> rest
        | [< >] -> empty

    and blanks = parser
        | [< 'BlankLine, _; _ = blanks >] -> ()
        | [< >] -> ()

    and card = parser
        | [< 'TextLine s, _; backlines = lines >] -> 
              (* Sanity check - if there are a million lines, then it is
                 probably some other format being parsed as a simple format
                 because of a syntax error *)
              if List.length backlines > 20 then (
                  eprintf "Quitting because the back of a card has \
                           greater than 20 lines - this almost certainly means it is \
                           a granule or record file with a syntax error.\n";
                  exit 1 )
              else
                  {front = s;
                   back = String.concat "\n" 
                              backlines}
                      
    and lines = parser
        | [< 'TextLine s, _; rest = lines >] -> s :: rest
        | [< >] -> []
end

module RecordFormatParser = struct
            
    module StringMap = Map.Make(String)
        
    let concat = String.concat "\n"

    let process_attrib_line map line info =
        match Str.split (Str.regexp "[ \t]*:[ \t]*") line with
            | [name; value] -> StringMap.add name value map
            | _ -> 
                  eprintf "WARNING: Ignoring malformed line %i\n%!" 
                        info.line; 
                  map
                      
    let grab_line_num stream =
        match Stream.peek stream with
            | Some x -> (snd x).line
            | None -> -1

    let rec deck = parser
        | [< _ = blanks; rest = deckbody >] -> rest

    and deckbody = parser
        | [< 
              (first,level) = card; 
              'CardEnd, _ ?? "No card terminator after card.";
              rest = deck 
          >] 
            -> add ~level first rest
              
        | [< >] -> empty

    and blanks = parser
        | [< 'BlankLine, _; _ = blanks >] -> ()
        | [< >] -> ()
              
    and card stream = 
        let linenum = grab_line_num stream in
        match stream with parser 
            | [< front = section;
                 'SectionEnd, _ 
                     ?? (sprintf "Card is missing a section end marker \
                                  (%s) after front section near line %i."
                             "%%" linenum);
                 back = section; 
                 map = optional_attributes >] -> 
                  ( let level = 
                        try int_of_string (StringMap.find "level" map) 
                        with
                            | Not_found -> 0
                            | _ -> 0 (* TODO: eprint err msg *)
                    in
                    {front = concat front;
                     back= concat back},
                    level 
                  )
                        
    and section = parser
        | [< 'TextLine s, _; rest = section_tail >] -> s :: rest

    and section_tail = parser
        | [< 'TextLine s, _; rest = section_tail >] -> s :: rest
        | [< 'BlankLine, _; rest = section_tail >] -> "" :: rest
        | [< >] -> []
              
    and optional_attributes = parser
        | [< 'SectionEnd, _; map = attributes >] -> map
        | [< >] -> StringMap.empty
              
    (* TODO: use utf-aware stuff in assoc section rather than Str, but
       since for now only the program edits it... *)
    and attributes = parser
        | [< 'BlankLine, _; map = attributes >] -> map
        | [< 'TextLine s, info; map = attributes >] -> process_attrib_line map s info
        | [< >] -> StringMap.empty
end      
        

module GranuleFormatParser = struct

    open Pxp_yacc
    open Pxp_document
    class warner =
    object 
        method warn w =
            print_endline ("WARNING: " ^ w)
    end
    ;;
    
    let card_of_xmlnode xmlnode =
        let frontr, backr = ref "", ref "" in
        List.iter 
            (fun child ->
                 match child # node_type with
                     | T_element "front" -> frontr := child # data
                     | T_element "back" -> backr := child # data
                     | _ -> ())
            
            (xmlnode # sub_nodes);
        
        {front = !frontr; back = !backr}, 0
end

let line_tokenize_channel ?(records = false) inchan =
    let line = ref 0 in
    (Stream.from (fun _ ->
                      try Some (
                          line := !line + 1;
                          let info = {line = !line} in
                          let nextline = input_line inchan in
                          match nextline with
                              | "" -> BlankLine, info
                              | "%%" when records -> SectionEnd, info
                              | "%%%%" when records -> CardEnd, info
                              | s -> TextLine s, info
                      )
                      with
                          | End_of_file -> None))

let dump_tokenized filename =
    let inchannel = open_in filename in
    let tokenstream = line_tokenize_channel ~records:true inchannel in
    Stream.iter (fun token -> 
                     match fst token with
                         | TextLine s -> printf "TextLine: %s\n" s
                         | BlankLine -> printf "BlankLine: \n"
                         | SectionEnd -> printf "SectionEnd: \n"
                         | CardEnd -> printf "CardEnd: \n"
                )
        tokenstream

        
        
let of_simple_channel inchan =
    SimpleFormatParser.deck (line_tokenize_channel inchan)

let of_record_channel inchan =
    RecordFormatParser.deck (line_tokenize_channel ~records:true inchan)
    
open Pxp_yacc    
open Pxp_document
let of_granule_file filename =
    let xmldoc = parse_document_entity 
                     {default_config with 
                          warner = new GranuleFormatParser.warner;
                          encoding = `Enc_utf8;
                          disable_content_validation = true}
                     (from_file filename)
                     default_spec
    in
    let children = xmldoc # root # sub_nodes in
              
              List.fold_right
                  (fun nextchild decktail ->
                       match nextchild # node_type with
                           | T_element "card" -> 
                                 let card,level = (GranuleFormatParser.card_of_xmlnode 
                                                       nextchild) in
                                 add ~level card decktail
                           | _ -> decktail)
                  children
                  empty
        
(* Trial and error / magic detection requires filename, can't work
   on arbitrary channels *)

let of_filename filename =
    (*eprintf "Trying to open %s\n" filename;*)
    
    (*eprintf "Trying as granule file.\n%!";*)
    try of_granule_file filename
    with granule_exception -> ();
        Debug.verbose (sprintf "Could not load as granule file:\n%s\n"
                           (Pxp_types.string_of_exn granule_exception));
        
        (*eprintf "Trying as record file.\n%!";*)
        let in_channel = open_in filename in
        try of_record_channel in_channel
        with record_exception -> ();
            Debug.verbose (sprintf "Could not load a record file:\n%s\n"
                               (Printexc.to_string record_exception));
            
            close_in in_channel;
            
            (*eprintf "Trying as simple file.\n%!";*)
            let in_channel = open_in filename in
            try of_simple_channel in_channel
            with simple_exception -> ();
                Debug.verbose (sprintf "Could not load as simple file:\n%s\n"
                                   (Printexc.to_string simple_exception));
                
                eprintf "Failed to open %s via any file type, Giving up!\n%!" filename;
                exit 1



(*
  ~filetype:(if Filename.check_suffix filename ".dkf"
  then Granule else Cardflasher)
*)

let output_simple outchan deck =
    List.iter
        (fun (card, _) -> ();
             fprintf outchan "%s\n%s\n\n" card.front card.back)
        (get_cards deck)

let output_records outchan deck =
    List.iter 
        (fun (card, attr) -> ();
             fprintf outchan "%s\n\
                              %%%%\n\
                              %s\n\
                              %%%%\n\
                              level: %i\n\
                              %%%%%%%%\n"
                 card.front card.back attr.level)
        (get_cards deck)

(*
open Pxp_document
let output_granule outchan deck =
    let decknode = new Pxp_document.

    fprintf outchan "<deck>\n"
*)

