Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.priority rt.model.arrival.basic.task_arrival.
Require Import rt.model.schedule.global.jitter.job rt.model.schedule.global.jitter.schedule
               rt.model.schedule.global.jitter.interference rt.model.schedule.global.jitter.platform.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module ConstrainedDeadlines.

  Import Job SporadicTaskset ScheduleOfSporadicTaskWithJitter SporadicTaskset
         TaskArrival Interference Priority Platform.

  Section Lemmas.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.
    Variable job_jitter: Job -> time.

    (* Consider any job arrival sequence ... *)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule of this arrival sequence. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.
    Hypothesis H_jobs_come_from_arrival_sequence:
      jobs_come_from_arrival_sequence sched arr_seq.

    (* For simplicity, let's define some local names. *)
    Let job_is_pending := pending job_arrival job_cost job_jitter sched.
    Let job_is_backlogged := backlogged job_arrival job_cost job_jitter sched.

    (* Next, assume all jobs have valid parameters. *)
    Hypothesis H_valid_job_parameters:
      forall j,
        arrives_in arr_seq j ->
        valid_sporadic_job task_cost task_deadline job_cost job_deadline job_task j.

    (* In this section we prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed.  *)
    Section NoMultipleJobs.

        (* Assume any work-conserving priority-based scheduler. *)
        Variable higher_eq_priority: JLDP_policy Job.
        Hypothesis H_work_conserving:
          work_conserving job_arrival job_cost job_jitter arr_seq sched.
        Hypothesis H_respects_JLDP_policy:
          respects_JLDP_policy job_arrival job_cost job_jitter arr_seq sched higher_eq_priority.

        (* Consider task set ts. *)
        Variable ts: taskset_of sporadic_task.

        (* Assume that all jobs come from the taskset. *)
        Hypothesis H_all_jobs_from_taskset:
          forall j,
            arrives_in arr_seq j ->
            job_task j \in ts.

        (* Suppose that jobs are sequential, ...*)
        Hypothesis H_sequential_jobs: sequential_jobs sched.
        (* ... jobs only execute after the jitter, ... *)
        Hypothesis H_jobs_execute_after_jitter:
          jobs_execute_after_jitter job_arrival job_jitter sched.
        (* ... and jobs do not execute after completion. *)
        Hypothesis H_completed_jobs_dont_execute:
          completed_jobs_dont_execute job_cost sched.

        (* Assume that the schedule satisfies the sporadic task model. *)
        Hypothesis H_sporadic_tasks:
          sporadic_task_model task_period job_arrival job_task arr_seq.

        (* Consider a valid task tsk, ...*)
        Variable tsk: sporadic_task.
        Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

        (*... whose job j ... *)
        Variable j: Job.
        Hypothesis H_j_arrives: arrives_in arr_seq j.
        Hypothesis H_job_of_tsk: job_task j = tsk.

        (*... is backlogged at time t. *)
        Variable t: time.
        Hypothesis H_j_backlogged: job_is_backlogged j t.

        (* Assume that any previous jobs of tsk have completed by the period. *)
        Hypothesis H_all_previous_jobs_completed :
          forall j_other tsk_other,
            arrives_in arr_seq j_other ->
            job_task j_other = tsk_other ->
            job_arrival j_other + task_period tsk_other <= t ->
            completed job_cost sched j_other (job_arrival j_other + task_period (job_task j_other)).

        Let scheduled_task_other_than (tsk tsk_other: sporadic_task) :=
          task_is_scheduled job_task sched tsk_other t && (tsk_other != tsk).

        (* Then, there can be at most one pending job of each task at time t. *)
        Lemma platform_at_most_one_pending_job_of_each_task :
          forall j1 j2,
            arrives_in arr_seq j1 ->
            arrives_in arr_seq j2 ->
            job_is_pending j1 t ->
            job_is_pending j2 t ->
            job_task j1 = job_task j2 ->
            j1 = j2.
        Proof.
          rename H_sporadic_tasks into SPO, H_all_previous_jobs_completed into PREV.
          intros j1 j2 ARRin1 ARRin2 PENDING1 PENDING2 SAMEtsk.
          apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
          move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
          unfold jitter_has_passed, actual_arrival in *.
          destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
          {
            specialize (SPO j1 j2 DIFF ARRin1 ARRin2 SAMEtsk BEFORE1).
            assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
            {
              apply leq_trans with (n := job_arrival j2); first by done.
              by apply leq_trans with (n := job_arrival j2 + job_jitter j2); first by apply leq_addr.
            }
            exploit (PREV j1 (job_task j1)); try (by done).
            intros COMP1; apply NOTCOMP1.
            by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
          }
          {
            apply ltnW in BEFORE2.
            exploit (SPO j2 j1); try (by done); [by red; ins; subst | intro SPO'].
            assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
            {
              apply leq_trans with (n := job_arrival j1); first by done.
              by apply leq_trans with (n := job_arrival j1 + job_jitter j1); first by apply leq_addr.
            }
            exploit (PREV j2 (job_task j2)); try (by done).
            intros COMP2; apply NOTCOMP2.
            by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
          }
        Qed.

        (* Therefore, all processors are busy with tasks other than tsk. *)
        Lemma platform_cpus_busy_with_interfering_tasks :
          count (scheduled_task_other_than tsk) ts = num_cpus.
        Proof.
          have UNIQ := platform_at_most_one_pending_job_of_each_task.
          rename H_all_jobs_from_taskset into FROMTS, H_sequential_jobs into SEQUENTIAL,
                 H_work_conserving into WORK, H_jobs_come_from_arrival_sequence into FROMarr,
                 H_respects_JLDP_policy into PRIO, H_j_backlogged into BACK,
                 H_job_of_tsk into JOBtsk, H_valid_job_parameters into JOBPARAMS,
                 H_valid_task into TASKPARAMS, H_all_previous_jobs_completed into PREV,
                 H_completed_jobs_dont_execute into COMP, H_jobs_execute_after_jitter into JITTER.
          apply work_conserving_eq_work_conserving_count in WORK.
          unfold valid_sporadic_job, valid_realtime_job,
                 respects_JLDP_policy, completed_jobs_dont_execute,
                 sporadic_task_model, is_valid_sporadic_task,
                 jobs_of_same_task_dont_execute_in_parallel,
                 sequential_jobs in *.
          apply/eqP; rewrite eqn_leq; apply/andP; split.
          {
            apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
              first by apply sub_count; first by red; move => x /andP [SCHED _].
            unfold task_is_scheduled.
            apply count_exists; first by destruct ts.
            {
              intros cpu x1 x2 SCHED1 SCHED2.
              destruct (sched cpu t); last by done.
              move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
              by rewrite -SCHED1 -SCHED2.
            }
          }
          {
            rewrite -(WORK j t) // -count_predT.
            apply leq_trans with (n := count
                                         (fun j => scheduled_task_other_than tsk (job_task j))
                                         (jobs_scheduled_at sched t));
              last first.
            {
              rewrite -count_map.
              apply count_sub_uniqr; last first.
              {
                move => tsk' /mapP [j' INj' JOBtsk']; subst; apply FROMTS.
                by rewrite mem_scheduled_jobs_eq_scheduled in INj'; eauto 2.
              }
              rewrite map_inj_in_uniq; first by apply scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRin2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
            }
            {
              apply sub_in_count; intros j' SCHED' _.
              rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
              unfold scheduled_task_other_than; apply/andP; split.
              {
                move: SCHED' => /existsP [cpu /eqP SCHED'].
                by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
              }
              {
                apply/eqP; red; intro SAMEtsk; symmetry in SAMEtsk.
                move: BACK => /andP [PENDING NOTSCHED].
                generalize SCHED'; intro PENDING'.
                have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
                exploit (UNIQ j j'); try (by done);
                  [by apply scheduled_implies_pending | by rewrite -SAMEtsk |].
                by intro EQjob; subst; rewrite SCHED' in NOTSCHED.
              }
            }
          }
        Qed.

    End NoMultipleJobs.

    (* In this section we also prove the absence of multiple jobs of the same
       task when constrained deadlines are assumed, but in the specific case
       of fixed-priority scheduling.  *)
    Section NoMultipleJobsFP.

      (* Assume any work-conserving priority-based scheduler. *)
      Variable higher_eq_priority: FP_policy sporadic_task.
      Hypothesis H_work_conserving: work_conserving job_arrival job_cost job_jitter arr_seq sched.
      Hypothesis H_respects_JLDP_policy:
        respects_FP_policy job_arrival job_cost job_task job_jitter arr_seq sched higher_eq_priority.

      (* Consider any task set ts. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that all jobs come from the taskset. *)
      Hypothesis H_all_jobs_from_taskset:
        forall j,
          arrives_in arr_seq j ->
          job_task j \in ts.

      (* Suppose that jobs are sequential, ...*)
      Hypothesis H_sequential_jobs: sequential_jobs sched.
      (* ... jobs only execute after the jitter, ... *)
      Hypothesis H_jobs_execute_after_jitter:
        jobs_execute_after_jitter job_arrival job_jitter sched.
      (* ... and jobs do not execute after completion. *)
      Hypothesis H_completed_jobs_dont_execute:
        completed_jobs_dont_execute job_cost sched.

      (* Assume that the schedule satisfies the sporadic task model. *)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Consider a valid task tsk, ...*)
      Variable tsk: sporadic_task.
      Hypothesis H_valid_task: is_valid_sporadic_task task_cost task_period task_deadline tsk.

      (*... whose job j ... *)
      Variable j: Job.
      Hypothesis H_j_arrives: arrives_in arr_seq j.
      Hypothesis H_job_of_tsk: job_task j = tsk.

      (*... is backlogged at time t <= job_arrival j + task_period tsk. *)
      Variable t: time.
      Hypothesis H_j_backlogged: job_is_backlogged j t.
      Hypothesis H_t_before_period: t < job_arrival j + task_period tsk.

      (* Recall the definition of a higher-priority task (with respect to tsk). *)
      Let is_hp_task := higher_priority_task higher_eq_priority tsk.

      (* Assume that any jobs of higher-priority tasks complete by their period. *)
      Hypothesis H_all_previous_jobs_completed :
        forall j_other tsk_other,
          arrives_in arr_seq j_other ->
          job_task j_other = tsk_other ->
          is_hp_task tsk_other ->
          completed job_cost sched j_other (job_arrival j_other + task_period tsk_other).

      (* Assume that any jobs of tsk prior to j complete by their period. *)
      Hypothesis H_all_previous_jobs_of_tsk_completed :
        forall j0,
          arrives_in arr_seq j0 ->
          job_task j0 = tsk ->
          job_arrival j0 < job_arrival j ->
          completed job_cost sched j0 (job_arrival j0 + task_period tsk).

      Definition scheduled_task_with_higher_eq_priority (tsk_other: sporadic_task) :=
        task_is_scheduled job_task sched tsk_other t &&
        is_hp_task tsk_other.

      (* Then, there can be at most one pending job of higher-priority tasks at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_interfering_tasks :
        forall j1 j2,
          arrives_in arr_seq j1 ->
          arrives_in arr_seq j2 ->
          job_is_pending j1 t ->
          job_is_pending j2 t ->
          job_task j1 = job_task j2 ->
          is_hp_task (job_task j1) ->
          j1 = j2.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO, H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV.
        intros j1 j2 ARRin1 ARRin2 PENDING1 PENDING2 SAMEtsk INTERF.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: PENDING1 PENDING2 => /andP [ARRIVED1 /negP NOTCOMP1] /andP [ARRIVED2 /negP NOTCOMP2].
        destruct (leqP (job_arrival j1) (job_arrival j2)) as [BEFORE1 | BEFORE2].
        {
          specialize (SPO j1 j2 DIFF ARRin1 ARRin2 SAMEtsk BEFORE1).
          assert (LEt: job_arrival j1 + task_period (job_task j1) <= t).
          {
            apply leq_trans with (n := job_arrival j2); first by done.
            by apply leq_trans with (n := job_arrival j2 + job_jitter j2); first by apply leq_addr.
          }
          exploit (PREV j1 (job_task j1) ARRin1); [by done | by apply INTERF | intros COMP1].
          apply NOTCOMP1.
          by apply completion_monotonic with (t0 := job_arrival j1 + task_period (job_task j1)).
        }
        {
          apply ltnW in BEFORE2.
          feed (SPO j2 j1); first by red; ins; subst j2.
          feed (SPO ARRin2 ARRin1); first by rewrite SAMEtsk.
          feed SPO; first by done.
          assert (LEt: job_arrival j2 + task_period (job_task j2) <= t).
          {
            apply leq_trans with (n := job_arrival j1); first by done.
            by apply leq_trans with (n := job_arrival j1 + job_jitter j1); first by apply leq_addr.
          }
          exploit (PREV j2 (job_task j2) ARRin2);
            [by done | by rewrite -SAMEtsk | intro COMP2 ].
          apply NOTCOMP2.
          by apply completion_monotonic with (t0 := job_arrival j2 + task_period (job_task j2)).
        }
      Qed.

      (* Also, there can be at most one pending job of tsk at time t. *)
      Lemma platform_fp_no_multiple_jobs_of_tsk :
        forall j',
          arrives_in arr_seq j' ->
          job_is_pending j' t ->
          job_task j' = tsk ->
          j' = j.
      Proof.
        unfold sporadic_task_model in *.
        rename H_sporadic_tasks into SPO,
               H_valid_task into PARAMS,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_all_previous_jobs_completed into PREV,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk.
        intros j' ARRin' PENDING' SAMEtsk.
        apply/eqP; rewrite -[_ == _]negbK; apply/negP; red; move => /eqP DIFF.
        move: BACK PENDING' => /andP [/andP [ARRIVED /negP NOTCOMP] NOTSCHED]
                               /andP [ARRIVED' /negP NOTCOMP'].
        destruct (leqP (job_arrival j') (job_arrival j)) as [BEFORE | BEFORE'].
        {
          exploit (SPO j' j DIFF ARRin' H_j_arrives); [by rewrite JOBtsk | by done | intro SPO'].
          assert (LEt: job_arrival j' + task_period tsk <= t).
          {
            apply leq_trans with (n := job_arrival j); first by rewrite -SAMEtsk.
            by apply leq_trans with (n := job_arrival j + job_jitter j); first by apply leq_addr.
          }
          apply NOTCOMP'.
          apply completion_monotonic with (t0 := job_arrival j' + task_period tsk); try (by done).
          apply PREVtsk; try (by done).
          apply leq_trans with (n := job_arrival j' + task_period tsk); last by rewrite -SAMEtsk.
          rewrite -addn1; apply leq_add; first by done.
          by unfold is_valid_sporadic_task in *; des.
        }
        {
          unfold jitter_has_passed, actual_arrival in *.
          rewrite leqNgt in ARRIVED'; move: ARRIVED' => /negP BUG; apply BUG.
          apply leq_trans with (n := job_arrival j'); last by apply leq_addr.
          apply leq_trans with (n := job_arrival j + task_period tsk); first by done.
          by rewrite -JOBtsk; apply SPO; try (by done);
            [by red; ins; subst j' | by rewrite SAMEtsk | by apply ltnW].
        }
      Qed.

      (* Therefore, all processors are busy with tasks other than tsk. *)
      Lemma platform_fp_cpus_busy_with_interfering_tasks :
        count scheduled_task_with_higher_eq_priority ts = num_cpus.
      Proof.
        have UNIQ := platform_fp_no_multiple_jobs_of_interfering_tasks.
        have UNIQ' := platform_fp_no_multiple_jobs_of_tsk.
        rename H_all_jobs_from_taskset into FROMTS, H_sequential_jobs into SEQUENTIAL,
               H_work_conserving into WORK, H_respects_JLDP_policy into PRIO,
               H_j_backlogged into BACK, H_job_of_tsk into JOBtsk,
               H_sporadic_tasks into SPO, H_valid_job_parameters into JOBPARAMS,
               H_valid_task into TASKPARAMS, H_all_previous_jobs_completed into PREV,
               H_completed_jobs_dont_execute into COMP,
               H_jobs_come_from_arrival_sequence into FROMarr,
               H_all_previous_jobs_of_tsk_completed into PREVtsk,
               H_jobs_execute_after_jitter into JITTER.
        apply work_conserving_eq_work_conserving_count in WORK.
        unfold valid_sporadic_job, valid_realtime_job,
               respects_FP_policy, respects_JLDP_policy, FP_to_JLDP,
               completed_jobs_dont_execute, sequential_jobs,
               sporadic_task_model, is_valid_sporadic_task,
               jobs_of_same_task_dont_execute_in_parallel,
               is_hp_task in *.
        apply/eqP; rewrite eqn_leq; apply/andP; split.
        {
          apply leq_trans with (n := count (fun x => task_is_scheduled job_task sched x t) ts);
            first by apply sub_count; red; move => x /andP [SCHED _].
          unfold task_is_scheduled.
          apply count_exists; first by destruct ts.
          {
            intros cpu x1 x2 SCHED1 SCHED2.
            destruct (sched cpu t); last by done.
            move: SCHED1 SCHED2 => /eqP SCHED1 /eqP SCHED2.
            by rewrite -SCHED1 -SCHED2.
          }
        }
        {
          rewrite -(WORK j t) // -count_predT.
          apply leq_trans with (n := count (fun j =>
            scheduled_task_with_higher_eq_priority (job_task j)) (jobs_scheduled_at sched t));
            last first.
          {
            rewrite -count_map.
            apply leq_trans with (n := count predT
                    [seq x <- (map (fun j => job_task j) (jobs_scheduled_at sched t))
                      | scheduled_task_with_higher_eq_priority x]);
              first by rewrite count_filter; apply sub_count; red; ins.
            apply leq_trans with (n := count predT
                                   [seq x <- ts | scheduled_task_with_higher_eq_priority x]);
              last by rewrite count_predT size_filter.
            apply count_sub_uniqr; last first.
            {
              red; intros tsk' IN'.
              rewrite mem_filter in IN'; move: IN' => /andP [SCHED IN'].
              rewrite mem_filter; apply/andP; split; first by done.
              move: IN' => /mapP [j' IN'] ->; apply FROMTS.
              by rewrite mem_scheduled_jobs_eq_scheduled in IN'; eauto 2.
            }
            {
              rewrite filter_map.
              rewrite map_inj_in_uniq; first by apply filter_uniq, scheduled_jobs_uniq.
              red; intros j1 j2 SCHED1 SCHED2 SAMEtsk.
              rewrite 2!mem_filter in SCHED1 SCHED2.
              move: SCHED1 SCHED2 => /andP [/andP [_ HP1] SCHED1] /andP [/andP [_ HP2] SCHED2].
              rewrite 2!mem_scheduled_jobs_eq_scheduled in SCHED1 SCHED2.
              have ARRin1: arrives_in arr_seq j1 by apply (FROMarr j1 t).
              have ARRIn2: arrives_in arr_seq j2 by apply (FROMarr j2 t).
              by apply UNIQ; try (by done); apply scheduled_implies_pending.
            }
          }
          {
            apply sub_in_count; intros j' SCHED' _.
            rewrite mem_scheduled_jobs_eq_scheduled in SCHED'.
            apply/andP; split.
            {
              move: SCHED' => /existsP [cpu /eqP SCHED'].
              by apply/existsP; exists cpu; rewrite /task_scheduled_on SCHED' eq_refl.
            }
            apply/andP; split; first by rewrite -JOBtsk; apply PRIO with (t := t).
            {
              apply/eqP; red; intro SAMEtsk.
              generalize SCHED'; intro PENDING'.
              have ARRin': arrives_in arr_seq j' by apply (FROMarr j' t).
              apply scheduled_implies_pending with (job_arrival0 := job_arrival)
                (job_cost0 := job_cost) (job_jitter0 := job_jitter) in PENDING'; try (by done).
              specialize (UNIQ' j' ARRin' PENDING' SAMEtsk); subst j'.
              by move: BACK => /andP [_ NOTSCHED]; rewrite SCHED' in NOTSCHED.
            }
          }
        }
      Qed.

    End NoMultipleJobsFP.

  End Lemmas.

End ConstrainedDeadlines.


(**

  SP.v

  Second Prize, as mech.v mechanism.

  Reference: see Tim Roughgarden's Lecture note #13 CS269I.

  Proofs :
  - SP is rational.
  - SP is truthful.
  - SP is Pareto-optimal.
  - Provide 2 Nash equilibria (default and "Wolf and Sheep").

  Pierre Jouvelot (30/6/2021).

  Licence: CeCILL-B.

*)

From Coq Require Import Unicode.Utf8.
From mathcomp Require Import all_ssreflect.
From mathcomp.fingroup Require Import perm.

From mech.lib Require Import lib labelling mech.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Variable (n'' : nat).

Definition n' := n''.+1.
Definition n := n'.+1.

Definition A := agent.type n.

Notation last_agent := (@agent.last n).
Notation agent_succ := (@agent.succ n').
Notation agent_pred := (@agent.pred n).

Variable p' : nat.
Definition p := p'.+1.
Definition bid := 'I_p.
Definition bid0 : bid := Ordinal (ltn0Sn p').
Definition bids := n.-tuple bid.

Let geq_bid := @geq_bid p'.

Notation tsort := (tsort geq_bid).
Notation idxa := (idxa geq_bid).

Section Algorithm.

Variable (bs0 : bids) (i : A).

Let bs := tsort bs0.
Let i' := idxa bs0 i.

Definition i0 : A := ord0.

Definition is_winner := (i' == i0).
Definition price : nat := tnth bs (agent_succ i').

End Algorithm.

Section Prices.

Notation is_labelling := (is_labelling geq_bid).
Notation tlabel := (tlabel geq_bid).

Definition labelling_of (bs : bids) : labelling _ := xchoose (exists_labelling geq_bid bs).

Lemma tsorted_bids_sorted (bs : bids) : sorted_bids (tsort bs).
Proof.
apply/sorted_bids_sorted.
apply: sort_sorted.
exact: total_geq_bid.
Qed.

Section BothWin.

Variable (bs bs' : bids) (a : A) (diff : differ_on bs bs' a).

Let i := idxa bs a.
Let i' := idxa bs' a.

Variable (iwins : i = i0) (iwins' : i' = i0).

Let l := tlabel bs.

Lemma bs_uniq_labelling : projT1 (exists_labellingW geq_bid bs) = l.
Proof. exact: uniq_labelling. Qed.

Let l' := l.

Definition over_bids := [tuple tnth bs' (tnth l' j) | j < n].

Lemma max_first j : tnth bs' j <= tnth bs' a.
Proof.
rewrite -(labelling_spec_idxa geq_bid bs' a) -(labelling_spec_idxa geq_bid bs' j).
apply: tsorted_bids_sorted.
by move: iwins'; rewrite /i' => ->.
Qed.

Lemma sorted_over_bids : sorted_bids over_bids.
Proof.
move=> j1 j2 lej1j2.
rewrite !tnth_map !tnth_ord_tuple.
move: diff.
rewrite /differ_on /action_on => d.
- have [] := boolP (j1 == i0) => [/eqP eqj10|].
  - have [] := boolP (j2 == i0) => /eqP eqj20.
    by rewrite eqj10 eqj20.
  - by rewrite eqj10 -iwins cancel_idxa  max_first.
- rewrite -lt0n => lt0j1.
  have inva : a = tnth l i by rewrite cancel_idxa.
  have netnth (j : A) : j != i -> tnth (projT1 (exists_labellingW geq_bid bs)) j != tnth l i.
    apply: contra_neq.
    rewrite bs_uniq_labelling.
    apply: labelling_inj.
    exact: tlabelP.
  rewrite !d /l' -?bs_uniq_labelling ?inva.
  move: (labellingP geq_bid bs) => /forallP /(_ j2) /eqP <-.
  move: (labellingP geq_bid bs) => /forallP /(_ j1) /eqP <-.
  exact: tsorted_bids_sorted.
  by have/netnth: j1 != i by rewrite iwins -(inj_eq val_inj) /= -lt0n.
  by have/netnth: j2 != i by rewrite neq_ltn [X in _ || X](@leq_trans j1) // iwins ?orbT.
Qed.

Lemma perm_over_bids : perm_eq bs' over_bids.
Proof.
have xbs' : bs' = [tuple tnth bs' j | j < n].
  apply: eq_from_tnth => j.
  by rewrite tnth_map tnth_ord_tuple.
rewrite {1}xbs' /=.
set arg2 := (X in perm_eq _ X).
have -> : arg2 = [seq tnth bs' j | j <- map (tnth l') (enum 'I_n)].
  apply: (@eq_from_nth _ bid0) => [|j ltjs]; first by rewrite !size_map.
  rewrite size_map size_enum_ord in ltjs.
  by rewrite !(@nth_map _ i0) // ?size_map -?enumT ?size_enum_ord.
apply: perm_map.
rewrite map_tnth_enum -(sort_inj_ord (labelling_inj (tlabelP geq_bid bs))).
by rewrite perm_sort perm_refl.
Qed.

Lemma is_over_labelling : labelling_of bs' = l'.
Proof.
have sorted: sorted_bids over_bids by exact: sorted_over_bids.
have sorting :=
  sorted_sort (@transitive_geq_bid p') (iffLR (sorted_bids_sorted over_bids) sorted).
have sortedbs': sort geq_bid bs' = over_bids.
  rewrite -sorting.
  apply/perm_sortP => //.
  exact: total_geq_bid.
  exact: transitive_geq_bid.
  exact: anti_geq_bid.
  exact: perm_over_bids.
have: is_labelling bs' l'.
  apply/eqP.
  apply: eq_from_tnth => j.
  rewrite !tnth_map !(tnth_nth bid0) tupleE /= sortedbs'.
  rewrite (@nth_map _ j _ bid0) ?(tnth_nth bid0);
    last by rewrite size_enum_ord ltn_ord.
  by rewrite val_ord_tuple nth_ord_enum.
have: is_labelling bs' (labelling_of bs') by apply: xchooseP.
exact: labelling_singleton.
Qed.

Lemma eq_winning_price  :
  tnth (tsort bs') (agent_succ i0) = tnth (tsort bs) (agent_succ i0).
Proof.
set i1 := agent_succ i0.
move: (labellingP geq_bid bs') => /forallP /(_ i1) /eqP ->.
move: (labellingP geq_bid bs) => /forallP /(_ i1) /eqP ->.
have -> : projT1 (exists_labellingW geq_bid bs') = l'.
  apply: labelling_singleton.
  move: (exists_labellingW geq_bid bs') => [lab islab].
  exact: islab.
  by rewrite -is_over_labelling tlabelP.
rewrite bs_uniq_labelling.
apply: diff.
have -> : a = tnth l' i by rewrite cancel_idxa.
have: i1 != i by rewrite iwins.
apply: contra_neq.
apply: (@labelling_inj _ _ _ _ l).
exact: tlabelP.
Qed.

End BothWin.

Section iLoses.

Variable (bs bs' : bids) (a : A) (diff : differ_on bs bs' a).

Let i := idxa bs a.
Let i' := idxa bs' a.

Variable (iloses : i != i0) (iwins' : i' = i0).

Let l := tlabel bs.

Lemma l_inj : injective (tnth l).
Proof. exact: labelling_inj (tlabelP geq_bid bs). Qed.

Lemma cancel_a : a = tnth l (idxa bs a).
Proof. by rewrite cancel_idxa. Qed.

Let under_index (j : A) := if j == i0 then
                             a
                           else if i0 < j <= i then
                                  tnth l (agent_pred j)
                                else
                                  tnth l j.
Let l' := [tuple under_index j | j < n].

Definition under_bids := [tuple tnth bs' (tnth l' j) | j < n].

Lemma sorted_under_bids : sorted_bids under_bids.
Proof.
move=> j1 j2 lej1j2.
move: diff; rewrite /differ_on /action_on => d.
rewrite !tnth_map !tnth_ord_tuple.
have relabpred (j : A) (lt0j : 0 < j) (leji : j <= i) :
  tnth bs' (tnth l (agent_pred j)) =  tnth (tsort bs) (agent_pred j).
  move: (labellingP geq_bid bs) => /forallP /(_ (agent_pred j)) /eqP.
  rewrite d ?[X in _ != X]cancel_a.
  rewrite uniq_labelling => <- //.
  have: agent_pred j != i.
    rewrite neq_ltn. apply/orP. left=> //=.
    by rewrite (@leq_trans j) // ltn_predL.
  by apply: contra => /eqP /l_inj /eqP.
have relab (j : A) (ltij : i < j): tnth bs' (tnth l j) =  tnth (tsort bs) j.
  move: (labellingP geq_bid bs) => /forallP /(_ j) /eqP.
  rewrite d ?[X in _ != X]cancel_a.
  rewrite uniq_labelling => <- //.
  have: j != i by rewrite neq_ltn ltij orbT.
  by apply: contra => /eqP /l_inj /eqP.
- have [] := boolP (j1 == i0) => eqj10 //.
  have [] := boolP (j2 == i0) => eqj20; first by rewrite /under_index !ifT.
  - have [] := boolP (j2 <= i) => ltj2i.
    rewrite /under_index ifF ?ifT ?max_first //; last by exact: negbTE.
    rewrite -(inj_eq val_inj) /= in eqj20.
    by rewrite /= lt0n ltj2i eqj20 // negbTE.
  - rewrite /under_index ifF; last by exact: negbTE.
    rewrite ifF ?ifT ?max_first //.
    by rewrite (negbTE ltj2i) andbF.
- have [] := boolP (j1 <= i) => ltj1i.
  rewrite /under_index (@ifF _ (j1 == i0)); last by exact: negbTE.
  rewrite -lt0n in eqj10.
  rewrite (@ifT _ (i0 < j1 <= i)); last by rewrite eqj10 ltj1i.
  - have [] := boolP (j2 == i0) => [/eqP|] eqj20; first by rewrite eqj20 leqNgt eqj10 in lej1j2.
  - rewrite -lt0n in eqj20.
    - have [] := boolP (j2 <= i) => ltj2i.
      rewrite !ifT //; last by rewrite eqj20.
      by rewrite !relabpred // tsorted_bids_sorted //= -!subn1 leq_sub2r.
    - rewrite andbF relabpred // relab // ?ltnNge //.
      by rewrite tsorted_bids_sorted //= (@leq_trans j1) // leq_pred.
- rewrite /under_index (@ifF _ (j1 == i0)); last by exact: negbTE.
  rewrite (@ifF _ (i0 < j1 <= i)); last by rewrite lt0n eqj10 (negbTE ltj1i).
  - have [] := boolP (j2 == i0) => [/eqP|] eqj20.
    by rewrite eqj20 leqNgt lt0n eqj10 in lej1j2.
  - have [] := boolP (j2 <= i) => ltj2i.
    by rewrite leqNgt (@leq_ltn_trans i) ?ltnNge in lej1j2.
  - by rewrite andbF !relab ?ltnNge // tsorted_bids_sorted.
Qed.

Lemma under_inj : injective under_index.
Proof.
move=> j1 j2.
wlog: j1 j2 / j1 <= j2 => [H|].
  move: (leq_total j1 j2) => /orP [lej1j2|lej2j /esym ei21]; first by exact: H.
  apply: esym.
  exact: H.
have [] := boolP (j1 == j2) => [/eqP ->|]; first by [].
rewrite /under_index cancel_a -(inj_eq val_inj) /= leq_eqVlt => /negbTE ->.
rewrite orFb.
have [] := boolP (j1 == i0) => [/eqP eqj10|nej10].
- have [] := boolP (j2 == i0) => [/eqP eqj20|nej20]; first by rewrite eqj10 eqj20.
  have [] := boolP (j2 <= i) => ltj2i ltj1j2.
  - rewrite eqj10 /= lt0n nej20 /= => /l_inj /eqP.
    rewrite -(inj_eq val_inj) //= => /eqP eqij21.
    move: ltj2i.
    rewrite eqij21 leqNgt ltn_predL lt0n.
    rewrite -(inj_eq val_inj) /= in nej20.
    by rewrite nej20.
  - rewrite andbF => /l_inj /eqP.
    rewrite -ltnNge /i in ltj2i.
    move/ltn_eqF: ltj2i.
    by rewrite -(inj_eq val_inj) => /= ->.
- have [] := boolP (j1 <= i) => ltj1i.
  rewrite -lt0n in nej10.
  have [] := boolP (j2 == i0) => [/eqP ->|eqj20 _]; first by rewrite ltn0.
  rewrite nej10 /= lt0n eqj20.
  have [] := boolP (j2 <= i) => ltj2i /= /l_inj eqpred.
  - rewrite -lt0n in eqj20.
    apply: val_inj => /=.
    move: eqpred => /(ord_pred_inj nej10 eqj20) /eqP.
    by rewrite -(inj_eq val_inj) //= => /eqP.
  - rewrite -ltnNge in ltj2i.
    move: (leq_ltn_trans ltj1i ltj2i).
    by rewrite ltnNge -eqpred /= leq_pred.
- rewrite lt0n nej10 //= [X in _ && X]leqNgt => ltj1j2.
  rewrite -ltnNge in ltj1i.
  move: (ltn_trans ltj1i ltj1j2) => -> /=.
  rewrite -lt0n in nej10.
  move: (ltn_trans nej10 ltj1j2).
  rewrite andbF -(inj_eq val_inj) /= lt0n => /negbTE -> /=.
  exact: l_inj.
Qed.

Lemma perm_under_bids : perm_eq bs' under_bids.
Proof.
rewrite perm_sym.
apply/tuple_permP.
exists (perm under_inj) => /=.
apply: (@eq_from_nth _ bid0) => [|j]; first by rewrite !size_map.
rewrite size_map size_enum_ord => ltjn.
rewrite [LHS](@nth_map _ i0); last by rewrite size_enum_ord.
rewrite [RHS](@nth_map _ i0); last by rewrite size_enum_ord.
by rewrite permE tnth_map tnth_ord_tuple.
Qed.

Lemma is_under_labelling : labelling_of bs' = l'.
Proof.
have sorted: sorted_bids under_bids by exact: sorted_under_bids.
have sorting :=
  sorted_sort (@transitive_geq_bid p') (iffLR (sorted_bids_sorted under_bids) sorted).
have sortedbs': sort geq_bid bs' = under_bids.
  rewrite -sorting.
  apply/perm_sortP => //.
  exact: total_geq_bid.
  exact: transitive_geq_bid.
  exact: anti_geq_bid.
  exact: perm_under_bids.
have: is_labelling bs' l'.
  apply/eqP.
  apply: eq_from_tnth => j.
  rewrite !tnth_map !(tnth_nth bid0) tupleE /= sortedbs'.
  rewrite tnth_ord_tuple.
  rewrite (@nth_map _ j _ bid0) ?(tnth_nth bid0);
    last by rewrite size_enum_ord ltn_ord.
  congr nth.
  rewrite /l' tnth_map (tnth_nth i0).
  by rewrite !val_ord_tuple !nth_ord_enum.
have: is_labelling bs' (labelling_of bs') by apply: xchooseP.
exact: labelling_singleton.
Qed.

Lemma eq_losing_price : tnth (tsort bs') (agent_succ i0) = tnth (tsort bs) i0.
Proof.
set i1 := agent_succ i0.
move: (labellingP geq_bid bs') => /forallP /(_ i1) /eqP ->.
move: (labellingP geq_bid bs) => /forallP /(_ i0) /eqP ->.
have -> : projT1 (exists_labellingW geq_bid bs') = l'.
  apply: labelling_singleton.
  move: (exists_labellingW geq_bid bs') => [lab islab].
  exact: islab.
  by rewrite -is_under_labelling tlabelP.
rewrite /l' tnth_map tnth_ord_tuple bs_uniq_labelling.
rewrite /under_index ifT /=; last by rewrite lt0n.
have -> : (agent_pred i1) = i0 by exact: val_inj.
apply: diff.
have -> : a = tnth l i by rewrite cancel_idxa.
have: i0 != i by rewrite eq_sym.
apply: contra_neq.
apply: (@labelling_inj _ _ _ _ l).
exact: tlabelP.
Qed.

End iLoses.

End Prices.

Definition m :=
  mech.new (fun bs => map_tuple (fun i => (is_winner bs i, bs)) (agent.agents n)).

Definition a :=
  auction.new (fun (o : mech.O m) i =>
                 let: (w, bs) := tnth o i in if w then Some (price bs i) else None).

Variable v : agent.type n -> bid.

Definition prefs := auction.prefs a v.

Section Properties.

(** SP is rational, if one bids truthfully. *)

Theorem individual_rational i (tv : forall bs, tnth bs i = v i) : auction.individual_rational a v i.
Proof.
rewrite /auction.individual_rational /auction.p /= => o.
case: (tnth o i) => iw' bs'.
case: ifP => [_|//].
by rewrite -(tv bs') -(labelling_spec_idxa geq_bid bs' i) tsorted_bids_sorted // le_ord_succ.
Qed.

(** SP is truthful *)

Theorem truthful_SP : truthful prefs.
Proof.
rewrite /truthful => bs bs' i diff /=.
rewrite /auction.U /auction.p /= !tnth_map /= !tnth_ord_tuple.
case: ifP => [iw'|//].
case: ifP => iw.
- rewrite leq_sub2l // /price.
  move: (iw) (iw') => /eqP -> /eqP ->.
  rewrite /is_winner in iw iw'.
  rewrite (eq_winning_price diff) //; last by apply/eqP.
  by apply/eqP.
- rewrite /action_on => <-.
  rewrite leqn0 subn_eq0 /price.
  move: (iw') => /eqP ->.
  rewrite /is_winner in iw iw'.
  rewrite (eq_losing_price diff) // -?(labelling_spec_idxa geq_bid bs).
  exact: tsorted_bids_sorted.
  by move: iw; apply: contraFneq => ->.
  by apply/eqP.
Qed.

(** Two proofs that SP with truthful bidding is a Nash equilibrium:
    - direct
    - using weak dominance property. *)

Lemma SP_Nash_truthful_direct: Nash_equilibrium prefs v.
Proof.
rewrite /Nash_equilibrium => i s'.
rewrite /U /prefs.U /= /auction.U /auction.p /= !tnth_map !tnth_ord_tuple.
case: ifP => [iw'|//].
move: iw'; rewrite /is_winner /actions /price => /eqP eqix'0.
case: ifP => [iw|neiw]; last first.
- pose bs := [tuple v j | j < n]; set bs' := (X in tsort X).
  rewrite eqix'0 (@eq_losing_price bs bs' i) //; last by rewrite negbT.
  - have -> : v i = tnth (tsort bs) (idxa bs i)
      by rewrite labelling_spec_idxa tnth_map tnth_ord_tuple.
    by rewrite leqn0 subn_eq0 tsorted_bids_sorted.
  - rewrite /differ_on /action_on => j.
    by rewrite !tnth_map !tnth_ord_tuple -{2}(negbK (j == i)) => ->.
- rewrite leq_sub2l // /price.
  move: (iw); rewrite /is_winner => /eqP eqix0.
  set bs := actions v; set bs' := set_in_actions v s' i.
  rewrite eqix0 eqix'0 (@eq_winning_price bs bs' i) // => j neji.
  by rewrite /differ_on /action_on !tnth_map !tnth_ord_tuple ifF // (negbTE neji).
Qed.

(* SP being a truthful auction, it is a Nash equilibrium. *)

Definition m_t := truthfulMech.new truthful_SP.

Definition a_t :=
  auction.new (fun (o : mech.O m_t) i =>
                 let: (w, bs) := tnth o i in if w then Some (price bs i) else None).

Definition prefs_t := auction.prefs a_t v.

Lemma SP_Nash_truthful : Nash_equilibrium prefs_t v.
Proof. exact: truthfulMech.Nash_truthful. Qed.

(** Truthful bidding in SP is a Pareto optimum. *)

Lemma Pareto_optimal_SP : Pareto_optimal prefs (true_value_strategy prefs).
Proof.
rewrite /Pareto_optimal /action_on => s' i.
set bs := [tuple v j  | j < n].
set bs' := [tuple if j == i then s' j else v j  | j < n].
have diff : differ_on bs bs' i.
  move=> j.
  rewrite /action_on /bs' !tnth_map !tnth_ord_tuple.
  by case: ifP.
set U := (X in X < _); set U' := (X in _ < X) => ltUU'.
move: (ltUU').
have -> // : 0 < U' -> U' = U; last by rewrite (@leq_ltn_trans U).
  rewrite /U /U' /prefs.U /= /auction.U /auction.p /=.
  rewrite !tnth_map /= !tnth_ord_tuple => lt0U'.
  case: ifP => [/eqP iw'|niw']; last by move: lt0U'; rewrite niw'.
  case: ifP => [/eqP iw|niw].
  - congr (_ - _).
    by rewrite /price iw iw' (@eq_winning_price bs bs' i).
  - apply/eqP; rewrite subn_eq0 /price.
    rewrite /is_winner in niw iw'.
    rewrite iw' (@eq_losing_price bs bs' i) //; last by rewrite niw.
    rewrite (@leq_trans (tnth (tsort bs) (idxa bs i))) //; last by exact: tsorted_bids_sorted.
    by rewrite !labelling_spec_idxa tnth_map tnth_ord_tuple.
by rewrite ltnn.
Qed.

(** "Wolf and sheep" bidding is another Nash equilibrium for SP when bidding truthfully.
     See https://homepages.cwi.nl/~apt/stra/ch7.pdf. *)

Section Wolf.

Notation cancel_inv_idxa := (cancel_inv_idxa geq_bid).
Notation labelling_spec_idxa := (labelling_spec_idxa geq_bid).
Notation tlabel := (tlabel geq_bid).

Variable bs : bids.

Definition l := tlabel bs.

Definition wolf := [tuple if idxa bs j == i0 then v j else bid0 | j < n].

Definition sorted_wolf := [tuple of (v (tnth l i0)) :: nseq n' bid0].

Local Lemma refold (b : bid) : b :: nseq n'' b = nseq n' b.
Proof. by []. Qed.

Lemma sorted_sorted_wolf : sorted_bids sorted_wolf.
Proof.
move=> j1 j2 le12.
rewrite !(tnth_nth bid0).
have [/eqP -> |] := boolP (j1 == i0).
- have [/eqP -> //=|ne20] := boolP (j2 == i0).
  have lt02: 0 < j2 by move: ne20;  rewrite -(inj_eq val_inj) /= lt0n.
  by rewrite -(@prednK j2) //= refold nth_nseq if_same.
- rewrite -(inj_eq val_inj) /= -lt0n => lt01.
  have lt02: 0 < j2 by rewrite (@leq_trans j1).
  by rewrite -(@prednK j2) // -(@prednK j1) //= !refold nth_nseq if_same.
Qed.

Lemma perm_eq_wolf : perm_eq sorted_wolf wolf.
Proof.
apply/tuple_permP.
exists (tperm i0 (tnth l i0)).
apply: (@eq_from_nth _ ord0) => [|i ltin]; first by rewrite !size_tuple.
rewrite /= size_nseq in ltin.
rewrite !(nth_map ord_max) -?enumT ?size_enum_ord //.
have [/eqP eqi0|] := boolP (i == i0).
- rewrite eqi0 /= nth_agent_enum.
  have -> : @Ordinal (S n') O is_true_true = ord0 by exact: val_inj.
  by rewrite tpermL /= tnth_map tnth_ord_tuple /wolf cancel_inv_idxa -(inj_eq val_inj).
- rewrite nth_agent_enum /= => nei0.
  rewrite -lt0n in nei0.
  have [/eqP eqil0|neil0] := boolP (Ordinal ltin == tnth l i0).
  - rewrite eqil0 tpermR /= tnth_map tnth_ord_tuple /wolf.
    rewrite -(@prednK i) //= ?refold ?nth_nseq ?if_same ifF //.
    apply: (contra_eqF _ eqil0) => /eqP <-.
    by rewrite cancel_idxa -(inj_eq val_inj) /= -lt0n.
  - rewrite -[in LHS](@prednK i) //= refold nth_nseq if_same.
    rewrite tpermD ?tnth_map ?tnth_ord_tupl /wolf; last exact: (contra_neq _ neil0).
    - rewrite tnth_ord_tuple ifF //.
      apply: (contra_neqF _ neil0) => /eqP <-.
      by rewrite cancel_idxa.
    - by rewrite -(inj_eq val_inj) /= eq_sym -lt0n.
Qed.

Lemma sort_wolf : tsort wolf = sorted_wolf.
Proof.
have tr: transitive geq_bid by exact: transitive_geq_bid.
apply: val_inj => /=.
have := perm_eq_wolf => /(@perm_sortP _ geq_bid) <- //; last by exact: anti_geq_bid.
- rewrite sorted_sort => [//|//|].
  rewrite (iffLR (sorted_bids_sorted sorted_wolf)) //.
  exact: sorted_sorted_wolf.
- exact: total_geq_bid.
Qed.

Lemma Nash_wolf_and_sheep (tv : tnth bs =1 v) : Nash_equilibrium prefs (tnth wolf).
Proof.
rewrite /Nash_equilibrium => i s'.
rewrite /U /prefs.U /= /auction.U /auction.p /= !tnth_map !tnth_ord_tuple.
set b' := (X in price X).
case: ifP => [iw'|//].
move: iw'; rewrite /is_winner /actions /price => /eqP eqix'0.
case: ifP => [/eqP iw|neiw].
- rewrite /price leq_sub2l // /set_in_actions /actions.
  rewrite tuple_of_tnth in iw *.
  rewrite eqix'0 (@eq_winning_price wolf b' i) // => [|j neji].
  - by rewrite tsorted_bids_sorted // iw.
  - by rewrite /action_on !tnth_map !tnth_ord_tuple ifF // (negbTE neji).
- rewrite eqix'0 -tv leqn0 subn_eq0 (@eq_losing_price wolf b' i) ?negbT //; last first.
  - by rewrite tuple_of_tnth in neiw.
  - rewrite /differ_on /action_on => j.
    by rewrite !tnth_map !tnth_ord_tuple -{2}(negbK (j == i)) => ->.
  - have -> : tnth (tsort wolf) i0 = tnth (tsort bs) i0.
      rewrite sort_wolf (tnth_nth bid0) /=.
      by rewrite -[in RHS](cancel_inv_idxa bs i0) (labelling_spec_idxa bs) -tv.
    by rewrite -(labelling_spec_idxa bs) tsorted_bids_sorted.
Qed.

End Wolf.

End Properties.

(* Check truthful_SP. *)
(* Print Assumptions truthful_SP. *)


(***************************************************************************
* Preservation and Progress for mini-ML (CBV) - Definitions                *
* Arthur Chargueraud, March 2007, Coq v8.1                                 *
* Extension to structural polymorphism                                     *
* Jacques Garrigue, October 2007 - May 2008                                *
***************************************************************************)

Set Implicit Arguments.
Require Import Metatheory List Arith.

(* Constraint domain specification *)

Module Type CstrIntf.
  Parameter cstr attr : Set.
  Parameter valid : cstr -> Prop.
  Parameter valid_dec : forall c, sumbool (valid c) (~valid c).
  Parameter eq_dec : forall x y:attr, {x=y}+{x<>y}.
  Parameter unique : cstr -> attr -> bool.
  Parameter lub : cstr -> cstr -> cstr.
  Parameter entails : cstr -> cstr -> Prop.
  Parameter entails_refl : forall c, entails c c.
  Hint Resolve entails_refl : core.
  Parameter entails_trans : forall c1 c2 c3,
    entails c1 c2 -> entails c2 c3 -> entails c1 c3.
  Parameter entails_lub : forall c1 c2 c,
    (entails c c1 /\ entails c c2) <-> entails c (lub c1 c2).
  Parameter entails_unique : forall c1 c2 v,
    entails c1 c2 -> unique c2 v = true -> unique c1 v = true.
  Parameter entails_valid : forall c1 c2,
    entails c1 c2 -> valid c1 -> valid c2.
End CstrIntf.

Module Type CstIntf.
  Parameter const : Set.
  Parameter arity : const -> nat.
End CstIntf.

Declare Scope typ_scope.

(* Parameterized definitions *)

Module MkDefs(Cstr:CstrIntf)(Const:CstIntf).

(* ********************************************************************** *)
(** ** Description of types *)

(** Grammar of types. *)

Inductive typ : Set :=
  | typ_bvar  : nat -> typ
  | typ_fvar  : var -> typ
  | typ_arrow : typ -> typ -> typ.

(** Types are inhabited, giving us a default value. *)

Definition typ_def := typ_bvar 0.

(** Constraint domain *)

Definition coherent kc (kr:list(Cstr.attr*typ)) := forall x T U,
  Cstr.unique kc x = true -> In (x,T) kr -> In (x,U) kr -> T = U.

Record ckind : Set := Kind {
  kind_cstr : Cstr.cstr;
  kind_valid : Cstr.valid kind_cstr;
  kind_rel  : list (Cstr.attr*typ);
  kind_coherent : coherent kind_cstr kind_rel }.

Definition kind := option ckind.

Definition entails K K' :=
  Cstr.entails (kind_cstr K) (kind_cstr K') /\
  forall T:Cstr.attr*typ, In T (kind_rel K') -> In T (kind_rel K).

(** Type schemes. *)

Record sch : Set := Sch {
  sch_type  : typ ;
  sch_kinds : list kind }.

Notation "'sch_arity' M" :=
  (length (sch_kinds M)) (at level 20, no associativity).

(** Opening body of type schemes. *)

Fixpoint typ_open (T : typ) (Vs : list typ) {struct T} : typ :=
  match T with
  | typ_bvar i      => nth i Vs typ_def
  | typ_fvar x      => typ_fvar x
  | typ_arrow T1 T2 => typ_arrow (typ_open T1 Vs) (typ_open T2 Vs)
  end.

(** Opening body of type schemes with variables *)

Definition typ_fvars :=
  List.map typ_fvar.

Definition typ_open_vars T Xs :=
  typ_open T (typ_fvars Xs).

(** Instanciation of a type scheme *)

Definition sch_open M :=
  typ_open (sch_type M).

Definition sch_open_vars M :=
  typ_open_vars (sch_type M).

Notation "M ^^ Vs" := (sch_open M Vs)
  (at level 67, only parsing) : typ_scope.
Notation "M ^ Xs" :=
  (sch_open_vars M Xs) (only parsing) : typ_scope.

Bind Scope typ_scope with typ.
Open Scope typ_scope.

(** Locally closed types *)

Inductive type : typ -> Prop :=
  | type_fvar : forall X,
      type (typ_fvar X)
  | type_arrow : forall T1 T2,
      type T1 ->
      type T2 ->
      type (typ_arrow T1 T2).

(** List of n locally closed types *)

Definition types := list_for_n type.

(** Iterating and opening kinds *)

Definition kind_types (K:kind) :=
  match K with
  | None => nil
  | Some k => list_snd (kind_rel k)
  end.

Definition All_kind_types (P:typ->Prop) K :=
  list_forall P (kind_types K).

Lemma map_coherent : forall f kc kr,
  coherent kc kr ->
  coherent kc (map_snd f kr).
Proof.
  intros. intro; intros.
  puts (H x).
  destruct (map_snd_inv _ _ _ _ H1) as [T' [Heq Hin]].
  destruct (map_snd_inv _ _ _ _ H2) as [U' [Heq' Hin']].
  subst.
  rewrite* (H3 T' U').
Qed.

Definition ckind_map_spec (f:typ->typ) (k:ckind):
  {k' |  kind_cstr k = kind_cstr k' /\
  kind_rel k' = map_snd f (kind_rel k)}.
Proof.
  intros.
  destruct k as [kc kv kr kh].
  exists (Kind kv (map_coherent f kh)).
  simpl. auto.
Defined.

Definition ckind_map f k := proj1_sig (ckind_map_spec f k).

Definition kind_map f (K:kind) : kind :=
  match K with
  | None => None
  | Some k => Some (ckind_map f k)
  end.

Definition kind_open K Vs := kind_map (fun T => typ_open T Vs) K.

(** Body of a scheme *)

Definition typ_body T Ks :=
  forall Xs, length Ks = length Xs ->
    type (typ_open_vars T Xs) /\
    list_forall (All_kind_types (fun T' => type (typ_open_vars T' Xs))) Ks.

(** Definition of a well-formed scheme *)

Definition scheme M :=
   typ_body (sch_type M) (sch_kinds M).

(* ********************************************************************** *)
(** ** Description of terms *)

(** Grammar of terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_let  : trm -> trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_cst  : Const.const -> trm.

(** Opening term binders. *)

Fixpoint trm_open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if k === i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (trm_open_rec (S k) u t1)
  | trm_let t1 t2 => trm_let (trm_open_rec k u t1) (trm_open_rec (S k) u t2)
  | trm_app t1 t2 => trm_app (trm_open_rec k u t1) (trm_open_rec k u t2)
  | trm_cst c     => trm_cst c
  end.

Definition trm_open t u := trm_open_rec 0 u t.

(* Notation "{ k ~> u } t" := (trm_open_rec k u t) (at level 67). *)
Notation "t ^^ u" := (trm_open t u) (at level 67).
Notation "t ^ x" := (trm_open t (trm_fvar x)).

(** Locally closed termessions *)

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_let : forall L t1 t2,
      term t1 ->
      (forall x, x \notin L -> term (t2 ^ x)) ->
      term (trm_let t1 t2)
  | term_app : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_app t1 t2)
  | term_cst : forall c,
      term (trm_cst c).

(** Definition of the body of an abstraction *)

Definition term_body t :=
  exists L, forall x, x \notin L -> term (t ^ x).

(** Term instanciation *)

Definition trm_def := trm_bvar 0.

Fixpoint trm_inst_rec (k : nat) (tl : list trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => if le_lt_dec k i then nth (i-k) tl t else trm_bvar i
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (trm_inst_rec (S k) tl t1)
  | trm_let t1 t2 => trm_let (trm_inst_rec k tl t1) (trm_inst_rec (S k) tl t2)
  | trm_app t1 t2 => trm_app (trm_inst_rec k tl t1) (trm_inst_rec k tl t2)
  | trm_cst c     => trm_cst c
  end.

Definition trm_inst t tl := trm_inst_rec 0 tl t.

(** Applying a constant *)

Definition const_app c vl := fold_left trm_app vl (trm_cst c).

(* ********************************************************************** *)
(** ** Description of typing *)

(** Definition of kinding environments *)

Definition kenv := env kind.

Definition kenv_ok K :=
  ok K /\ env_prop (All_kind_types type) K.

(** Proper instanciation *)

Inductive well_kinded : kenv -> kind -> typ -> Prop :=
  | wk_any : forall K T,
      well_kinded K None T
  | wk_kind : forall k' K k x,
      binds x (Some k') K ->
      entails k' k ->
      well_kinded K (Some k) (typ_fvar x).

Hint Constructors well_kinded : core.

Definition kinds_open Ks Us :=
  List.map (fun k:kind => kind_open k Us) Ks.

Definition proper_instance K Ks Us :=
  types (length Ks) Us /\
  list_forall2 (well_kinded K) (kinds_open Ks Us) Us.

Definition kinds_open_vars Ks Xs :=
  List.combine Xs (kinds_open Ks (typ_fvars Xs)).

(** Definition of typing environments *)

Definition env := env sch.

Definition env_ok (E:env) := ok E /\ env_prop scheme E.

(** Computing free variables of a type. *)

Fixpoint typ_fv (T : typ) {struct T} : vars :=
  match T with
  | typ_bvar i      => {}
  | typ_fvar x      => {{x}}
  | typ_arrow T1 T2 => (typ_fv T1) \u (typ_fv T2)
  end.

(** Computing free variables of a list of terms. *)

Definition typ_fv_list :=
  List.fold_right (fun t acc => typ_fv t \u acc) {}.

(** Computing free variables of a kind. *)

Definition kind_fv k :=
  typ_fv_list (kind_types k).

Definition kind_fv_list :=
  List.fold_right (fun t acc => kind_fv t \u acc) {}.

(** Computing free variables of a type scheme. *)

Definition sch_fv M :=
  typ_fv (sch_type M) \u kind_fv_list (sch_kinds M).

(** Computing free type variables of the values of an environment. *)

Definition env_fv :=
  fv_in sch_fv.

(** Grammar of values *)

Inductive valu : nat -> trm -> Prop :=
  | value_abs : forall t1, term (trm_abs t1) -> valu 0 (trm_abs t1)
  | value_cst : forall c, valu (Const.arity c) (trm_cst c)
  | value_app : forall n t1 n2 t2,
      valu (S n) t1 ->
      valu n2 t2 ->
      valu n (trm_app t1 t2).

Definition value t := exists n, valu n t.

(** Another functor for delta-rules *)

Module Type DeltaIntf.
  Parameter type : Const.const -> sch.
  Parameter closed : forall c, sch_fv (type c) = {}.
  Parameter scheme : forall c, scheme (type c).
  Parameter reduce : forall c tl,
    list_for_n value (S(Const.arity c)) tl -> trm.
  Parameter term : forall c tl vl,
    term (@reduce c tl vl).
End DeltaIntf.

Module MkJudge(Delta:DeltaIntf).

(** The typing judgment *)

Reserved Notation "K ; E | gc |= t ~: T" (at level 69).

Inductive gc_kind : Set := GcAny | GcLet.
Definition gc_info : Set := (bool * gc_kind)%type.
Fixpoint gc_ok (gc:gc_info) := fst gc = true.
Fixpoint gc_raise (gc:gc_info) : gc_info :=
  match snd gc with
  | GcLet => (true, GcLet)
  | _ => gc
  end.
Fixpoint gc_lower (gc:gc_info) : gc_info :=
  match snd gc with
  | GcLet => (false, GcLet)
  | _ => gc
  end.

Inductive typing(gc:gc_info) : kenv -> env -> trm -> typ -> Prop :=
  | typing_var : forall K E x M Us,
      kenv_ok K ->
      env_ok E ->
      binds x M E ->
      proper_instance K (sch_kinds M) Us ->
      K ; E | gc |= (trm_fvar x) ~: (M ^^ Us)
  | typing_abs : forall L K E U T t1,
      type U ->
      (forall x, x \notin L ->
        K ; (E & x ~ Sch U nil) | gc_raise gc |= (t1 ^ x) ~: T) ->
      K ; E | gc |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_let : forall M L1 L2 K E T2 t1 t2,
      (forall Xs, fresh L1 (sch_arity M) Xs ->
         (K & kinds_open_vars (sch_kinds M) Xs); E | gc_raise gc |=
           t1 ~: (M ^ Xs)) ->
      (forall x, x \notin L2 ->
         K ; (E & x ~ M) | gc_raise gc |= (t2 ^ x) ~: T2) ->
      K ; E | gc |= (trm_let t1 t2) ~: T2
  | typing_app : forall K E S T t1 t2,
      K ; E | gc_lower gc |= t1 ~: (typ_arrow S T) ->
      K ; E | gc_lower gc |= t2 ~: S ->
      K ; E | gc |= (trm_app t1 t2) ~: T
  | typing_cst : forall K E Us c,
      kenv_ok K ->
      env_ok E ->
      proper_instance K (sch_kinds (Delta.type c)) Us ->
      K ; E | gc |= (trm_cst c) ~: (Delta.type c ^^ Us)
  | typing_gc : forall Ks L K E t T,
      gc_ok gc ->
      (forall Xs, fresh L (length Ks) Xs ->
        K & kinds_open_vars Ks Xs; E | gc |= t ~: T) ->
      K ; E | gc |= t ~: T

where "K ; E | gc |= t ~: T" := (typing gc K E t T).

(* ********************************************************************** *)
(** ** Description of the semantics *)

(** Reduction rules *)

Inductive red : trm -> trm -> Prop :=
  | red_abs : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_let : forall t1 t2,
      term (trm_let t1 t2) ->
      value t1 ->
      red (trm_let t1 t2) (t2 ^^ t1)
  | red_delta : forall c tl vl,
      red (const_app c tl) (@Delta.reduce c tl vl)
  | red_let_1 : forall t1 t1' t2,
      term_body t2 ->
      red t1 t1' ->
      red (trm_let t1 t2) (trm_let t1' t2)
  | red_app_1 : forall t1 t1' t2,
      value t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      term t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2').

Notation "t --> t'" := (red t t') (at level 68).

(* ********************************************************************** *)
(** ** Description of the results *)

(** Goal is to prove preservation and progress *)

Definition preservation := forall K E t t' T,
  K ; E | (true,GcAny) |= t ~: T ->
  t --> t' ->
  K ; E | (true,GcAny) |= t' ~: T.

Definition progress := forall K t T,
  K ; empty | (true,GcAny) |= t ~: T ->
     value t
  \/ exists t', t --> t'.

End MkJudge.

End MkDefs.