open Printf
open Pxp_yacc
open Pxp_document

(* The mutable deck's implementation is made for speed, because 
   cardflasher was a little tooooo slow with just lists being
   merged about.  It is important for cards to have an order, but
   we will just store it in the card, and sort them before showing
   to the user. 

   So, we will store the cards in a (string*string) hashtable by their front/back
*)

type t = (card, card * card_attributes) Hashtbl.t

and card = {
    front : string;
    back : string;
}

and card_attributes = int (*(string, string) Hashtbl.t*)

let create = Hastbl.create 50


type filetype = Granule | Cardflasher

let empty = []
                
let get_cards deck = deck
                    
let add (newcard, newlevel) deck = 
    (List.remove_assoc newcard deck) @ [newcard, newlevel]
        
let mem card deck = List.mem_assoc card deck

let filter f deck = List.filter f deck

let merge (deck1:t) (deck2:t) =
    List.fold_right
        (fun (card,level) li -> 
             if mem card li then li 
             else add (card,level) li)
        deck2
        deck1

let merge_scores (card_deck:t) (score_deck:t) =
    List.fold_right
        (fun (card, level) li ->
             try (card, List.assoc card score_deck) :: li
             with Not_found -> (card, level) :: li )
        card_deck
        []
             

(* TODO *)
let flip deck = 
    List.map
        (fun (card, level) ->
             {front = card.back; back = card.front}, level)
        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 deck_array = Array.of_list deck in
    let len = Array.length deck_array in
    for i = 0 to len - 1 do
        let j = i + (Random.int (len - i)) in
        let tmp = deck_array.(i) in
        deck_array.(i) <- deck_array.(j);
        deck_array.(j) <- tmp
    done;
    Array.to_list deck_array
    
        

let of_list li =
    List.fold_right add 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}, 0
              
    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 = card; 
             'CardEnd, _ ?? "No card terminator after card.";
             rest = deck >] -> add 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
    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)
        
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" -> 
                                 (GranuleFormatParser.card_of_xmlnode nextchild) ::
                                       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)
        deck

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

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

    fprintf outchan "<deck>\n"
*)

