open Architecture

module Make(Card : CARD) = struct
  module Card = Card

  module LevelMap = Map.Make(struct type t = int let compare = compare end)

  type t = {
    levels : Card.t list LevelMap.t;
    given  : IntSet.t;
    hidden : IntSet.t;
  }

  let empty = {
    levels = LevelMap.empty;
    front = 0
  }

  let get_level level deck =
    try  LevelMap.find level deck
    with Not_found -> []

  let add ?(level = 0) card deck =
    let level_list = get_level level deck in
    LevelMap.add level
      (level_list @ [card])
      deck

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

type card_attributes = {
    level : int;
    order : int;
}

    

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

(* This function exists in newer O'Caml, and probably isn't O(n) *)
let size deck = CardMap.fold (fun _ _ size -> size + 1) deck 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
    CardMap.add 
        newcard 
        {level = level; order = max_card_order + 1}
        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 attr newmap
             else
                 newmap)
        deck
        CardMap.empty
        
let merge (deck1:t) (deck2:t) =
    let cards_to_add =
        filter 
            (fun card attr -> not (mem card deck1))
            deck2
    in

    let max = max_ordinal deck1 in
    fst (
        CardMap.fold
             (fun card attr (newmap, i) -> 
                  let newattr = {attr with order = i} in
                  CardMap.add card newattr newmap, i+1)
            
            cards_to_add
            (deck1, max+1)
    )
        
let merge_scores (card_deck:t) (score_deck:t) =

    let take_score card attr scores =
        try {attr with level = (CardMap.find card scores).level}
        with Not_found -> attr
    in
        
    CardMap.fold
        (fun card attr newmap -> 
             CardMap.add card (take_score card attr score_deck) newmap)
        card_deck
        empty

        
let flip (deck:t) = 
    CardMap.fold
        (fun card attr newdeck ->
             CardMap.add {front = card.back; back = card.front} attr newdeck)
        deck
        empty


(*
  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 = 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 newattr newmap, i+1)
             deck
             (CardMap.empty, 0)
    )
        

(******************************************************************)


type filetype = Granule | Cardflasher

let of_list li =
    List.fold_right 
        (fun card map -> add card map) 
        li
        empty
        
let of_list_with_levels 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
    (* TODO: fix this parser, it flips out
       when a section is empty - really, just use
       ocamlyacc or something, this is retarded *)
            
    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
        (* TODO: it barfs on that message for line 249, claiming it is
           line 2, so fix that message, plus it barfs just cuz the back
           of the line was empty, which it should allow *)
        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
                          Debug.debug (sprintf "Line %i: %s\n%!" !line nextline);
                          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
  
let sanity_check deck =
  CardMap.iter (fun card attribs -> 
                  if card.front = "" || card.back = "" then
                    failwith 
                      (sprintf "PANIC: Sanity check failed for card with front='%s' back='%s'"
                         card.front card.back))
    deck
        
(* 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%!";*)
  
  let deck =
    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
  in
  sanity_check deck;
  deck



(*
  ~filetype:(if Filename.check_suffix filename ".dkf"
  then Granule else Cardflasher)
*)
    
let output_simple outchan deck =
  sanity_check deck; (* TODO: make this uneccessary - why am I outputting corrupted files?? *)
  List.iter
    (fun (card, _) -> ();
       fprintf outchan "%s\n%s\n\n" card.front card.back)
    (to_list deck)

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

