Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.response_time prosa.classic.model.schedule.global.workload
               prosa.classic.model.schedule.global.schedulability.
Require Import prosa.classic.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq div fintype bigop path.

Module WorkloadBound.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask TaskArrival ResponseTime Schedulability Workload.

  Section WorkloadBoundDef.

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

    Variable tsk: sporadic_task.
    Variable R_tsk: time. (* Known response-time bound for the task *)
    Variable delta: time. (* Length of the interval *)

    (* Bound on the number of jobs that execute on the interval *)
    Definition max_jobs :=
      div_ceil (delta + R_tsk) (task_period tsk).

    (* Simplified workload bound for parallel jobs.*)
    Definition W := max_jobs * task_cost tsk.

  End WorkloadBoundDef.

  Section BasicLemmas.

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

    (* Let tsk be any task...*)
    Variable tsk: sporadic_task.

    (* ...with period > 0. *)
    Hypothesis H_period_positive: task_period tsk > 0.

    (* Let R1 <= R2 be two response-time bounds that
       are larger than the cost of the tsk. *)
    Variable R1 R2: time.
    Hypothesis H_R_lower_bound: R1 >= task_cost tsk.
    Hypothesis H_R1_le_R2: R1 <= R2.

    Let workload_bound := W task_cost task_period tsk.

    (* The workload bound W is monotonically increasing. *)
    Lemma W_monotonic :
      forall t1 t2,
        t1 <= t2 ->
        workload_bound R1 t1 <= workload_bound R2 t2.
    Proof.
      intros t1 t2 LEt.
      unfold workload_bound, W, max_jobs.
      rewrite leq_mul2r; apply/orP; right.
      by apply leq_divceil2r; last by apply leq_add.
    Qed.

  End BasicLemmas.

  Section ProofWorkloadBound.

    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_task: Job -> sporadic_task.
    Variable job_deadline: Job -> time.

    Variable arr_seq: arrival_sequence Job.

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

    (* Consider any schedule. *)
    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.

    (* Assumption: jobs only execute if they arrived.
       This is used to eliminate jobs that arrive after end of the interval t1 + delta. *)
    Hypothesis H_jobs_must_arrive_to_execute:
      jobs_must_arrive_to_execute job_arrival sched.

    (* Assumption: jobs do not execute after they completed.
       This is used to eliminate jobs that complete before the start of the interval t1. *)
    Hypothesis H_completed_jobs_dont_execute:
      completed_jobs_dont_execute job_cost sched.

    (* Assumption: sporadic task model.
       This is necessary to conclude that consecutive jobs ordered by arrival times
       are separated by at least 'period' times units. *)
    Hypothesis H_sporadic_tasks:
      sporadic_task_model task_period job_arrival job_task arr_seq.

    (* Before starting the proof, let's give simpler names to the definitions. *)
    Let job_has_completed_by := completed job_cost sched.

    Let workload_of (tsk: sporadic_task) (t1 t2: time) :=
      workload job_task sched tsk t1 t2.

    (* Now we define the theorem. Let tsk be any task in the taskset. *)
    Variable tsk: sporadic_task.

    (* Assumption: the task must have valid parameters:
         a) period > 0 (used in divisions)
         b) deadline of the jobs = deadline of the task
         c) cost <= period
            (used to prove that the distance between the first and last
             jobs is at least (cost + n*period), where n is the number
             of middle jobs. If cost >> period, the claim does not hold
             for every task set. *)
    Hypothesis H_valid_task_parameters:
      is_valid_sporadic_task task_cost task_period task_deadline tsk.

    (* Consider an interval [t1, t1 + delta). *)
    Variable t1 delta: time.

    (* Assume that any job with response-time bound R_tsk before
       t1 + delta indeed completes within the response-time bound. *)
    Variable R_tsk: time.

    Hypothesis H_response_time_bound :
      forall j,
        arrives_in arr_seq j ->
        job_task j = tsk ->
        job_arrival j + R_tsk < t1 + delta ->
        job_has_completed_by j (job_arrival j + R_tsk).

    Section MainProof.

      (* In this section, we prove that the workload of a task in the
         interval [t1, t1 + delta) is bounded by W. *)

      (* Let's simplify the names a bit. *)
      Let t2 := t1 + delta.
      Let n_k := max_jobs task_period tsk R_tsk delta.
      Let workload_bound := W task_cost task_period tsk R_tsk delta.

      (* Since we only care about the workload of tsk, we restrict
         our view to the set of jobs of tsk scheduled in [t1, t2). *)
      Let scheduled_jobs :=
        jobs_of_task_scheduled_between job_task sched tsk t1 t2.

      (* Now, let's consider the list of interfering jobs sorted by arrival time. *)
      Let earlier_arrival := fun x y => job_arrival x <= job_arrival y.
      Let sorted_jobs := (sort earlier_arrival scheduled_jobs).

      (* The first step consists in simplifying the sum corresponding
         to the workload. *)
      Section SimplifyJobSequence.

        (* After switching to the definition of workload based on a list
           of jobs, we show that sorting the list preserves the sum. *)
        Lemma workload_bound_simpl_by_sorting_scheduled_jobs :
          workload_joblist job_task sched tsk t1 t2 =
           \sum_(i <- sorted_jobs) service_during sched i t1 t2.
        Proof.
          unfold workload_joblist; fold scheduled_jobs.
          rewrite (perm_big sorted_jobs) /= //.
          by rewrite -(perm_sort earlier_arrival).
        Qed.

        (* Remember that both sequences have the same set of elements *)
        Lemma workload_bound_job_in_same_sequence :
          forall j,
            (j \in scheduled_jobs) = (j \in sorted_jobs).
        Proof.
          by apply perm_mem; rewrite -(perm_sort earlier_arrival).
        Qed.

        (* Remember that all jobs in the sorted sequence is an
           interfering job of task tsk. *)
        Lemma workload_bound_all_jobs_from_tsk :
          forall j_i,
            j_i \in sorted_jobs ->
            arrives_in arr_seq j_i /\
            job_task j_i = tsk /\
            service_during sched j_i t1 t2 != 0 /\
            j_i \in jobs_scheduled_between sched t1 t2.
        Proof.
          rename H_jobs_come_from_arrival_sequence into FROMarr.
          intros j_i LTi.
          rewrite -workload_bound_job_in_same_sequence mem_filter in LTi; des.
          unfold jobs_scheduled_between in *; rewrite mem_undup in LTi0.
          apply mem_bigcat_nat_exists in LTi0; des.
          rewrite mem_scheduled_jobs_eq_scheduled in LTi0.
          repeat split; try (by done); first by apply (FROMarr j_i i).
          {
            apply service_implies_cumulative_service with (t := i);
              first by apply/andP; split.
            by rewrite -not_scheduled_no_service negbK.
          }
          {
            rewrite mem_undup.
            apply mem_bigcat_nat with (j := i); first by auto.
            by rewrite mem_scheduled_jobs_eq_scheduled.
          }
        Qed.

        (* Remember that consecutive jobs are ordered by arrival. *)
        Lemma workload_bound_jobs_ordered_by_arrival :
          forall i elem,
            i < (size sorted_jobs).-1 ->
            earlier_arrival (nth elem sorted_jobs i) (nth elem sorted_jobs i.+1).
        Proof.
          intros i elem LT.
          assert (SORT: sorted earlier_arrival sorted_jobs).
            by apply sort_sorted; unfold total, earlier_arrival; ins; apply leq_total.
          by destruct sorted_jobs; simpl in *; [by rewrite ltn0 in LT | by apply/pathP].
        Qed.

      End SimplifyJobSequence.

      (* Next, we show that if the number of jobs is no larger than n_k,
         the workload bound trivially holds. *)
      Section WorkloadNotManyJobs.

        Lemma workload_bound_holds_for_at_most_n_k_jobs :
          size sorted_jobs <= n_k ->
          \sum_(i <- sorted_jobs) service_during sched i t1 t2 <=
            workload_bound.
        Proof.
          unfold workload_bound, W; intros LEnk.
          apply leq_trans with (n := \sum_(x <- sorted_jobs) task_cost tsk);
            last by rewrite big_const_seq iter_addn addn0 mulnC leq_mul2r; apply/orP; right.
          rewrite [\sum_(_ <- _) service_during _ _ _ _]big_seq_cond.
          rewrite [\sum_(_ <- _) task_cost _]big_seq_cond.
          apply leq_sum; intros j_i; move/andP => [INi _].
          apply workload_bound_all_jobs_from_tsk in INi; des.
          eapply cumulative_service_le_task_cost;
            [by apply H_completed_jobs_dont_execute | by apply INi0 |].
          by apply H_jobs_have_valid_parameters.
        Qed.

      End WorkloadNotManyJobs.

      (* Otherwise, assume that the number of jobs is larger than n_k >= 0.
         First, consider the simple case with only one job. *)
      Section WorkloadSingleJob.

        (* Assume that there's at least one job in the sorted list. *)
        Hypothesis H_at_least_one_job: size sorted_jobs > 0.

        Variable elem: Job.
        Let j_fst := nth elem sorted_jobs 0.

        (* The first job is an interfering job of task tsk. *)
        Lemma workload_bound_j_fst_is_job_of_tsk :
          arrives_in arr_seq j_fst /\
          job_task j_fst = tsk /\
          service_during sched j_fst t1 t2 != 0 /\
          j_fst \in jobs_scheduled_between sched t1 t2.
        Proof.
          by apply workload_bound_all_jobs_from_tsk, mem_nth.
        Qed.

        (* The workload bound holds for the single job. *)
        Lemma workload_bound_holds_for_a_single_job :
          \sum_(0 <= i < 1) service_during sched (nth elem sorted_jobs i) t1 t2 <=
          workload_bound.
        Proof.
          rename H_valid_task_parameters into PARAMS.
          unfold is_valid_sporadic_task in *.
          unfold workload_bound, W; fold n_k.
          have INfst := workload_bound_j_fst_is_job_of_tsk; des.
          rewrite big_nat_recr // big_geq // [nth]lock /= -lock add0n.
          apply leq_trans with (n := task_cost tsk).
          {
            eapply cumulative_service_le_task_cost; [by eauto 1 | by apply INfst0 |].
            by apply H_jobs_have_valid_parameters.
          }
          rewrite -{1}[task_cost tsk]mul1n leq_mul2r; apply/orP; right.
          apply ceil_neq0; last by apply PARAMS0.
          {
            apply leq_trans with (n := delta); last by apply leq_addr.
            rewrite lt0n; apply/eqP; intro EQ0.
            move: INfst1 => /eqP BUG; apply BUG.
            unfold t2; rewrite EQ0 addn0.
            by unfold service_during; rewrite big_geq.
          }
        Qed.

      End WorkloadSingleJob.

      (* Next, consider the last case where there are at least two jobs:
         the first job j_fst, and the last job j_lst. *)
      Section WorkloadTwoOrMoreJobs.

        (* There are at least two jobs. *)
        Variable num_mid_jobs: nat.
        Hypothesis H_at_least_two_jobs : size sorted_jobs = num_mid_jobs.+2.

        Variable elem: Job.
        Let j_fst := nth elem sorted_jobs 0.
        Let j_lst := nth elem sorted_jobs num_mid_jobs.+1.

        (* The last job is an interfering job of task tsk. *)
        Lemma workload_bound_j_lst_is_job_of_tsk :
          arrives_in arr_seq j_lst /\
          job_task j_lst = tsk /\
          service_during sched j_lst t1 t2 != 0 /\
          j_lst \in jobs_scheduled_between sched t1 t2.
        Proof.
          apply workload_bound_all_jobs_from_tsk, mem_nth.
          by rewrite H_at_least_two_jobs.
        Qed.

        (* The response time of the first job must fall inside the interval. *)
        Lemma workload_bound_response_time_of_first_job_inside_interval :
          t1 <= job_arrival j_fst + R_tsk.
        Proof.
          rewrite leqNgt; apply /negP; unfold not; intro LTt1.
          exploit workload_bound_all_jobs_from_tsk.
          {
            apply mem_nth; instantiate (1 := 0).
            apply ltn_trans with (n := 1); [by done | by rewrite H_at_least_two_jobs].
          }
          instantiate (1 := elem); move => [FSTarr [FSTtsk [/eqP FSTserv FSTin]]].
          apply FSTserv.
          apply (cumulative_service_after_job_rt_zero job_arrival job_cost) with (R := R_tsk);
            try (by done); last by apply ltnW.
          apply H_response_time_bound; try (by done).
          by apply leq_trans with (n := t1); last by apply leq_addr.
        Qed.

        (* The arrival of the last job must also fall inside the interval. *)
        Lemma workload_bound_last_job_arrives_before_end_of_interval :
          job_arrival j_lst < t2.
        Proof.
          rewrite leqNgt; apply/negP; unfold not; intro LT2.
          exploit workload_bound_all_jobs_from_tsk.
          {
            apply mem_nth; instantiate (1 := num_mid_jobs.+1).
            by rewrite -(ltn_add2r 1) addn1 H_at_least_two_jobs addn1.
          }
          instantiate (1 := elem); move => [LSTarr [LSTtsk [/eqP LSTserv LSTin]]].
          unfold service_during; apply LSTserv.
          by eapply cumulative_service_before_job_arrival_zero; eauto 1.
        Qed.

        (* Bound the service of the middle jobs. *)
        Lemma workload_bound_service_of_middle_jobs :
          \sum_(0 <= i < num_mid_jobs)
            service_during sched (nth elem sorted_jobs i.+1) t1 t2 <=
            num_mid_jobs * task_cost tsk.
        Proof.
          apply leq_trans with (n := num_mid_jobs * task_cost tsk);
            last by rewrite leq_mul2l; apply/orP; right.
          apply leq_trans with (n := \sum_(0 <= i < num_mid_jobs) task_cost tsk);
            last by rewrite big_const_nat iter_addn addn0 mulnC subn0.
          rewrite big_nat_cond [\sum_(0 <= i < num_mid_jobs) task_cost _]big_nat_cond.
          apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.
          exploit workload_bound_all_jobs_from_tsk.
          {
            instantiate (1 := nth elem sorted_jobs i.+1).
            apply mem_nth; rewrite H_at_least_two_jobs.
            by rewrite ltnS; apply leq_trans with (n := num_mid_jobs).
          }
          move => [ARR [TSK _]].
          eapply cumulative_service_le_task_cost; eauto 1.
          by apply H_jobs_have_valid_parameters.
        Qed.

        (* Conclude that the distance between first and last is at least num_mid_jobs + 1 periods. *)
        Lemma workload_bound_many_periods_in_between :
          job_arrival j_lst - job_arrival j_fst >= num_mid_jobs.+1 * (task_period tsk).
        Proof.
          assert (EQnk: num_mid_jobs.+1=(size sorted_jobs).-1).
            by rewrite H_at_least_two_jobs.
          unfold j_fst, j_lst; rewrite EQnk telescoping_sum;
            last by ins; apply workload_bound_jobs_ordered_by_arrival.
          rewrite -[_ * _ tsk]addn0 mulnC -iter_addn -{1}[_.-1]subn0 -big_const_nat.
          rewrite big_nat_cond [\sum_(0 <= i < _)(_-_)]big_nat_cond.
          apply leq_sum; intros i; rewrite andbT; move => /andP LT; des.

          (* To simplify, call the jobs 'cur' and 'next' *)
          set cur := nth elem sorted_jobs i.
          set next := nth elem sorted_jobs i.+1.

          (* Show that cur arrives earlier than next *)
          assert (ARRle: job_arrival cur <= job_arrival next).
            by unfold cur, next; apply workload_bound_jobs_ordered_by_arrival.

          feed (workload_bound_all_jobs_from_tsk cur).
            by apply mem_nth, (ltn_trans LT0); destruct sorted_jobs.
          intros [CURarr [CURtsk [_ CURin]]].

          feed (workload_bound_all_jobs_from_tsk next).
            by apply mem_nth; destruct sorted_jobs.
          intros [NEXTarr [NEXTtsk [_ NEXTin]]].

          (* Use the sporadic task model to conclude that cur and next are separated
             by at least (task_period tsk) units. Of course this only holds if cur != next.
             Since we don't know much about the list (except that it's sorted), we must
             also prove that it doesn't contain duplicates. *)
          assert (CUR_LE_NEXT: job_arrival cur + task_period (job_task cur) <= job_arrival next).
          {
            apply H_sporadic_tasks; try (by done).
            unfold cur, next, not; intro EQ; move: EQ => /eqP EQ.
            rewrite nth_uniq in EQ; first by move: EQ => /eqP EQ; intuition.
              by apply ltn_trans with (n := (size sorted_jobs).-1); destruct sorted_jobs; ins.
              by destruct sorted_jobs; ins.
              by rewrite sort_uniq -/scheduled_jobs filter_uniq // undup_uniq.
              by rewrite CURtsk.
          }
          by rewrite subh3 // addnC -CURtsk.
        Qed.

        (* Next, we prove that n_k covers every scheduled job, ... *)
        Lemma workload_bound_n_k_covers_all_jobs :
          n_k >= num_mid_jobs.+2.
        Proof.
          rename H_valid_task_parameters into PARAMS.
          unfold is_valid_sporadic_task in *; des.
          rewrite leqNgt; apply/negP; unfold not; intro LTnk.
          assert (DISTmax: job_arrival j_lst - job_arrival j_fst >= delta + R_tsk).
          {
            apply leq_trans with (n := num_mid_jobs.+1 * task_period tsk);
              last by apply workload_bound_many_periods_in_between.
            apply leq_trans with (n := n_k * task_period tsk);
              last by rewrite leq_mul2r; apply/orP; right.
            unfold n_k, max_jobs, div_ceil.
            destruct (task_period tsk %| delta + R_tsk) eqn:DIV.
            {
              rewrite dvdn_eq in DIV; move: DIV => /eqP DIV.
              by rewrite DIV.
            }
            by apply ltnW, ltn_ceil, PARAMS0.
          }
          rewrite <- leq_add2r with (p := job_arrival j_fst) in DISTmax.
          rewrite addnC subh1 in DISTmax; last first.
          {
            unfold j_fst, j_lst; rewrite -[_.+1]add0n.
            apply prev_le_next; last by rewrite H_at_least_two_jobs add0n leqnn.
            by ins; apply workload_bound_jobs_ordered_by_arrival.
          }
          rewrite -[job_arrival j_lst + _ - _]subnBA // subnn subn0 in DISTmax.
          rewrite [delta + _]addnC addnA in DISTmax.
          apply leq_trans with (m := t1 + delta) in DISTmax; last first.
          {
            rewrite leq_add2r.
            by apply workload_bound_response_time_of_first_job_inside_interval.
          }
          have LST := workload_bound_last_job_arrives_before_end_of_interval.
          by apply leq_ltn_trans with (m := t2) in LST; first by rewrite ltnn in LST.
        Qed.

        (* ... so the workload bound trivially holds. *)
        Lemma workload_bound_holds :
            \sum_(0 <= i < num_mid_jobs.+2)
             service_during sched (nth elem sorted_jobs i) t1 t2
          <= workload_bound.
        Proof.
          unfold workload_bound, W; fold n_k.
          have ALL := workload_bound_n_k_covers_all_jobs.
          apply leq_trans with (n := num_mid_jobs.+2 * task_cost tsk);
            last by rewrite leq_mul2r; apply/orP; right.
          apply leq_trans with (n := \sum_(0 <= i < num_mid_jobs.+2) task_cost tsk);
            last by rewrite big_const_nat iter_addn addn0 subn0 mulnC.
          rewrite big_nat_cond [\sum_(_ <= _ < _ | true)_]big_nat_cond.
          apply leq_sum; intro i; move => /andP [/andP [_ LEi] _].
          exploit workload_bound_all_jobs_from_tsk.
          {
            instantiate (1 := nth elem sorted_jobs i).
            by apply mem_nth; rewrite H_at_least_two_jobs.
          }
          move => [ARR [TSK _]].
          eapply cumulative_service_le_task_cost; eauto 1.
          by apply H_jobs_have_valid_parameters.
        Qed.

      End WorkloadTwoOrMoreJobs.

      (* Using the lemmas above, we prove the main theorem about the workload bound. *)
      Theorem workload_bounded_by_W :
        workload_of tsk t1 (t1 + delta) <= workload_bound.
      Proof.
        unfold workload_of, workload_bound, W in *; ins; des.
        fold n_k.

        (* Use the definition of workload based on list of jobs. *)
        rewrite workload_eq_workload_joblist.

        (* Now we order the list by job arrival time. *)
        rewrite workload_bound_simpl_by_sorting_scheduled_jobs.

        (* Next, we show that the workload bound holds if n_k
           is no larger than the number of interferings jobs. *)
        destruct (size sorted_jobs <= n_k) eqn:NUM;
          first by apply workload_bound_holds_for_at_most_n_k_jobs.
        apply negbT in NUM; rewrite -ltnNge in NUM.

        (* Find some dummy element to use in the nth function *)
        assert (EX: exists elem: Job, True).
          destruct sorted_jobs; [ by rewrite ltn0 in NUM | by exists s].
        destruct EX as [elem _].

        (* Now we index the sum to access the first and last elements. *)
        rewrite (big_nth elem).

        (* First, we show that the bound holds for an empty list of jobs. *)
        destruct (size sorted_jobs) as [| n] eqn:SIZE;
          first by rewrite big_geq.

        (* Then, we show the same for a singleton set of jobs. *)
        destruct n as [| num_mid_jobs];
          first by apply workload_bound_holds_for_a_single_job; rewrite SIZE.
        (* Since num_mid_jobs + 2 <= n_k >= num_mid_jobs + 2, the proof follows easily. *)
        by apply workload_bound_holds.
      Qed.

    End MainProof.

  End ProofWorkloadBound.

End WorkloadBound.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable rt_ : Universe -> Universe -> Prop.
Variable r_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable c_ : Universe.
Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ a_ /\ (dom_ b_ /\ (dom_ c_ /\ (rt_ a_ b_ /\ r_ a_ c_)))).
Variable goal_ax_2 : (forall X : Universe, ((dom_ X /\ (r_ b_ X /\ rt_ c_ X)) -> goal_)).
Variable r_in_rt_3 : (forall X Y : Universe, (r_ X Y -> rt_ X Y)).
Variable trans_rt_4 : (forall X Y Z : Universe, ((rt_ X Y /\ rt_ Y Z) -> rt_ X Z)).
Variable r_or_rr_5 : (forall X Y : Universe, (rt_ X Y -> (exists U : Universe, (r_ X Y \/ (dom_ U /\ (rt_ X U /\ rt_ U Y)))))).
Variable ih_cdp1_6 : (forall X Y : Universe, ((rt_ a_ X /\ (rt_ X b_ /\ r_ a_ Y)) -> (exists U : Universe, (dom_ U /\ (r_ X U /\ rt_ Y U))))).
Variable ih_cdp2_7 : (forall X Y : Universe, ((rt_ a_ X /\ (rt_ X b_ /\ r_ X Y)) -> (exists U : Universe, (dom_ U /\ (r_ b_ U /\ rt_ Y U))))).
Variable dp_r_8 : (forall X Y Z : Universe, ((r_ X Y /\ r_ X Z) -> (exists U : Universe, (dom_ U /\ (r_ Y U /\ r_ Z U))))).

Theorem cdp_9 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Rules.
Require Export Infra.
Require Export DoubleUnfolding.

Definition env_amber := list (atom * atom).

Fixpoint domA (E : env_amber) : atoms :=
  match E with
  | nil => {}
  | (X,Y)::E' => {{X}} \u {{Y}} \u domA E'
  end.

Inductive wfe_amber: env_amber -> Prop :=
| wfea_base:
    wfe_amber nil
| wfea_cons: forall X Y E,
    X \notin domA E ->
    Y \notin {{X}} \u domA E ->
    wfe_amber E ->
    wfe_amber ((X,Y)::E).

Inductive wf_amber: env_amber -> typ -> Prop :=
| wfa_nat: forall E,
    wfe_amber E ->
    wf_amber E typ_nat
| wfa_top: forall E,
    wfe_amber E ->
    wf_amber E typ_top
| wfa_fvarl: forall E X Y,
    In (X,Y) E ->
    wfe_amber E ->
    wf_amber E X
| wfa_fvarr: forall E X Y,
    In (X,Y) E ->
    wfe_amber E ->
    wf_amber E Y
| wfa_arrow: forall E A1 A2,
    wf_amber E A1 ->
    wf_amber E A2 ->
    wf_amber E (typ_arrow A1 A2)
| wfa_rec: forall E A L,
    (forall X Y,
        X \notin L -> Y \notin L \u {{X}} ->
        wf_amber (X ~ Y ++ E) (open_tt A X)) ->
    wf_amber E (typ_mu A).

Inductive sub_amber: env_amber -> typ -> typ -> Prop :=
| sam_nat: forall E,
    wfe_amber E ->
    sub_amber E typ_nat typ_nat
| sam_top: forall E A,
    wf_amber E A ->
    wfe_amber E ->
    sub_amber E A typ_top
| sam_fvar: forall E X Y,
    In (X, Y) E ->
    wfe_amber E ->
    sub_amber E (typ_fvar X) (typ_fvar Y)
| sam_arrow: forall E A1 A2 B1 B2,
    sub_amber E B1 A1 ->
    sub_amber E A2 B2 ->
    sub_amber E (typ_arrow A1 A2) (typ_arrow B1 B2)
| sam_rec: forall E A B L,
    (forall X Y,
        X \notin L -> Y \notin {{X}} \u L ->
        sub_amber ((X,Y)::E) (open_tt A X) (open_tt B Y)) ->
    sub_amber E (typ_mu A) (typ_mu B)
| sam_refl: forall E A,
    wfe_amber E ->
    wf_amber E (typ_mu A) ->
    sub_amber E (typ_mu A) (typ_mu A)
.

Inductive posvar: Mode -> atom -> typ -> typ -> Prop :=
| pos_nat: forall X m,
    posvar m X typ_nat typ_nat
| pos_top: forall X A m,
    type A ->
    posvar m X A typ_top
| pos_top_flip: forall X A m,
    type A ->
    posvar m X typ_top A
| pos_fvar_x: forall X,
    posvar Pos X (typ_fvar X) (typ_fvar X)
| pos_fvar_y: forall X Y m,
    X <> Y ->
    posvar m X (typ_fvar Y) (typ_fvar Y)
| pos_arrow: forall X m A1 A2 B1 B2,
    posvar (flip m) X B1 A1 ->
    posvar m X A2 B2 ->
    posvar m X (typ_arrow A1 A2) (typ_arrow B1 B2)
| pos_rec: forall X m A B L,
    (forall Y, Y \notin L \u {{X}} ->
               posvar m X (open_tt A Y) (open_tt B Y)) ->
     (forall Y, Y \notin L \u {{X}} ->
               posvar Pos Y (open_tt A Y) (open_tt B Y)) ->
    posvar m X (typ_mu A) (typ_mu B)
| pos_rec_t : forall A X m L,
    X \notin fv_tt A ->
    (forall Y, Y \notin L \u {{X}} ->
               type (open_tt A Y)) ->
    posvar m X (typ_mu A) (typ_mu A).

Inductive sub_amber2: env -> typ -> typ -> Prop :=
| sam2_nat: forall E,
    wf_env E ->
    sub_amber2 E typ_nat typ_nat
| sam2_top: forall E A,
    WFA E A ->
    wf_env E ->
    sub_amber2 E A typ_top
| sam2_fvar: forall E X ,
    binds X bind_sub E ->
    wf_env E ->
    sub_amber2 E (typ_fvar X) (typ_fvar X)
| sam2_arrow: forall E A1 A2 B1 B2,
    sub_amber2 E B1 A1 ->
    sub_amber2 E A2 B2 ->
    sub_amber2 E (typ_arrow A1 A2) (typ_arrow B1 B2)
| sam2_rec: forall E A B L,
    (forall X , X \notin L ->
                sub_amber2 (X ~ bind_sub ++ E) (open_tt A X) (open_tt B X)) ->
    (forall X , X \notin L ->
                posvar Pos X (typ_mu A) (typ_mu B)) ->
    sub_amber2 E (typ_mu A) (typ_mu B)
.

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let C := gather_atoms_with (fun x : list (var * typ) => dom x) in
  let D := gather_atoms_with (fun x : exp => fv_exp x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  let G := gather_atoms_with (fun x : env_amber => domA x) in
  constr:(A `union` B `union`  E \u C \u D \u F \u G).

Hint Constructors wfe_amber wf_amber sub_amber sub_amber2 posvar  : core.

Lemma in_domA_1: forall X Y E,
    In (X, Y) E -> X \in domA E.
Proof with auto.
  intros.
  induction E...
  inversion H...
  destruct a.
  inversion H.
  inversion H0.
  subst.
  simpl...
  apply IHE in H0.
  simpl...
Qed.

Lemma in_domA_2: forall X Y E,
    In (X, Y) E -> Y \in domA E.
Proof with auto.
  intros.
  induction E...
  inversion H...
  destruct a.
  inversion H.
  inversion H0.
  subst.
  simpl...
  apply IHE in H0.
  simpl...
Qed.

Lemma notin_domA: forall E1 E2 X,
    X \notin domA (E1 ++ E2) -> X \notin domA E1 /\ X \notin domA E2.
Proof with auto.
  induction E1...
  intros.
  rewrite_alist (a :: (E1 ++ E2)) in H.
  destruct a.
  simpl in *...
  apply notin_union in H.
  destruct H.
  apply notin_union in H0.
  destruct H0.
  apply IHE1 in H1.
  destruct H1...
Qed.

Lemma wfe_amber_div: forall E1 E2,
    wfe_amber (E1 ++ E2) -> wfe_amber E1 /\ wfe_amber E2.
Proof with auto.
  induction E1...
  intros.
  rewrite_alist (a :: (E1 ++ E2)) in H.
  dependent destruction H.
  apply IHE1 in H1.
  destruct H1...
  split...
  apply notin_domA in H.
  constructor...
  apply notin_union in H0.
  destruct H0.
  apply notin_domA in H3...
Qed.

Lemma wf_amber_comm: forall X Y A E1 E2,
    wf_amber (E1 ++ [(X, Y)] ++ E2) A -> wf_amber (E1 ++ [(X, Y)] ++ E2) (subst_tt X Y A).
Proof with auto.
  intros.
  dependent induction H;simpl...
  -
    destruct (X0==X)...
    subst.
    apply wfa_fvarr with (X:=X)...
    apply In_lemmaR...
    apply in_eq...
    apply in_app_iff in H.
    destruct H.
    apply wfa_fvarl with (Y:=Y0)...
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    inversion H...
    inversion H1;subst...
    destruct n...
    inversion H1...
    apply wfa_fvarl with (Y:=Y0)...
    rewrite_alist ((E1 ++ [(X, Y)]) ++ E2).
    apply In_lemmaR...
  -
    destruct (Y0==X)...
    subst.
    apply wfa_fvarr with (X:=X)...
    apply In_lemmaR...
    apply in_eq...
    apply in_app_iff in H.
    destruct H.
    apply wfa_fvarr with (X:=X0)...
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    apply wfa_fvarr with (X:=X0)...
    inversion H...
    inversion H1;subst...
    apply In_lemmaR...
    apply in_eq...
    inversion H1...
    apply wfa_fvarr with (X:=X0)...
    rewrite_alist ((E1 ++ [(X, Y)]) ++ E2).
    apply In_lemmaR...
  -
    constructor...
    apply IHwf_amber1...
    apply IHwf_amber2...
  -
    apply wfa_rec with (L:=L \u {{X}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_alist (([(X0, Y0)] ++ E1) ++ [(X, Y)] ++ E2)...
    eapply H0...
Qed.

Lemma wf_amber_comm2: forall X Y A E1 E2,
    wf_amber (E1 ++ [(X, Y)] ++ E2) A -> wf_amber (E1 ++ [(X, Y)] ++ E2) (subst_tt Y X A).
Proof with auto.
  intros.
  dependent induction H;simpl...
  -
    destruct (X0==Y)...
    subst.
    apply wfa_fvarl with (Y:=Y)...
    apply In_lemmaR...
    apply in_eq...
    apply in_app_iff in H.
    destruct H.
    apply wfa_fvarl with (Y:=Y0)...
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    inversion H...
    inversion H1;subst...
    apply wfa_fvarl with (Y:=Y0)...
    apply In_lemmaR.
    apply in_eq...
    inversion H1...
    apply wfa_fvarl with (Y:=Y0)...
    rewrite_alist ((E1 ++ [(X, Y)]) ++ E2).
    apply In_lemmaR...
  -
    destruct (Y0==Y)...
    subst.
    apply wfa_fvarl with (Y:=Y)...
    apply In_lemmaR...
    apply in_eq...
    apply in_app_iff in H.
    destruct H.
    apply wfa_fvarr with (X:=X0)...
    apply In_lemmaL...
    apply in_app_iff in H.
    destruct H.
    inversion H...
    inversion H1;subst...
    destruct n...
    inversion H1...
    apply wfa_fvarr with (X:=X0)...
    rewrite_alist ((E1 ++ [(X, Y)]) ++ E2).
    apply In_lemmaR...
  -
    constructor...
    apply IHwf_amber1...
    apply IHwf_amber2...
  -
    apply wfa_rec with (L:=L \u {{Y}})...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite_alist (([(X0, Y0)] ++ E1) ++ [(X, Y)] ++ E2)...
    eapply H0...
Qed.

Lemma sam_regular : forall E A B,
    sub_amber E A B -> wfe_amber E /\ wf_amber E A /\ wf_amber E B.
Proof with eauto.
  intros.
  induction H...
  -
    destruct IHsub_amber1.
    destruct H2.
    destruct IHsub_amber2.
    destruct H5.
    repeat split;auto...
  -
    split.
    pick fresh X.
    pick fresh Y.
    assert (X \notin L) by auto.
    assert (Y `notin` union (singleton X) L ) by auto.
    specialize (H0 X Y H1 H2).
    destruct H0.
    inversion H0...
    split;apply wfa_rec with (L:=L \u fv_tt B);intros.
    eapply H0...
    rewrite subst_tt_intro with (X:=Y)...
    rewrite_alist (nil ++ [(X, Y)] ++ E).
    apply wf_amber_comm2...
    eapply H0...
Qed.

Lemma suba2_regular : forall E A B,
    sub_amber2 E A B -> wf_env E /\ WFA E A /\ WFA E B.
Proof with eauto.
  intros.
  induction H...
  -
    destruct IHsub_amber2_1.
    destruct H2.
    destruct IHsub_amber2_2.
    destruct H5.
    repeat split...
  -
    split.
    pick fresh X.
    assert (X \notin L) by auto.
    specialize (H0 X  H2).
    destruct H0...
    inversion H0...
    split;apply WFA_rec with (L:=L \u fv_tt A \u fv_tt B);intros;eapply H0...
Qed.

Fixpoint env_trans (E : env_amber) : env :=
  match E with
  | nil => nil
  | (X,Y)::E' => X ~ bind_sub ++  env_trans E'
  end.

Fixpoint rename_env (E : env_amber) (A : typ) : typ :=
  match E with
  | nil => A
  | cons (X,Y) E' => subst_tt Y (typ_fvar X) (rename_env E' A)
  end.

Lemma rename_top : forall E, rename_env E typ_top = typ_top.
  induction E; simpl in *; eauto.
  destruct a.
  rewrite IHE.
  simpl in *; eauto.
Defined.

Lemma rename_nat : forall E, rename_env E typ_nat = typ_nat.
  induction E; simpl in *; eauto.
  destruct a.
  rewrite IHE.
  simpl in *; eauto.
Defined.

Lemma wfe_rename_fix:forall E Y,
    Y \notin domA E -> rename_env E Y = Y.
Proof with auto.
  intros.
  induction E...
  destruct a.
  simpl.
  rewrite_alist ([(a,a0)] ++ E) in H.
  apply notin_domA in H.
  destruct H...
  apply IHE in H0.
  rewrite H0.
  simpl in H...
  rewrite <- subst_tt_fresh...
Qed.

Lemma rename_fvar : forall E X Y,
    wfe_amber E ->
    In (X, Y) E -> rename_env E (typ_fvar Y) = typ_fvar X.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0.
  rewrite H0 in H.
  generalize dependent E.
  induction x;intros...
  -
    simpl in *...
    inversion H;subst.
    rewrite wfe_rename_fix with (E:=x0)...
    simpl...
    destruct (Y==Y)...
    destruct n...
  -
    simpl in *...
    destruct a.
    rewrite_alist ((a, a0) :: (x ++ (X, Y) :: x0)) in H.
    inversion H;subst.
    assert (x ++ (X, Y) :: x0 = x ++ (X, Y) :: x0) by auto.
    specialize (IHx H6 (x ++ (X, Y) :: x0) H0).
    clear H0.
    rewrite IHx.
    rewrite <- subst_tt_fresh...
    simpl in *...
    apply notin_union in H5.
    destruct H5.
    apply notin_domA in H1.
    destruct H1.
    simpl in H2...
Qed.

Lemma rename_fvar2 : forall E X Y,
    wfe_amber E ->
    In (X, Y) E -> rename_env E (typ_fvar X) = typ_fvar X.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0.
  rewrite H0 in H.
  generalize dependent E.
  induction x;intros...
  -
    simpl in *...
    inversion H;subst.
    rewrite wfe_rename_fix with (E:=x0)...
    simpl...
    destruct (X==Y)...
  -
    simpl in *...
    destruct a.
    rewrite_alist ((a, a0) :: (x ++ (X, Y) :: x0)) in H.
    inversion H;subst.
    assert (x ++ (X, Y) :: x0 = x ++ (X, Y) :: x0) by auto.
    specialize (IHx H6 (x ++ (X, Y) :: x0) H0).
    clear H0.
    rewrite IHx.
    rewrite <- subst_tt_fresh...
    simpl in *...
    apply notin_union in H5.
    destruct H5.
    apply notin_domA in H1.
    destruct H1.
    simpl in H2...
Qed.

Lemma rename_arrow : forall E A B, rename_env E (typ_arrow A B) = typ_arrow (rename_env E A) (rename_env E B).
  induction E; simpl in *; intros; eauto.
  destruct a.
  rewrite IHE.
  simpl in *; eauto.
Defined.

Lemma rename_mu : forall E A, rename_env E (typ_mu A) = typ_mu (rename_env E A).
  induction E; simpl in *; intros; eauto.
  destruct a.
  rewrite IHE.
  simpl in *; eauto.
Defined.

Lemma domA_X_neq_Y: forall E X Y,
    wfe_amber E -> In (X, Y) E -> X <> Y.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0 in H.
  apply wfe_amber_div in H.
  destruct H.
  dependent destruction H1...
Qed.

Lemma rename_bvar : forall E n, rename_env E (typ_bvar n) = typ_bvar n.
  induction E; simpl in *; intros; eauto.
  destruct a.
  rewrite IHE.
  simpl in *; eauto.
Defined.

Lemma subst_tt_open_tt_var2 : forall (X Y:atom) P T k,
  Y <> X ->
  type P ->
  open_tt_rec k Y (subst_tt X P T) = subst_tt X P (open_tt_rec k Y T).
Proof with congruence || auto.
  intros X Y P T k Neq Wu.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma rename_open: forall E A X,
    X \notin domA E ->
    rename_env E (open_tt A X) = open_tt (rename_env E A) X.
Proof with auto.
  intros.
  unfold open_tt.
  generalize 0.
  induction A;intros;simpl...
  -
    rewrite rename_top...
  -
    rewrite rename_nat...
  -
    destruct (n0==n)...
    subst.
    rewrite rename_bvar...
    simpl...
    destruct (n==n)...
    rewrite wfe_rename_fix...
    destruct n0...
    rewrite rename_bvar...
    simpl...
    destruct (n0==n)...
    destruct n1...
  -
    induction E...
    rewrite_alist ([(a0)] ++ E) in H.
    apply notin_domA in H.
    destruct H.
    apply IHE in H0.
    simpl...
    destruct a0.
    rewrite subst_tt_open_tt_var2...
    f_equal...
    simpl in H...
  -
    rewrite rename_mu...
    rewrite IHA with (n:=S n)...
    rewrite rename_mu...
  -
    rewrite rename_arrow...
    rewrite IHA1 with (n:=n)...
    rewrite IHA2 with (n:=n)...
    rewrite rename_arrow...
Qed.

Lemma rename_subst: forall E (X Y:atom) A,
    X \notin domA E \u fv_tt (rename_env E A)->
    Y \notin domA E ->
    (subst_tt X Y (rename_env E (open_tt A X))) = rename_env E (open_tt A Y).
Proof with auto.
  intros.
  rewrite rename_open...
  rewrite <- subst_tt_intro...
  rewrite rename_open...
Qed.

Lemma notin_fv_domA: forall E A X,
    X \notin domA E ->
    X \notin fv_tt A ->
    X \notin fv_tt (rename_env E A).
Proof with auto.
  intros.
  induction E...
  simpl...
  destruct a.
  rewrite_alist ([(a, a0)] ++ E) in H.
  apply notin_domA in H.
  destruct H.
  simpl in H...
  apply notin_fv_subst...
Qed.

Lemma domA_neq_mutual_aux: forall E1 X Y S T E2 E3,
    wfe_amber (E1 ++ [(X,Y)] ++ E2 ++ [(S,T)] ++ E3) ->
    Y <> S /\ X <> T /\ X <> S /\ Y <> T.
Proof with auto.
  induction E1;intros...
  -
    simpl in H.
    dependent destruction H.
    apply notin_union in H0.
    destruct H0.
    apply notin_domA in H2.
    destruct H2.
    apply notin_domA in H.
    destruct H.
    simpl in *...
  -
    rewrite_alist ([a] ++ (E1 ++ [(X, Y)] ++ E2 ++ [(S, T)] ++ E3)) in H.
    apply wfe_amber_div in H.
    destruct H...
    eapply IHE1...
    eassumption...
Qed.

Lemma domA_neq_mutual: forall X Y S T E,
    wfe_amber E ->
    In (X, Y) E ->
    In (S, T) E ->
    X <> S ->
    S <> Y.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0 in H1.
  rewrite H0 in H.
  apply in_app_iff in H1.
  destruct H1.
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x1 ++ [(S, T)] ++ x2 ++ [(X, Y)] ++ x0) in H.
  apply domA_neq_mutual_aux in H...
  apply in_inv in H1.
  destruct H1.
  inversion H1...
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x ++ [(X, Y)] ++ x1 ++ [(S, T)] ++ x2) in H.
  apply domA_neq_mutual_aux in H...
  destruct H...
Qed.

Lemma domA_neq_mutual1: forall X Y S T E,
    wfe_amber E ->
    In (X, Y) E ->
    In (S, T) E ->
    Y <> T ->
    X <> S.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0 in H1.
  rewrite H0 in H.
  apply in_app_iff in H1.
  destruct H1.
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x1 ++ [(S, T)] ++ x2 ++ [(X, Y)] ++ x0) in H.
  apply domA_neq_mutual_aux in H...
  destruct H.
  destruct H3.
  destruct H4...
  apply in_inv in H1.
  destruct H1.
  inversion H1...
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x ++ [(X, Y)] ++ x1 ++ [(S, T)] ++ x2) in H.
  apply domA_neq_mutual_aux in H...
