(*** PERMUTATIONS ***)

(* An abstract signature for permutations. *)
module type PERM = sig
  (* A permutation of length n is a one-to-one correspondence
     from the integers 0 through n-1 to themselves. *)
  type perm

  (* >> is used as the permutation access operator.
     p>>i is the value to which permutation p maps i. *)
  val (>>) : perm -> int -> int

  (* << is the permutation find operator.
     p<<i is the value j such that p maps j to i. *)
  val (<<) : perm -> int -> int

  (* Identity permutation of size n: id>>i = i. *)
  val id : int -> perm

  (* Random permutation of size n. *)      
  val rand : int -> perm

  (* Inverse of a permutation: p>>i = j <=> p<<j = i *)
  val inverse : perm -> perm

  (* Swap two elements in a permutation.
     swap i j p is the permutation q such that
     q>>i = p>>j, q>>j = p>>i, and q>>k = p>>k for k not equal to j or i. *)
  val swap : int -> int -> perm -> perm 

  (* Composition of two permutations.
     compose p q is the permutation r such that r>>i = p>>(q>>i).
     The two arguments must have the same size. *)
  val compose : perm -> perm -> perm

  (* Convert a permutation into a string.  
     The result simply lists the values to which 0, 1 etc map, in order,
     between braces.
     (This is not to be confused with cycle notation used in group theory.) *)
  val show : perm -> string
end
       
(* A simple implementation of permutations as arrays. *)
module Perm : PERM = struct
  type perm = int array

  let (>>) p i = p.(i)

  let (<<) p i =
    let rec find j = if p.(j) = i then j else find (j+1) in
    find 0

  let id n = Array.init n (fun i -> i)

  (* Helper function yank takes a list xs and an index i, and returns a pair.
     The first element of the result is the ith element of xs.
     The second element is list consisting of the elements of xs other than
     the ith, possibly in a different order. *)
  let yank : 'a list -> int -> 'a * 'a list = fun xs i ->
    let rec yank' ys zs j = 
      match zs with
      |	w :: ws -> 
	  if j = 0 
	  then (w, ys @ ws) 
	  else yank' (w :: ys) ws (j-1)
      |	_ -> invalid_arg "yank: index out of range"
    in yank' [] xs i

  (* Helper function shuffle takes a list and returns a new list
     with the same elements in a uniformaly random order. *)
  let rec shuffle : 'a list -> 'a list = function
    | [] -> []
    | xs -> 
	let i = Random.int (List.length xs) in
	let (y,ys) = yank xs i in
	y :: (shuffle ys)

  let rand n =
    Array.of_list (shuffle (Array.to_list (id n)))

  let inverse p =
    let q = Array.create (Array.length p) (-1) in
    Array.iteri (fun i j -> Array.set q j i) p;
    q

  let swap i j p =
    let q = Array.copy p in
    q.(i) <- p.(j);
    q.(j) <- p.(i);
    q

  let compose p q =
    assert (Array.length p = Array.length q);
    Array.init (Array.length p) (fun i -> p.(q.(i)))

  let show p = 
    let rec show' i = 
      if i = Array.length p - 1
      then string_of_int (p>>i) ^ " }"
      else string_of_int (p>>i) ^ " " ^ show' (i+1)
    in "{ " ^ show' 0

end

(*** INFORMATION AND PLAYER TYPES ***)

(* Players may send messages to each other identifying a single player,
   or they have the option not to send a message 
   (which is itself a message!) *)
type message = int option

(*
 * An annal is a record of a single year, from the point of view of a 
 * particular player.  It consists of
 *   all players active at the beginning of the year;
 *   messages sent by the player to each of the other players;
 *   messages received by the player from each of the other players;
 *   the player eliminated at the end of the year.
 *)

type annal = 
    { active : int list;
      sent : message array;
      received : message array;
      votes : int array;
      eliminated : int }

(*
 * To implement a player, you need to supply two functions.  
 * The first decides what message to send to each of the other players,
 * given the list of players currently active and the history of previous years.
 * The second decides how to vote, given the list of players active, 
 * the history of previous years, the messages the player sent this year, 
 * and the messages it received this year.
 * The history is represented as a list of annals, most recent year first.
 * In the vote function, the first message array is the messages sent, the
 * second the messages received.
 *)

type player = 
    { send : int list * annal list -> message array;
      vote : int list * annal list * message array * message array -> int }

(*** PLAY A GAME ***)

open Perm
open Printf