Qed.

Lemma domA_neq_mutual2: forall X Y S T E,
    wfe_amber E ->
    In (X, Y) E ->
    In (S, T) E ->
    X <> S ->
    T <> Y.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0 in H1.
  rewrite H0 in H.
  apply in_app_iff in H1.
  destruct H1.
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x1 ++ [(S, T)] ++ x2 ++ [(X, Y)] ++ x0) in H.
  apply domA_neq_mutual_aux in H...
  apply in_inv in H1.
  destruct H1.
  inversion H1...
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x ++ [(X, Y)] ++ x1 ++ [(S, T)] ++ x2) in H.
  apply domA_neq_mutual_aux in H...
  destruct H...
  destruct H3.
  destruct H4...
Qed.

Lemma notin_subst_Y:forall A Y B,
    Y \notin fv_tt B  ->
    Y \notin fv_tt (subst_tt Y B A).
Proof with auto.
  induction A...
  intros.
  simpl.
  destruct (a==Y)...
Qed.

Lemma raname_notin_Y: forall E X Y A,
    wfe_amber E ->
    In (X,Y) E ->
    Y \notin fv_tt (rename_env E A).
Proof with auto.
  induction E...
  intros.
  destruct a.
  rewrite_alist ([(a, a0)] ++ E) in H0.
  apply in_app_iff in H0.
  dependent destruction H.
  destruct H2...
  -
    inversion H2...
    inversion H3;subst...
    simpl.
    apply notin_subst_Y...
  -
    simpl.
    apply notin_fv_subst...
    apply in_domA_2 in H2.
    assert (Y <> a).
    apply in_notin with (T:=domA E)...
    simpl...
    apply IHE with (X:=X)...
    apply in_domA_2 in H2.
    apply in_notin with (T:=domA E)...
Qed.

Lemma domA_neq_mutual_false: forall E1 X Y Z E2 E3,
    wfe_amber (E1 ++ [(X,Y)] ++ E2 ++ [(X,Z)] ++ E3) -> False.
Proof with auto.
  induction E1;intros...
  -
    simpl in H.
    dependent destruction H.
    apply notin_domA in H.
    destruct H.
    simpl in H2...
  -
    rewrite_alist ([a] ++ (E1 ++ [(X, Y)] ++ E2 ++ [(X, Z)] ++ E3)) in H.
    apply wfe_amber_div in H.
    destruct H...
    eapply IHE1...
    eassumption...
Qed.

Lemma domA_neq_mutual3: forall X Y Z E,
    wfe_amber E ->
    In (X, Y) E ->
    In (X, Z) E ->
    Y = Z.
Proof with auto.
  intros.
  apply in_split in H0.
  destruct H0.
  destruct H0.
  rewrite H0 in H1.
  rewrite H0 in H.
  apply in_app_iff in H1.
  destruct H1.
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x1 ++ [(X, Z)] ++ x2 ++ [(X, Y)] ++ x0) in H.
  apply domA_neq_mutual_false in H...
  destruct H.
  apply in_inv in H1.
  destruct H1.
  inversion H1...
  apply in_split in H1.
  destruct H1.
  destruct H1.
  rewrite H1 in H.
  rewrite_alist (x ++ [(X, Y)] ++ x1 ++ [(X, Z)] ++ x2) in H.
  apply domA_neq_mutual_false in H...
  destruct H...