(* 
 * Choose which player to eliminate, given the current list of active players,
 * and the voting history.  While the history contains votes of all players,
 * only votes by active players are valid.  
 * The elimination rule is as follows:
 * beginning with the current round, find the active player with the most votes
 * by active players.  If there is a tie, continue to the previous round, treating
 * only the tied players as active.  If there is no previous round, select a random
 * player. 
 *)
   
let rec eliminate active = function
  | [] -> List.nth active (Random.int (List.length active))
  | current_votes :: old_votes ->
      let score i =
	List.length (List.filter (fun j -> current_votes.(j) = i) active) in
      printf "Scores = ";
      List.iter (fun i -> printf "(%d,%d) " i (score i)) active;
      printf "\n";
      let rec maximizers old_max_score old_maximizers = function
	| [] -> old_maximizers
	| i :: is -> 
	    let s = score i in
	    if s > old_max_score
	    then maximizers s [i] is
	    else if s = old_max_score
	    then maximizers s (i :: old_maximizers) is
	    else maximizers old_max_score old_maximizers is
      in match maximizers min_int [] active with
      |	[i] -> i
      |	is -> eliminate is old_votes


(* Play a game with a given array of players. *)
let play players = 
  let n = Array.length players in

  (* 
   * Create the permutations for each player.
   * For each player i, begin with a random permutation, and make sure that
   * i sees itself as 0.  
   * This is a view of the world from i's point of view.
   * decodes.(i) describes the world from i's point of view: 
   * if decodes.(i)>>j = k, then i views actual agent k as "j".
   * encodes.(i) is the inverse of decodes.(i).
   * If i sends a message to "j" saying "k", then i is really sending a
   * message to decodes.(i)>>j saying decodes.(i)>>k.  Thus, for any h, the
   * message actually sent from i to h is decodes.(i)>>g, where g is the message
   * i thinks it is sending to encodes.(i)>>h.
   * Similarly, if actual agent j sends an actual message k to i, then
   * i thinks it is getting a message encodes.(i)>>k from encodes.(i)>>j.
   * Thus, for any h, i views the message received from h as encodes.(i)>>g,
   * where g is the message i actually receives from decodes.(i)>>h. 
   *)
  let decodes = Array.init n (fun i -> let p = rand n in swap 0 (p<<i) p) in
  let encodes = Array.map inverse decodes in
  (* translate an array of messages from i *)
  let decode i ms = 
    Array.init n 
      (fun h -> 
	match ms.(encodes.(i) >> h) with
	| None -> None
	| Some g -> Some (decodes.(i) >> g))
  (* translate an array of messages from i *)
  and encode i ms = 
    Array.init n
      (fun h -> 
	match ms.(decodes.(i) >> h) with
	| None -> None
	| Some g -> Some (encodes.(i) >> g))
  in

  (* Print the permutations, for debugging purposes *)
  Array.iteri (fun i p -> printf "Code for player %d : %s\n" i (show p)) encodes;
  Array.iteri (fun i p -> printf "Decode for player %d : %s\n" i (show p)) decodes;


  (* An array of views of the world from the point of view of each player. *)
  let histories = Array.create n [] in

  (* History of votes *)
  let voting_record = ref [] in

  (* play with the given list of survivors, returning a list of players 
     in reverse order of elimination (winner first) *)
  let rec play' = function
    | [winner] -> [winner]
    | active ->
	(* We need to encode the active lists for passing to each player;
	   also, we sort the encoded list so that an agent can't identify what
	   player a code refers to from its position in the list *)
	let coded_active = 
	  Array.init n
	    (fun i -> List.sort compare (List.map (fun j -> encodes.(i) >> j) active))
		
        (* begin the round by getting a message from each player *)
	in let coded_from = 
	  Array.init n 
	    (fun i -> players.(i).send (coded_active.(i), histories.(i))) in

        (* work out who the message is actually sent to *)
	let actual_from = Array.mapi decode coded_from in

        (* create an array of messages sent to i *)
	let transfer_to i = Array.init n (fun j -> actual_from.(j).(i)) in

        (* an array of all messages sent to all players *)
	let actual_to = Array.init n transfer_to in

        (* messages sent to players from their own viewpoint *)
	let coded_to = Array.mapi encode actual_to in

        (* get a vote from each player *)
	let get_vote i = 
	  players.(i).vote 
	    (coded_active.(i), histories.(i), coded_from.(i), coded_to.(i)) in

        (* array of all votes: each players vote needs to be translated into an
           actual vote.  *)
	let votes = Array.init n (fun i -> decodes.(i) >> get_vote i) in

        (* update the voting history *)
	voting_record := votes :: !voting_record;
    
        (* figure out who gets eliminated from the voting record *)
	let eliminated = eliminate active !voting_record in

        (* update each player's history *)
	let new_record i = 
	  { active = coded_active.(i);
	    sent = coded_from.(i);
	    received = coded_to.(i);
            (* to translate votes, we have to do a double encoding;
	       i thinks that j voted for k if decodes.(i) >> j voted
	       for decodes.(i) >> k.
   	       So in i's annal, votes.(j) is 
	       encodes.(i).(votes.(decodes.(i).(j))) *)
	    votes = Array.init n (fun j -> encodes.(i) >> votes.(decodes.(i) >> j));
	    eliminated = encodes.(i) >> eliminated }
	in Array.iteri (fun i h -> histories.(i) <- new_record i :: h) histories;

        (* write a report of the round *)
	printf "\nROUND %2d\n=========\n" (List.length active);
	printf "Active players are ";
	List.iter (fun i -> printf "%d " i) active;
	printf "\n\nMessages sent:\n   ";
	for i = 0 to n-1 do
	  printf " %2d" i
	done;
	printf "\n";
	for i = 0 to n-1 do
	  printf "%2d:" i;
	  for j = 0 to n-1 do
	    match actual_from.(i).(j) with
	    | None -> printf " --"
	    | Some k -> printf " %2d" k
	  done;
	  printf "\n";
	done;
	printf "Messages received:\n   ";
	for i = 0 to n-1 do
	  printf " %2d" i
	done;
	printf "\n";
	for i = 0 to n-1 do
	  printf "%2d:" i;
	  for j = 0 to n-1 do
	    match actual_to.(i).(j) with
	    | None -> printf " --"
	    | Some k -> printf " %2d" k
	  done;
	  printf "\n";
	done;
	printf "\nVotes:\n";
	for i = 0 to n-1 do
	  printf " %2d" i
	done;
	printf "\n";
	for i = 0 to n-1 do
	  printf " %2d" votes.(i)
	done;
	printf "\nPlayer %d was eliminated\n" eliminated;

        (* continue play without the eliminated player,
           returning a list of players in elimination order *)
	eliminated :: play' (List.filter (fun i -> i <> eliminated) active)

  in List.rev (play' (Array.to_list (Array.init n (fun i -> i))))

(*** SOME DUMMY PLAYERS ***)

(* Helper to figure out the size of the game from the current list of active
   players and the history.  If the history is empty, then all players are currently
   active, otherwise the size can be found out from history. *)
let num_players active = function
  | [] -> List.length active
  | last :: _ -> Array.length last.votes

(* A player that uses another player to actually play, but reports what it sees
   and what it decides.  Very useful for debugging.  *)

let count = ref 1

let reporter player = 
  let name = sprintf "00%d" !count in
  incr count;
  let send (active, history) = 
    let n = num_players active history in
    begin
      match history with
      | [] -> ()
      | last :: _ ->
	  printf "\n\nAnnal of Last Round from Point of View of %s\n" name;
	  printf "Active: ";
	  List.iter (fun x -> printf "%d " x) last.active;
	  printf "\nMessages sent:\n";
	  for i = 0 to n-1 do
	    printf " %2d" i
	  done;
	  printf "\n";
	  for i = 0 to n-1 do
	    match last.sent.(i) with
	    | None -> printf " --"
	    | Some j -> printf " %2d" j
	  done;
	  printf "\nMessages received:\n";
	  for i = 0 to n-1 do
	    printf " %2d" i
	  done;
	  printf "\n";
	  for i = 0 to n-1 do
	    match last.received.(i) with
	    | None -> printf " --"
	    | Some j -> printf " %2d" j
	  done;
	  printf "\nVotes:\n";
	  for i = 0 to n-1 do
	    printf " %2d" i
	  done;
	  printf "\n";
	  for i = 0 to n-1 do
	    printf " %2d" last.votes.(i)
	  done;
	  printf "\nEliminated: %d\n" last.eliminated;
    end;
    let sent = player.send (active, history) in
    printf "\n\nCurrently active: ";
    List.iter (fun x -> printf "%d " x) active;
    printf "\n%s sending:\n" name;
    for i = 0 to n-1 do
      printf " %2d" i
    done;
    printf "\n";
    for i = 0 to n-1 do
      match sent.(i) with
      | None -> printf " --"
      | Some j -> printf " %2d" j
    done;
    sent

  and vote (active, history, sent, received) = 
    let n = Array.length sent in 
    printf "\n\nPlayer %s About to Vote\n" name;
    printf "\nMessages sent\n";
    for i = 0 to n-1 do
      printf " %2d" i
    done;
    printf "\n";
    for i = 0 to n-1 do
      match sent.(i) with
      | None -> printf " --"
      | Some j -> printf " %2d" j
    done;
    printf "\n\nMessages received\n";
    for i = 0 to n-1 do
      printf " %2d" i
    done;
    printf "\n";
    for i = 0 to n-1 do
      match received.(i) with
      | None -> printf " --"
      | Some j -> printf " %2d" j
    done;
    let result = player.vote (active, history, sent, received) in
    printf "\n\n%s votes for %d\n" name result;
    result
    
  in { send = send; vote = vote }
      
(* Helper function to pick a random player other than oneself. *)
let rec pick active =
  let i = Random.int (List.length active) in
  let j = List.nth active i in
  if j = 0 then pick active else j

(* Helper function to find a player who voted against me, 
   and return a random player if there is none. *)
let revenge active votes =
  try List.find (fun i -> votes.(i) = 0) active 
  with Not_found -> pick active

(* Helper function to find a player who received a minimum number 
   of votes last round (excluding myself) *)
let low_votes active votes =
  let n = Array.length votes in
  let count i =
    let rec count' j accum = 
      if j = n 
      then accum 
      else if votes.(j) = i 
      then count' (j+1) (accum+1)
      else count' (j+1) accum
    in count' 0 0
  in let counts = List.map (fun i -> (i, count i)) active
  in let rec minimize best_i best_count = function
    | [] -> best_i
    | (j, count_j) :: rest ->
	if count_j < best_count && j <> 0
	then minimize j count_j rest
	else minimize best_i best_count rest
  in minimize 0 max_int counts

(* Helper function to send a message to all players according to a rule. 
   The rule should take the active list and history as argument, 
   and return a message. *)
let all_same rule = 
  function (active, history) ->
    Array.create (num_players active history) (rule active history)

(* Sending function for a player that doesn't send any messages. *)
let quiet = all_same (fun a h -> None)

(* A stubborn player is one that picks its vote at the beginning of the round
   and sticks to it, and also sends that message to all the players.
   It takes as argument the rule for deciding which player to vote for.
   In the vote function, the message to itself is used as a reminder of who
   it picked, in case the rule does not always return the same answer. *)
let stubborn rule =
  let send = all_same (fun a h -> Some (rule a h))
  and vote (active, history, sent, received) = 
    match received.(0) with
    | Some i -> i
    | _ -> assert false
  in { send = send; vote = vote }

(* Vote for an active player who appeared most often in messages to you 
   (excluding yourself) . *)
let obey (active, history, sent, received) =
  let n = Array.length sent in
  let count i =
    let rec count' j accum = 
      if j = n 
      then accum 
      else if received.(j) = Some i 
      then count' (j+1) (accum+1)
      else count' (j+1) accum
    in count' 0 0
  in let counts = List.map (fun i -> (i, count i)) active
  in let rec maximize best_i best_count = function
    | [] -> best_i
    | (j, count_j) :: rest ->
	if count_j > best_count && j <> 0
	then maximize j count_j rest
	else maximize best_i best_count rest
  in maximize 0 min_int counts

(* The PERSISTENT player is a stubborn player that randomly picks a player to
   vote for, and then keeps on voting for that player until it the player
   is eliminated. 
   The effect is achieved by picking the first player in the active list who
   isn't 0 - because of the random permutations, this will appear random to the
   other players. *)
let persistent =
  let rule active history =
    match active with
    | i :: j :: _ -> 
	printf "In persistent, i = %d, j = %d\n" i j;
	if i = 0 then j else i
    | _ -> assert false
  in stubborn rule

(* The FLIGHTFUL player is a stubborn player that randomly picks a different
   player each round. *)
let flightful = 
  let rule active history = pick active
  in stubborn rule

(* The VENGEFUL player votes for a player who voted against it last time. *)
let vengeful =
  let rule active history = 
    match history with 
    | [] -> pick active
    | last :: _ -> revenge active last.votes
  in stubborn rule

(* The FOLLOWER is one who doesn't send any messages, and obeys the messages
   sent to it. *)
let follower =
  { send = quiet; vote = obey }

(* The COMPLIANT player tries to get the others to vote for one who voted against
   it, but obeys their messages. *)
let compliant =
  let rule active history = 
    match history with 
    | [] -> Some (pick active)
    | last :: _ -> Some (revenge active last.votes)
  in { send = all_same rule; vote = obey }

(* The BALANCER subtly tries balance the power by asking everyone to vote for a
   player who received a minimum number of votes the previous round.  However, it
   obeys the messages sent to it so as not to stick out its neck too much. *)
let balancer =
  let rule active history =
    match history with 
    | [] -> Some (pick active)
    | last :: _ -> Some (low_votes active last.votes)
  in { send = all_same rule; vote = obey }