Qed.

Lemma notin_env_trans: forall E X,
    X \notin domA E ->
    X \notin dom (env_trans E).
Proof with auto.
  induction E...
  intros.
  destruct a.
  simpl in *...
Qed.

Lemma env_trans_wfe: forall E,
    wfe_amber E ->
    wf_env (env_trans E).
Proof with auto.
  induction E...
  intros.
  destruct a.
  simpl.
  dependent destruction H.
  constructor...
  apply notin_env_trans...
Qed.

Lemma fvar_in_env_trans_X: forall E X Y,
    In (X, Y) E ->
    In (X,bind_sub) (env_trans E).
Proof with auto.
  induction E...
  intros.
  destruct a.
  simpl in *...
  destruct H...
  inversion H;subst...
  right...
  apply IHE with (Y:=Y)...
Qed.

Lemma wf_amber_to_WF: forall E A,
    wf_amber E A ->
    WFA (env_trans E) (rename_env E A).
Proof with auto.
  intros.
  induction H...
  -
    rewrite rename_nat...
  -
    rewrite rename_top...
  -
    rewrite rename_fvar2 with (Y:=Y)...
    constructor...
    apply fvar_in_env_trans_X in H...
  -
    rewrite rename_fvar with (X:=X)...
    constructor...
    apply fvar_in_env_trans_X in H...
  -
    rewrite rename_arrow...
  -
    rewrite rename_mu...
    apply WFA_rec with (L:=L \u fv_tt A \u domA E)...
    intros.
    pick fresh Y.
    assert (X \notin L) by auto.
    assert (Y \notin L \u {{X}}) by auto.
    specialize (H0 _ _ H2 H3).
    simpl in H0.
    rewrite <- subst_tt_fresh in H0...
    rewrite rename_open in H0...
    apply notin_fv_domA...
    apply notin_fv_tt_open_aux...
Qed.

Lemma posvar_self_notin: forall A m X ,
    type A ->
    X \notin fv_tt A ->
    posvar m X A A.
Proof with auto.
  intros.
  generalize dependent m.
  induction H;intros...
  -
    simpl in H0.
    constructor...
  -
    simpl in H0.
    apply notin_union in H0.
    destruct H0.
    constructor...
  -
    simpl in *.
    apply pos_rec_t with (L:=L \u fv_tt T)...
Qed.

Lemma rename_env_open: forall A X Y,
    X <> Y ->
    X `notin` fv_tt (open_tt A Y) ->
    X \notin fv_tt A.
Proof with eauto.
  unfold open_tt.
  intros A.
  generalize 0.
  induction A;intros;simpl in *...
Qed.

Lemma rename_notin_X: forall E X Y A,
    wfe_amber E ->
    In (X,Y) E ->
    wf_amber E A ->
    Y \notin fv_tt A ->
    X \notin fv_tt A ->
    X \notin fv_tt (rename_env E A).
Proof with auto.
  intros.
  induction H1...
  -
    rewrite rename_nat...
  -
    rewrite rename_top...
  -
    rewrite rename_fvar2 with (Y:=Y0)...
  -
    rewrite rename_fvar with (X:=X0)...
    simpl in *.
    apply notin_singleton_2.
    eapply domA_neq_mutual1...
    eassumption.
    eassumption.
    eassumption.
  -
    rewrite rename_arrow...
    simpl in *.
    apply notin_union in H2.
    apply notin_union in H3.
    destruct H2.
    destruct H3.
    apply notin_union...
  -
    rewrite rename_mu...
    simpl in *.
    pick fresh X0.
    pick fresh Y0.
    assert (X0 \notin L) by auto.
    assert (Y0 \notin L \u {{X0}}) by auto.
    assert (wfe_amber ((X0, Y0) :: E)).
    constructor...
    assert ((X0, Y0) = (X, Y) \/ In (X, Y) E ).
    right...
    assert (Y `notin` fv_tt (open_tt A X0)).
    apply notin_fv_tt_open_aux...
    assert (X `notin` fv_tt (open_tt A X0)).
    apply notin_fv_tt_open_aux...
    specialize (H4 _ _ H5 H6 H7 H8 H9 H10).
    rewrite <- subst_tt_fresh in H4...
    rewrite rename_open in H4.
    apply rename_env_open with (Y:=X0)...
    auto.
    apply notin_fv_domA...
    apply notin_fv_tt_open_aux...
Qed.

Lemma sub_amber_to_posvar_aux: forall E A B,
    sub_amber E A B ->
    forall X Y ,
    In (X,Y) E ->
      (
        Y \notin fv_tt A ->
        X \notin fv_tt B ->
        posvar  Pos X (rename_env E A) (rename_env E B)
       )  /\ (
        X \notin fv_tt A ->
        Y \notin fv_tt B ->
        posvar  Neg X (rename_env E A) (rename_env E B)
      ).
Proof with auto.
  intros E A B H.
  dependent induction H;intros...
  -
    split;intros.
    rewrite rename_nat...
    rewrite rename_nat...
  -
    split;intros.
    rewrite rename_top...
    constructor...
    apply wf_amber_to_WF in H.
    apply soundness_wfa in H.
    apply wfs_type in H...
    rewrite rename_top...
    constructor...
    apply wf_amber_to_WF in H.
    apply soundness_wfa in H.
    apply wfs_type in H...
  -
    split;intros.
    +
      assert (rename_env E X = X).
      eapply rename_fvar2...
      eassumption.
      rewrite H4.
      assert (rename_env E Y = X).
      eapply rename_fvar...
      rewrite H5.
      simpl in H2...
      destruct (X0==X).
      subst...
      constructor...
    +
      assert (rename_env E X = X).
      eapply rename_fvar2...
      eassumption.
      rewrite H4.
      assert (rename_env E Y = X).
      eapply rename_fvar...
      rewrite H5.
      simpl in H2...
  -
    split;intros.
    simpl in *.
    rewrite rename_arrow...
    rewrite rename_arrow...
    constructor...
    simpl.
    eapply IHsub_amber1...
    assumption.
    eapply IHsub_amber2...
    assumption.
    simpl in *.
    rewrite rename_arrow...
    rewrite rename_arrow...
    constructor...
    simpl.
    eapply IHsub_amber1...
    assumption.
    eapply IHsub_amber2...
    assumption.
  -
    split;intros.
    +
      rewrite rename_mu...
      rewrite rename_mu...
      simpl in H2.
      simpl in H3.
      apply pos_rec with (L:=L \u {{X}} \u {{Y}} \u domA E \u fv_tt A \u fv_tt B)...
      *
        intros.
        pick fresh X0.
        assert (Y0 \notin L) by auto.
        assert (X0 `notin` union (singleton Y0) L) by auto.
        specialize (H0 _ _ H5 H6).
        assert (In (X, Y) ((Y0, X0) :: E)).
        {
          rewrite_alist ([(Y0, X0)] ++ E).
          apply In_lemmaR...
        }
        assert (Y `notin` fv_tt (open_tt A Y0)).
        {
          apply notin_fv_tt_open_aux...
        }
        assert (X `notin` fv_tt (open_tt B X0)).
        {
          apply notin_fv_tt_open_aux...
        }
        specialize (H0 _ _ H7).
        destruct H0.
        specialize (H0 H8 H9).
        simpl in H0.
        rewrite <- subst_tt_fresh in H0...
        rewrite <- rename_open...
        rewrite rename_subst in H0...
        rewrite <- rename_open...
        apply notin_union...
        split...
        apply notin_fv_domA...
        apply notin_fv_domA...
        apply notin_fv_tt_open_aux...
      *
        intros.
        pick fresh X0.
        assert (Y0 \notin L) by auto.
        assert (X0 `notin` union (singleton Y0) L) by auto.
        specialize (H0 _ _ H5 H6).
        assert (In (Y0, X0) ((Y0, X0) :: E)).
        {
          apply in_eq...
        }
        specialize (H0 _ _ H7).
        assert (X0 `notin` fv_tt (open_tt A Y0)).
        {
          apply notin_fv_tt_open_aux...
        }
        assert (Y0 `notin` fv_tt (open_tt B X0)).
        {
          apply notin_fv_tt_open_aux...
        }
        destruct H0.
        specialize (H0 H8 H9).
        simpl in H0.
        rewrite <- subst_tt_fresh in H0...
        rewrite <- rename_open...
        rewrite rename_subst in H0...
        rewrite <- rename_open...
        apply notin_union...
        split...
        apply notin_fv_domA...
        apply notin_fv_domA...
    +
      rewrite rename_mu...
      rewrite rename_mu...
      simpl in H2.
      simpl in H3.
      apply pos_rec with (L:=L \u {{X}} \u {{Y}} \u domA E \u fv_tt A \u fv_tt B)...
      *
        intros.
        pick fresh X0.
        assert (Y0 \notin L) by auto.
        assert (X0 `notin` union (singleton Y0) L) by auto.
        specialize (H0 _ _ H5 H6).
        assert (In (X, Y) ((Y0, X0) :: E)).
        {
          rewrite_alist ([(Y0, X0)] ++ E).
          apply In_lemmaR...
        }
        assert (X `notin` fv_tt (open_tt A Y0)).
        {
          apply notin_fv_tt_open_aux...
        }
        assert (Y `notin` fv_tt (open_tt B X0)).
        {
          apply notin_fv_tt_open_aux...
        }
        specialize (H0 _ _ H7).
        destruct H0.
        specialize (H10 H8 H9).
        simpl in H10.
        rewrite <- subst_tt_fresh in H10...
        rewrite <- rename_open...
        rewrite rename_subst in H10...
        rewrite <- rename_open...
        apply notin_union...
        split...
        apply notin_fv_domA...
        apply notin_fv_domA...
        apply notin_fv_tt_open_aux...
      *
        intros.
        pick fresh X0.
        assert (Y0 \notin L) by auto.
        assert (X0 `notin` union (singleton Y0) L) by auto.
        specialize (H0 _ _ H5 H6).
        assert (In (Y0, X0) ((Y0, X0) :: E)).
        {
          apply in_eq...
        }
        specialize (H0 _ _ H7).
        assert (X0 `notin` fv_tt (open_tt A Y0)).
        {
          apply notin_fv_tt_open_aux...
        }
        assert (Y0 `notin` fv_tt (open_tt B X0)).
        {
          apply notin_fv_tt_open_aux...
        }
        destruct H0.
        specialize (H0 H8 H9).
        simpl in H0.
        rewrite <- subst_tt_fresh in H0...
        rewrite <- rename_open...
        rewrite rename_subst in H0...
        rewrite <- rename_open...
        apply notin_union...
        split...
        apply notin_fv_domA...
        apply notin_fv_domA...
  -
    split;intros.
    apply posvar_self_notin...
    apply wf_amber_to_WF in H0...
    apply soundness_wfa in H0.
    apply wfs_type in H0...
    apply rename_notin_X with (Y:=Y)...
    simpl in *.
    apply posvar_self_notin...
    apply wf_amber_to_WF in H0...
    apply soundness_wfa in H0.
    apply wfs_type in H0...
    apply rename_notin_X with (Y:=Y)...
Qed.

Lemma posvar_regular: forall m X A B,
    posvar m X A B ->
    type A /\ type B.
Proof with auto.
  intros.
  induction H...
  -
    destruct IHposvar1.
    destruct IHposvar2...
  -
    split.
    apply type_mu with (L:=L \u {{X}})...
    intros.
    eapply H0...
    apply type_mu with (L:=L \u {{X}})...
    intros.
    eapply H0...
  -
    split.
    apply type_mu with (L:=L \u {{X}})...
    apply type_mu with (L:=L \u {{X}})...
Qed.

Lemma pos_rename_fix : forall X Y Z A B m,
    posvar m X A B ->
    X \notin {{Y}} \u {{Z}} ->
    posvar m X (subst_tt Y Z A) (subst_tt Y Z B).
Proof with auto.
  intros.
  induction H...
  -
    simpl in *...
    destruct (X==Y)...
    constructor...
    apply subst_tt_type...
    constructor...
    apply subst_tt_type...
  -
    simpl in *.
    constructor...
    apply subst_tt_type...
  -
    simpl.
    destruct (X==Y)...
  -
    simpl in *...
    destruct (Y0==Y)...
  -
    simpl in *...
  -
    simpl in *...
    apply pos_rec with (L:=L \u {{Y}} \u {{X}} \u {{Z}}).
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
  -
    simpl in *.
    apply pos_rec_t with (L:=L \u {{X}} \u {{Y}}).
    apply notin_fv_subst...
    intros.
    rewrite subst_tt_open_tt_var...
    apply subst_tt_type...
Qed.

Lemma pos_rename_1: forall X m A B Y,
    posvar m X A B ->
    Y \notin {{X}} \u fv_tt A \u fv_tt B ->
    posvar m Y (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  induction H;intros...
  -
    constructor...
    apply subst_tt_type...
  -
    constructor...
    apply subst_tt_type...
  -
    simpl in *...
    destruct (X==X)...
  -
    simpl in *...
    destruct (Y==X)...
  -
    simpl in *...
  -
    simpl in *...
    apply pos_rec with (L:=L \u {{X}} \u {{Y}} \u fv_tt A \u fv_tt B).
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    apply H0...
    apply notin_union...
    split...
    apply notin_union...
    split...
    apply notin_fv_tt_open_aux...
    apply notin_fv_tt_open_aux...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    pick fresh Y1.
    assert (Y1 `notin` union L (singleton X) ) by auto.
    assert (Y0 `notin` union (singleton Y1) (union (fv_tt (open_tt A Y1)) (fv_tt (open_tt B Y1)))).
    {
      apply notin_union.
      split...
      apply notin_union.
      split;apply notin_fv_tt_open_aux...
    }
    specialize (H2 _ H5 _ H6).
    rewrite <- subst_tt_intro in H2...
    rewrite <- subst_tt_intro in H2...
    apply pos_rename_fix...
  -
    simpl in *.
    apply pos_rec_t with (L:=L \u {{X}} \u {{Y}}).
    rewrite <- subst_tt_fresh...
    intros.
    rewrite subst_tt_open_tt_var...
    apply subst_tt_type...
Qed.

Lemma pos_rename_2: forall X m A B Y,
    posvar m X A B ->
    Y \notin {{X}} \u fv_tt A \u fv_tt B ->
    posvar m X (subst_tt X Y A) (subst_tt X Y B).
Proof with auto.
  intros.
  generalize dependent Y.
  induction H;intros...
  -
    constructor...
    apply subst_tt_type...
  -
    constructor...
    apply subst_tt_type...
  -
    simpl in *...
    destruct (X==X)...
  -
    simpl in *...
    destruct (Y==X)...
  -
    simpl in *...
  -
    simpl in *...
    apply pos_rec with (L:=L \u {{X}} \u {{Y}} \u fv_tt A \u fv_tt B).
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    apply H0...
    apply notin_union...
    split...
    apply notin_union...
    split...
    apply notin_fv_tt_open_aux...
    apply notin_fv_tt_open_aux...
    intros.
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    pick fresh Y1.
    assert (Y1 `notin` union L (singleton X) ) by auto.
    assert (Y0 `notin` union (singleton Y1) (union (fv_tt (open_tt A Y1)) (fv_tt (open_tt B Y1)))).
    {
      apply notin_union.
      split...
      apply notin_union.
      split;apply notin_fv_tt_open_aux...
    }
    specialize (H2 _ H5 _ H6).
    rewrite <- subst_tt_intro in H2...
    rewrite <- subst_tt_intro in H2...
    apply pos_rename_fix...
  -
    simpl in *.
    apply pos_rec_t with (L:=L \u {{X}} \u {{Y}}).
    rewrite <- subst_tt_fresh...
    intros.
    rewrite subst_tt_open_tt_var...
    apply subst_tt_type...
Qed.

Lemma sub_amber2_refl: forall E A,
    wf_env E ->
    WF E A ->
    sub_amber2 E A A.
Proof with auto.
  intros.
  induction H0...
  apply sam2_rec with (L:=L \u fv_tt A \u dom E)...
  intros...
  apply pos_rec_t with (L:=L \u fv_tt A \u dom E)...
  intros.
  apply wf_type with (E:=([(Y, bind_sub)] ++ E) )...
Qed.

Lemma sub_amber_to_amber_2: forall E A B,
    sub_amber E A B ->
    sub_amber2 (env_trans E) (rename_env E A) (rename_env E B).
Proof with auto using notin_fv_domA, notin_fv_tt_open_aux.
  intros.
  induction H...
  -
    rewrite rename_nat...
    constructor...
    apply env_trans_wfe...
  -
    rewrite rename_top...
    constructor...
    apply wf_amber_to_WF...
    apply env_trans_wfe...
  -
    assert (rename_env E X = X).
    eapply rename_fvar2...
    eassumption.
    rewrite H1.
    assert (rename_env E Y = X).
    eapply rename_fvar...
    rewrite H2.
    constructor...
    apply fvar_in_env_trans_X in H...
    apply env_trans_wfe...
  -
    rewrite rename_arrow...
    rewrite rename_arrow...
  -
    rewrite rename_mu...
    rewrite rename_mu...
    apply sam2_rec with (L:=L \u domA E \u fv_tt A \u fv_tt B).
    +
      intros.
      simpl in H0.
      pick fresh Y.
      assert (X \notin L) as Hx by auto.
      assert (Y \notin {{X}} \u L) as Hy by auto.
      specialize (H0 _ _ Hx Hy).
      rewrite <- subst_tt_fresh in H0...
      rewrite rename_subst in H0...
      rewrite rename_open in H0...
      rewrite rename_open in H0...
    +
      intros.
      pick fresh Y.
      assert (X \notin L) as Hx by auto.
      assert (Y \notin {{X}} \u L) as Hy by auto.
      specialize (H _ _ Hx Hy).
      apply sub_amber_to_posvar_aux with (X:=X) (Y:=Y) in H.
      destruct H.
      assert (Y `notin` fv_tt (open_tt A X)).
      apply notin_fv_tt_open_aux...
      assert (X `notin` fv_tt (open_tt B Y)).
      apply notin_fv_tt_open_aux...
      specialize (H H3 H4).
      simpl in H.
      rewrite <- subst_tt_fresh in H...
      rewrite rename_subst in H...
      apply pos_rec with (L:=domA E \u fv_tt A \u fv_tt B \u {{X}} \u {{Y}}).
      intros.
      rewrite rename_open in H...
      rewrite rename_open in H...
      rewrite subst_tt_intro with (X:=X)...
      remember (subst_tt X Y0 (open_tt (rename_env E A) X)).
      rewrite subst_tt_intro with (X:=X)...
      subst.
      apply pos_rename_2...
      intros.
      rewrite rename_open in H...
      rewrite rename_open in H...
      rewrite subst_tt_intro with (X:=X)...
      remember (subst_tt X Y0 (open_tt (rename_env E A) X)).
      rewrite subst_tt_intro with (X:=X)...
      subst.
      apply pos_rename_1...
      apply in_eq...
  -
    apply sub_amber2_refl...
    apply env_trans_wfe...
    apply wf_amber_to_WF in H0...
    apply soundness_wfa in H0...
    apply completeness_wf in H0...
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e256m2e224p2e192p2e96m1_4limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e512m491x2e496m1_16limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.