Require Import prosa.classic.util.all.
Require Import prosa.classic.analysis.apa.bertogna_fp_theory.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop div path.

Module ResponseTimeIterationFP.

  Import ResponseTimeAnalysisFP.

  (* In this section, we define the algorithm corresponding to the APA-reduction
     of Bertogna and Cirinei's RTA for FP scheduling. *)
  Section Analysis.

    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.

    (* As input for each iteration of the algorithm, we consider pairs
       of tasks and computed response-time bounds. *)
    Let task_with_response_time := (sporadic_task * time)%type.

    (* Consider a platform with num_cpus processors, ... *)
    Variable num_cpus: nat.

    (* ..., and priorities based on an FP policy. *)
    Variable higher_priority: FP_policy sporadic_task.

    (* Assume that every task has a processor affinity alpha. *)
    Variable alpha: task_affinity sporadic_task num_cpus.

    (* For the reduction to subproblems, consider a subaffinity alpha' for each task. *)
    Variable alpha': task_affinity sporadic_task num_cpus.

    (* Next we define the fixed-point iteration for the APA-reduction of
       Bertogna and Cirineis's response-time analysis. *)

    (* First, given a sequence of pairs R_prev = <..., (tsk_hp, R_hp)> of
       response-time bounds for the higher-priority tasks, we define an
       iteration that computes the response-time bound of the current task:

           R_tsk (0) = task_cost tsk
           R_tsk (step + 1) =  f (R step),

       where f is the response-time recurrence, step is the number of iterations,
       and R_tsk (0) is the initial state. *)
    Definition per_task_rta (tsk: sporadic_task)
                            (R_prev: seq task_with_response_time) (step: nat) :=
      iter step
        (fun t => task_cost tsk +
                  div_floor
                    (total_interference_bound_fp task_cost task_period alpha tsk
                                                 (alpha' tsk) R_prev t higher_priority)
                    #|alpha' tsk|)
        (task_cost tsk).

    (* To ensure that the iteration converges, we will apply per_task_rta
       a "sufficient" number of times: task_deadline tsk - task_cost tsk + 1.
       This corresponds to the time complexity of the iteration. *)
    Definition max_steps (tsk: sporadic_task) := task_deadline tsk - task_cost tsk + 1.

    (* Next we compute the response-time bounds for the entire task set.
       Since high-priority tasks may not be schedulable, we allow the
       computation to fail.
       Thus, given the response-time bound of previous tasks, we either
       (a) append the computed response-time bound (tsk, R) of the current task
           to the list of pairs, or,
       (b) return None if the response-time analysis failed. *)
    Definition fp_bound_of_task hp_pairs tsk :=
      if hp_pairs is Some rt_bounds then
        let R := per_task_rta tsk rt_bounds (max_steps tsk) in
          if R <= task_deadline tsk then
            Some (rcons rt_bounds (tsk, R))
          else None
      else None.

    (* The response-time analysis for a given task set is defined
       as a left-fold (reduce) based on the function above.
       This either returns a list of task and response-time bounds, or None. *)
    Definition fp_claimed_bounds (ts: seq sporadic_task) :=
      foldl fp_bound_of_task (Some [::]) ts.

    (* The schedulability test simply checks if we got a list of
       response-time bounds (i.e., if the computation did not fail). *)
    Definition fp_schedulable (ts: seq sporadic_task) :=
      fp_claimed_bounds ts != None.

    (* In the following section, we prove several helper lemmas about the
       list of response-time bounds. The results seem trivial, but must be proven
       nonetheless since the list of response-time bounds is computed with
       a specific algorithm and there are no lemmas in the library for that. *)
    Section SimpleLemmas.

      (* First, we show that the first component of the computed list is the set of tasks. *)
      Lemma fp_claimed_bounds_unzip :
        forall ts hp_bounds,
          fp_claimed_bounds ts = Some hp_bounds ->
          unzip1 hp_bounds = ts.
      Proof.
        unfold fp_claimed_bounds in *; intros ts.
        induction ts using last_ind; first by destruct hp_bounds.
        {
          intros hp_bounds SOME.
          destruct (lastP hp_bounds) as [| hp_bounds'].
          {
            rewrite -cats1 foldl_cat /= in SOME.
            unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
            by destruct l.
          }
          rewrite -cats1 foldl_cat /= in SOME.
          unfold fp_bound_of_task at 1 in SOME; simpl in *; desf.
          move: H0 => /eqP EQSEQ.
          rewrite eqseq_rcons in EQSEQ.
          move: EQSEQ => /andP [/eqP SUBST /eqP EQSEQ]; subst.
          unfold unzip1; rewrite map_rcons; f_equal.
          by apply IHts.
        }
      Qed.

      (* Next, we show that some properties of the analysis are preserved for the
         prefixes of the list: (a) the tasks do not change, (b) R <= deadline,
         (c) R is computed using the response-time equation, ... *)
      Lemma fp_claimed_bounds_rcons :
        forall ts' hp_bounds tsk1 tsk2 R,
          (fp_claimed_bounds (rcons ts' tsk1) = Some (rcons hp_bounds (tsk2, R)) ->
           (fp_claimed_bounds ts' = Some hp_bounds /\
            tsk1 = tsk2 /\
            R = per_task_rta tsk1 hp_bounds (max_steps tsk1) /\
            R <= task_deadline tsk1)).
      Proof.
        intros ts hp_bounds tsk tsk' R.
        rewrite -cats1.
        unfold fp_claimed_bounds in *.
        rewrite foldl_cat /=.
        unfold fp_bound_of_task at 1; simpl; desf.
        intros EQ; inversion EQ; move: EQ H0 => _ /eqP EQ.
        rewrite eqseq_rcons in EQ.
        move: EQ => /andP [/eqP EQ /eqP RESP].
        by inversion RESP; repeat split; subst.
      Qed.

      (* ..., which implies that any prefix of the computation is the computation
         of the prefix. *)
      Lemma fp_claimed_bounds_take :
        forall ts hp_bounds i,
          fp_claimed_bounds ts = Some hp_bounds ->
          i <= size hp_bounds ->
          fp_claimed_bounds (take i ts) = Some (take i hp_bounds).
      Proof.
        intros ts hp_bounds i SOME LTi.
        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.
        rewrite <- UNZIP in *.
        rewrite -[hp_bounds]take_size /unzip1 map_take in SOME.
        fold (unzip1 hp_bounds) in *; clear UNZIP.
        rewrite leq_eqVlt in LTi.
        move: LTi => /orP [/eqP EQ | LTi]; first by subst.
        remember (size hp_bounds) as len; apply eq_leq in Heqlen.
        induction len; first by rewrite ltn0 in LTi.
        {
          assert (TAKElen: fp_claimed_bounds (take len (unzip1 (hp_bounds))) =
                             Some (take len (hp_bounds))).
          {
            assert (exists p, p \in hp_bounds).
            {
              destruct hp_bounds; first by rewrite ltn0 in Heqlen.
              by exists t; rewrite in_cons eq_refl orTb.
            } destruct H as [[tsk R] _].
             rewrite (take_nth tsk) in SOME; last by rewrite size_map.
            rewrite (take_nth (tsk,R)) in SOME; last by done.
            destruct (nth (tsk, R) hp_bounds len) as [tsk_len R_len].
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
          rewrite ltnS leq_eqVlt in LTi.
          move: LTi => /orP [/eqP EQ | LESS]; first by subst.
          apply ltnW in Heqlen.
          by specialize (IHlen Heqlen TAKElen LESS).
        }
      Qed.

      (* If the analysis suceeds, the computed response-time bounds are no larger
         than the deadlines ... *)
      Lemma fp_claimed_bounds_le_deadline :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R <= task_deadline tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by apply Heq0.
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* ... and no smaller than the task costs. *)
      Lemma fp_claimed_bounds_ge_cost :
        forall ts' rt_bounds tsk R,
          fp_claimed_bounds ts' = Some rt_bounds ->
          (tsk, R) \in rt_bounds ->
          R >= task_cost tsk.
      Proof.
        intros ts; induction ts as [| ts' tsk_lst] using last_ind.
        {
          intros rt_bounds tsk R SOME IN.
          by inversion SOME; subst; rewrite in_nil in IN.
        }
        {
          intros rt_bounds tsk_i R SOME IN.
          destruct (lastP rt_bounds) as [|rt_bounds (tsk_lst', R_lst)];
            first by rewrite in_nil in IN.
          rewrite mem_rcons in_cons in IN; move: IN => /orP IN.
          destruct IN as [LAST | FRONT].
          {
            move: LAST => /eqP LAST.
            rewrite -cats1 in SOME.
            unfold fp_claimed_bounds in *.
            rewrite foldl_cat /= in SOME.
            unfold fp_bound_of_task in SOME.
            desf; rename H0 into EQ.
            move: EQ => /eqP EQ.
            rewrite eqseq_rcons in EQ.
            move: EQ => /andP [_ /eqP EQ].
            inversion EQ; subst.
            by destruct (max_steps tsk_lst');
              [by apply leqnn | by apply leq_addr].
          }
          {
            apply IHts with (rt_bounds := rt_bounds); last by ins.
            by apply fp_claimed_bounds_rcons in SOME; des.
          }
        }
      Qed.

      (* Short lemma about unfolding the iteration one step. *)
      Lemma per_task_rta_fold :
        forall tsk rt_bounds,
          task_cost tsk +
           div_floor (total_interference_bound_fp task_cost task_period alpha tsk (alpha' tsk) rt_bounds
                     (per_task_rta tsk rt_bounds (max_steps tsk)) higher_priority) #|alpha' tsk|
          = per_task_rta tsk rt_bounds (max_steps tsk).+1.
      Proof.
          by done.
      Qed.

    End SimpleLemmas.

    (* In this section, we prove that if the task set is sorted by priority,
       the tasks in fp_claimed_bounds are interfering tasks.  *)
    Section HighPriorityTasks.

      (* Consider a list of previous tasks and a task tsk to be analyzed. *)
      Variable ts: taskset_of sporadic_task.

      (* Assume that the task set is sorted by unique priorities, ... *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.

      (* ...the priority order is transitive, ...*)
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* ... and that the response-time analysis succeeds. *)
      Variable hp_bounds: seq task_with_response_time.
      Variable R: time.
      Hypothesis H_analysis_succeeds: fp_claimed_bounds ts = Some hp_bounds.

      (* Let's refer to tasks by index. *)
      Variable elem: sporadic_task.
      Let TASK := nth elem ts.

      (* We prove that higher-priority tasks have smaller index. *)
      Lemma fp_claimed_bounds_hp_tasks_have_smaller_index :
        forall hp_idx idx,
          hp_idx < size ts ->
          idx < size ts ->
          hp_idx != idx ->
          higher_priority (TASK hp_idx) (TASK idx) ->
          hp_idx < idx.
      Proof.
        unfold TASK; clear TASK.
        rename ts into ts'; destruct ts' as [ts UNIQ]; simpl in *.
        intros hp_idx idx LThp LT NEQ HP.
        rewrite ltn_neqAle; apply/andP; split; first by done.
        by apply sorted_rel_implies_le_idx with (leT := higher_priority) (xs := ts) (default := elem).
      Qed.

    End HighPriorityTasks.

    (* In this section, we show that the fixed-point iteration converges. *)
    Section Convergence.

      (* Consider any sequence with higher-priority tasks. *)
      Variable ts_hp: seq sporadic_task.

      (* Assume that the response-time analysis succeeds for the higher-priority tasks. *)
      Variable rt_bounds: seq task_with_response_time.
      Hypothesis H_test_succeeds: fp_claimed_bounds ts_hp = Some rt_bounds.

      (* Consider any task tsk to be analyzed, ... *)
      Variable tsk: sporadic_task.

      (* ... and assume all tasks have valid parameters. *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline (rcons ts_hp tsk).

      (* To simplify, let f denote the fixed-point iteration. *)
      Let f := per_task_rta tsk rt_bounds.

      (* Assume that f (max_steps tsk) is no larger than the deadline. *)
      Hypothesis H_no_larger_than_deadline: f (max_steps tsk) <= task_deadline tsk.

      (* First, we show that f is monotonically increasing. *)
      Lemma bertogna_fp_comp_f_monotonic :
        forall x1 x2, x1 <= x2 -> f x1 <= f x2.
      Proof.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
        rename H_test_succeeds into SOME,
               H_valid_task_parameters into VALID.
        intros x1 x2 LEx; unfold f, per_task_rta.
        apply fun_mon_iter_mon; [by ins | by ins; apply leq_addr |].
        clear LEx x1 x2; intros x1 x2 LEx.
        unfold div_floor, total_interference_bound_fp.
        rewrite big_seq_cond [\sum_(i <- _ | let '(tsk_other, _) := i in
                          higher_priority_task_in _ _ _ _ _)_]big_seq_cond.
        rewrite leq_add2l leq_div2r //.
        apply leq_sum; move => i /andP [IN _].
        destruct i as [i R].
        have GE_COST := fp_claimed_bounds_ge_cost ts_hp rt_bounds i R SOME IN.
        have UNZIP := fp_claimed_bounds_unzip ts_hp rt_bounds SOME.
        unfold interference_bound_generic; simpl.
        assert (IN': i \in ts_hp).
        {
          by rewrite -UNZIP; apply/mapP; exists (i,R).
        }
        unfold interference_bound_generic; simpl.
        rewrite leq_min; apply/andP; split.
        {
          apply leq_trans with (n := W task_cost task_period i R x1); first by apply geq_minl.
          exploit (VALID i); [by rewrite mem_rcons in_cons IN' orbT | ins; des].
          by apply W_monotonic; try (by done); apply GE_COST.
        }
        {
          apply leq_trans with (n := x1 - task_cost tsk + 1); first by apply geq_minr.
          by rewrite leq_add2r leq_sub2r //.
        }
      Qed.

      (* If the iteration converged at an earlier step, it remains as a fixed point. *)
      Lemma bertogna_fp_comp_f_converges_early :
        (exists k, k <= max_steps tsk /\ f k = f k.+1) ->
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        by intros EX; des; apply fixedpoint.iter_fix with (k := k).
      Qed.

      (* Else, we derive a contradiction. *)
      Section DerivingContradiction.

        (* Assume instead that the iteration continued to diverge. *)
        Hypothesis H_keeps_diverging:
          forall k,
            k <= max_steps tsk -> f k != f k.+1.

        (* By monotonicity, it follows that the value always increases. *)
        Lemma bertogna_fp_comp_f_increases :
          forall k,
            k <= max_steps tsk ->
            f k < f k.+1.
        Proof.
          intros k LT.
          rewrite ltn_neqAle; apply/andP; split.
            by apply H_keeps_diverging.
            by apply bertogna_fp_comp_f_monotonic, leqnSn.
        Qed.

        (* In the end, the response-time bound must exceed the deadline. Contradiction! *)
        Lemma bertogna_fp_comp_rt_grows_too_much :
          forall k,
            k <= max_steps tsk ->
            f k > k + task_cost tsk - 1.
        Proof.
          have INC := bertogna_fp_comp_f_increases.
          rename H_valid_task_parameters into TASK_PARAMS.
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.
          exploit (TASK_PARAMS tsk);
            [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
          induction k.
          {
            intros _; rewrite add0n -addn1 subh1;
              first by rewrite -addnBA // subnn addn0 /= leqnn.
            by apply PARAMS.
          }
          {
            intros LT.
            specialize (IHk (ltnW LT)).
            apply leq_ltn_trans with (n := f k);last by apply INC, ltnW.
            rewrite -addn1 -addnA [1 + _]addnC addnA -addnBA // subnn addn0.
            rewrite -(ltn_add2r 1) in IHk.
            rewrite subh1 in IHk;
              last by apply leq_trans with (n := task_cost tsk);
                [by apply PARAMS | by apply leq_addl].
            by rewrite -addnBA // subnn addn0 addn1 ltnS in IHk.
          }
        Qed.

      End DerivingContradiction.

      (* Using the lemmas above, we prove the convergence of the iteration after max_steps. *)
      Lemma per_task_rta_converges:
        f (max_steps tsk) = f (max_steps tsk).+1.
      Proof.
        have TOOMUCH := bertogna_fp_comp_rt_grows_too_much.
        have INC := bertogna_fp_comp_f_increases.
        rename H_no_larger_than_deadline into LE,
               H_valid_task_parameters into TASK_PARAMS.
        unfold valid_sporadic_taskset, is_valid_sporadic_task in *; des.

        (* Either f converges by the deadline or not. *)
        destruct ([exists k in 'I_(max_steps tsk).+1, f k == f k.+1]) eqn:EX.
        {
          move: EX => /exists_inP EX; destruct EX as [k _ ITERk].
          apply bertogna_fp_comp_f_converges_early.
          by exists k; split; [by rewrite -ltnS; apply ltn_ord | by apply/eqP].
        }

        (* If not, then we reach a contradiction *)
        apply negbT in EX; rewrite negb_exists_in in EX.
        move: EX => /forall_inP EX.
        rewrite leqNgt in LE; move: LE => /negP LE.
        exfalso; apply LE.

        assert (DIFF: forall k : nat, k <= max_steps tsk -> f k != f k.+1).
        {
          intros k LEk; rewrite -ltnS in LEk.
          by exploit (EX (Ordinal LEk)); [by done | intro DIFF; apply DIFF].
        }
        exploit TOOMUCH; [by apply DIFF | by apply leq_addr |].
        exploit (TASK_PARAMS tsk);
          [by rewrite mem_rcons in_cons eq_refl orTb | intro PARAMS; des].
        rewrite subh1; last by apply PARAMS2.
        rewrite -addnBA // subnn addn0 subn1 prednK //.
        intros LT; apply (leq_ltn_trans LT).
        by rewrite /max_steps [_ - _ + 1]addn1; apply INC, leq_addr.
      Qed.

    End Convergence.

    (* Now we prove the correctness of the response-time bounds. *)
    Section MainProof.

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

      (* Assume that all tasks have valid parameters ... *)
      Hypothesis H_valid_task_parameters:
        valid_sporadic_taskset task_cost task_period task_deadline ts.

      (* ...and constrained deadlines. *)
      Hypothesis H_constrained_deadlines:
        forall tsk, tsk \in ts -> task_deadline tsk <= task_period tsk.

      (* Assume that alpha' is a non-empty subaffinity of alpha. *)
      Hypothesis H_non_empty_affinity:
        forall tsk, tsk \in ts -> #|alpha' tsk| > 0.
      Hypothesis H_subaffinity:
        forall tsk, tsk \in ts -> is_subaffinity (alpha' tsk) (alpha tsk).

      (* Assume that the task set is totally ordered by unique decreasing
         priorities and that the priority order is transitive. *)
      Hypothesis H_task_set_is_sorted: sorted higher_priority ts.
      Hypothesis H_task_set_has_unique_priorities:
        FP_is_antisymmetric_over_task_set higher_priority ts.
      Hypothesis H_priority_is_total:
        FP_is_total_over_task_set higher_priority ts.
      Hypothesis H_priority_transitive: FP_is_transitive higher_priority.

      (* Next, consider any arrival sequence such that...*)
      Variable arr_seq: arrival_sequence Job.

     (* ...all jobs come from task set ts, ...*)
      Hypothesis H_all_jobs_from_taskset:
        forall j, arrives_in arr_seq j -> job_task j \in ts.

      (* ...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.

      (* ... and satisfy the sporadic task model.*)
      Hypothesis H_sporadic_tasks:
        sporadic_task_model task_period job_arrival job_task arr_seq.

      (* Then, consider any schedule such that...*)
      Variable sched: schedule Job num_cpus.
      Hypothesis H_jobs_come_from_arrival_sequence:
        jobs_come_from_arrival_sequence sched arr_seq.

      (* ...jobs only execute after they arrived and no longer
         than their execution costs,... *)
      Hypothesis H_jobs_must_arrive_to_execute: jobs_must_arrive_to_execute job_arrival sched.
      Hypothesis H_completed_jobs_dont_execute: completed_jobs_dont_execute job_cost sched.

      (* ...and jobs are sequential. *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* Assume a work-conserving APA scheduler that respects the FP policy. *)
      Hypothesis H_respects_affinity: respects_affinity job_task sched alpha.
      Hypothesis H_work_conserving: apa_work_conserving job_arrival job_cost job_task arr_seq
                                                        sched alpha.
      Hypothesis H_respects_FP_policy:
        respects_FP_policy_under_weak_APA job_arrival job_cost job_task arr_seq sched
                                          alpha higher_priority.

      (* To avoid a long list of parameters, we provide some local definitions. *)
      Let no_deadline_missed_by_task (tsk: sporadic_task) :=
        task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched tsk.
      Let no_deadline_missed_by_job :=
        job_misses_no_deadline job_arrival job_cost job_deadline sched.
      Let response_time_bounded_by (tsk: sporadic_task) :=
        is_response_time_bound_of_task job_arrival job_cost job_task arr_seq sched tsk.

      (* In the following theorem, we prove that any response-time bound contained
         in fp_claimed_bounds is safe. The proof follows by induction on the task set:

           Induction hypothesis: assume all higher-priority tasks have safe response-time bounds.
           Inductive step: we prove that the response-time bound of the current task is safe.

         Note that the inductive step is a direct application of the main Theorem from
         bertogna_fp_theory.v. *)
      Theorem fp_analysis_yields_response_time_bounds :
        forall tsk R,
          (tsk, R) \In fp_claimed_bounds ts ->
          response_time_bounded_by tsk R.
      Proof.
        rename H_valid_job_parameters into JOBPARAMS, H_valid_task_parameters into TASKPARAMS.
        unfold valid_sporadic_taskset in *.
        intros tsk R MATCH.
        assert (SOME: exists hp_bounds, fp_claimed_bounds ts = Some hp_bounds /\
                                        (tsk, R) \in hp_bounds).
        {
          destruct (fp_claimed_bounds ts); last by done.
          by exists l; split.
        } clear MATCH; des; rename SOME0 into IN.

        have UNZIP := fp_claimed_bounds_unzip ts hp_bounds SOME.

        set elem := (tsk,R).
        move: IN => /(nthP elem) [idx LTidx EQ].
        set NTH := fun k => nth elem hp_bounds k.
        set TASK := fun k => (NTH k).1.
        set RESP := fun k => (NTH k).2.
        cut (response_time_bounded_by (TASK idx) (RESP idx));
          first by unfold TASK, RESP, NTH; rewrite EQ.
        clear EQ.

        assert (PAIR: forall idx, (TASK idx, RESP idx) = NTH idx).
          by intros i; unfold TASK, RESP; destruct (NTH i).

        assert (SUBST: forall i, i < size hp_bounds -> TASK i = nth tsk ts i).
          by intros i LTi; rewrite /TASK /NTH -UNZIP (nth_map elem) //.

        assert (SIZE: size hp_bounds = size ts).
          by rewrite -UNZIP size_map.

        induction idx as [idx IH'] using strong_ind.

        assert (IH: forall tsk_hp R_hp, (tsk_hp, R_hp) \in take idx hp_bounds -> response_time_bounded_by tsk_hp R_hp).
        {
          intros tsk_hp R_hp INhp.
          move: INhp => /(nthP elem) [k LTk EQ].
          rewrite size_take LTidx in LTk.
          rewrite nth_take in EQ; last by done.
          cut (response_time_bounded_by (TASK k) (RESP k));
            first by unfold TASK, RESP, NTH; rewrite EQ.
          by apply IH'; try (by done); apply (ltn_trans LTk).
        } clear IH'.

        unfold response_time_bounded_by in *.

        exploit (fp_claimed_bounds_rcons (take idx ts) (take idx hp_bounds) (TASK idx) (TASK idx) (RESP idx)).
        {
          by rewrite PAIR SUBST // -2?take_nth -?SIZE // (fp_claimed_bounds_take _ hp_bounds).
        }
        intros [_ [_ [REC DL]]].

        apply bertogna_cirinei_response_time_bound_fp with
              (alpha0 := alpha) (alpha'0 := alpha')
              (task_cost0 := task_cost) (task_period0 := task_period)
              (task_deadline0 := task_deadline) (job_deadline0 := job_deadline) (tsk0 := (TASK idx))
              (job_task0 := job_task) (ts0 := ts) (hp_bounds0 := take idx hp_bounds)
              (higher_eq_priority := higher_priority); try (by ins).
        {
          cut (NTH idx \in hp_bounds = true); [intros IN | by apply mem_nth].
          by rewrite set_mem -UNZIP; apply/mapP; exists (TASK idx, RESP idx); rewrite PAIR.
        }
        {
          intros hp_tsk IN INTERF.
          exists (RESP (index hp_tsk ts)).
          move: (IN) => INDEX; apply nth_index with (x0 := tsk) in INDEX.
          rewrite -{1}[hp_tsk]INDEX -SUBST; last by rewrite SIZE index_mem.
          assert (UNIQ: uniq hp_bounds).
          {
            apply map_uniq with (f := fst); unfold unzip1 in *; rewrite UNZIP.
            by destruct ts.
          }
          rewrite -filter_idx_lt_take //.
          {
            rewrite PAIR mem_filter; apply/andP; split;
              last by apply mem_nth; rewrite SIZE index_mem.
            {
              rewrite /NTH index_uniq; [| by rewrite SIZE index_mem | by done ].
              {
                move: INTERF => /andP [/andP [HP NEQ] _].
                apply fp_claimed_bounds_hp_tasks_have_smaller_index with
                  (ts := ts) (elem := tsk) (hp_bounds := hp_bounds);
                  try (by done);
                  [by rewrite index_mem | by rewrite -SIZE | | by rewrite INDEX -SUBST].
                apply/eqP; intro BUG; subst idx.
                rewrite SUBST -{1}INDEX in NEQ;
                  first by rewrite eq_refl in NEQ.
                by rewrite SIZE index_mem INDEX.
              }
            }
          }
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_ge_cost with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          intros hp_tsk R_hp IN; apply mem_take in IN.
          by apply fp_claimed_bounds_le_deadline with (ts' := ts) (rt_bounds := hp_bounds).
        }
        {
          rewrite REC.
          rewrite per_task_rta_fold.
          apply per_task_rta_converges with (ts_hp := take idx ts);
            [by apply fp_claimed_bounds_take; try (by apply ltnW) | | by rewrite -REC ].
          rewrite SUBST // -take_nth -?SIZE //.
          by intros i IN; eapply TASKPARAMS, mem_take, IN.
        }
      Qed.

      (* Therefore, if the schedulability test suceeds, ...*)
      Hypothesis H_test_succeeds: fp_schedulable ts.

      (*..., no task misses its deadline. *)
      Theorem taskset_schedulable_by_fp_rta :
        forall tsk, tsk \in ts -> no_deadline_missed_by_task tsk.
      Proof.
        have RLIST := (fp_analysis_yields_response_time_bounds).
        have UNZIP := (fp_claimed_bounds_unzip ts).
        have DL := (fp_claimed_bounds_le_deadline ts).
        unfold no_deadline_missed_by_task, task_misses_no_deadline,
               job_misses_no_deadline, completed,
               fp_schedulable, valid_sporadic_job in *.
        rename H_valid_job_parameters into JOBPARAMS.
        move => tsk INtsk j ARRj JOBtsk.

        destruct (fp_claimed_bounds ts) as [rt_bounds |]; last by ins.
        feed (UNZIP rt_bounds); first by done.
        assert (EX: exists R, (tsk, R) \in rt_bounds).
        {
          rewrite set_mem -UNZIP in INtsk; move: INtsk => /mapP EX.
          by destruct EX as [p]; destruct p as [tsk' R]; simpl in *; subst tsk'; exists R.
        } des.
        exploit (RLIST tsk R EX j ARRj); [by apply JOBtsk | intro COMPLETED].
        exploit (DL rt_bounds tsk R); [by ins | by ins | clear DL; intro DL].
        apply leq_trans with (n := service sched j (job_arrival j + R)); last first.
        {
          unfold valid_sporadic_taskset, is_valid_sporadic_task in *.
          apply extend_sum; rewrite // leq_add2l.
          specialize (JOBPARAMS j ARRj); des; rewrite JOBPARAMS1.
          by rewrite JOBtsk.
        }
          by done.
      Qed.

      (* For completeness, since all jobs of the arrival sequence
         are spawned by the task set, we also conclude that no job in
         the schedule misses its deadline. *)
      Theorem jobs_schedulable_by_fp_rta :
        forall j, arrives_in arr_seq j -> no_deadline_missed_by_job j.
      Proof.
        intros j ARRj.
        have SCHED := taskset_schedulable_by_fp_rta.
        unfold no_deadline_missed_by_task, task_misses_no_deadline in *.
        apply SCHED with (tsk := job_task j); try (by done).
        by apply H_all_jobs_from_taskset.
      Qed.

    End MainProof.

  End Analysis.

End ResponseTimeIterationFP.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    Inria, 2006              *)
(*************************************************************)

(*rationnal numbers are the ones in QArith, and operations are systematically
  normalizing*)

Require Export QArith.
Require Import Qabs.

 Definition Npred(n :N):N :=
   match n with
     |N0 => N0
     |Npos p => match p with
		  |xH => N0
		  |_ => Npos (Ppred p)
		end
   end.

 Definition Nminus(n m:N):N :=
   match n, m with
     |N0, _ => N0
     |_, N0 => n
     |Npos p, Npos q =>  match Pminus_mask p q with
			   |IsNeg => N0
			   |IsNul => N0
			   |IsPos p => Npos p
			 end
     end.

 Definition is_gt(p q:positive):bool :=
   match Pcompare p q Eq with
     |Gt => true
     |_ => false
   end.

(* euclidian division, for positives *)

 Fixpoint quo_rem(a b :positive){struct a} : N*N :=
  match a with
    |xH => if (is_gt b xH) then (N0, Npos xH) else (Npos xH, N0)
    |xO a' => let (q', r') := quo_rem a' b in
      match r' with
	|N0 => (Ndouble q', N0)
	|Npos p' => if (is_gt b (xO p'))
	  then  (Ndouble q', Npos (xO p'))
	  else (Nsucc (Ndouble q'), Nminus (Npos (xO p')) (Npos b))
      end
    |xI a' => let (q',r') := quo_rem a' b in
      match r' with
	|N0 => if (is_gt b xH) then (Ndouble q', Npos xH) else (Npos a, N0)
	|Npos p' => if (is_gt b (xI p'))
	  then (Ndouble q', Npos (xI p'))
	  else (Nsucc (Ndouble q'), Nminus (Npos (xI p')) (Npos b))
      end
  end.

(*
(*if a >b > 0 computes the simplification of (a,b) ie gcd free parts (a', b')*)
(*n for the termination, will be a*)
 Fixpoint remove_gcd_term(a b n: positive){struct n}: positive*positive :=
   let (q,r) := quo_rem a b in
     match r, q, n with
       |N0, N0, _ =>  (a,b) (* n'arrive jamais *)
       |N0, Npos q', _ => (q', xH)
       |_, _, xH => (a,b) (* n'arrive jamais *)
       |Npos r', N0, xO n'  => let (l,m) := (remove_gcd_term b r' n') in (m, l)
       |Npos r', N0, xI n' => let (l,m) := (remove_gcd_term b r' n') in (m, l)
       |Npos r', Npos q', xO n' =>
	 let (l,m) := (remove_gcd_term b r' n') in
	   (Pplus (Pmult l q') m, l)
       |Npos r', Npos q', xI n' =>
	 let (l,m) := (remove_gcd_term b r' n') in
	   (Pplus (Pmult l q') m, l)
     end.

 Definition remove_gcd(a b:positive):=remove_gcd_term a b a.

 (* normalization of fractions*)

 Definition Qsimpl(q:Q):Q :=
   match Qnum q with
     |Z0 => 0#1
     |Zpos a => let b := Qden q in
       match Pcompare a b Eq with
	 |Eq => 1#1
	 |Lt => let (b', a'):= (remove_gcd b a) in (Zpos a')#b'
	 |Gt => let (a', b'):= (remove_gcd a b) in (Zpos a')#b'
       end
     |Zneg a => let b := Qden q in
       match Pcompare a b Eq with
	 |Eq => (Zneg xH)#1
	 |Lt => let (b', a'):= (remove_gcd b a) in (Zneg a')#b'
	 |Gt => let (a', b'):= (remove_gcd a b) in (Zneg a')#b'
       end
   end.
*)

 (*zero test for a rationnal*)
 Definition Qzero_test(q:Q):=
   let (d,n) := q in
     match d with
       |Z0 => true
       |_ => false
     end.

(*the sign of a rationnal number is th one of its denom*)
 Definition Q_sign(q:Q) :=
	match (Qnum q) with
	|Zpos _ => Gt
	|Zneg _ => Lt
	|_ => Eq
end.

(*no need to use normalized mult to compute a power of a norm rational*)
 Fixpoint Qpow_pos(q:Q)(i:positive){struct i}:Q:=
   match i with
     |xH => q
     |xO p => let q' := (Qpow_pos q p) in q'*q'
     |xI p => let q' := (Qpow_pos q p) in q * q' * q'
   end.

 Definition Qpow(q:Q)(i:N) : Q :=
   match i with
     |N0 => 1#1
     |Npos p => Qpow_pos q p
   end.

 Definition Q_abs_val(q:Q):=
   match Qnum q with
     |Zneg _ => -q
     |_ => q
   end.

 Definition Qlt_dec(q q':Q):=
   match Zcompare ((Zpos (Qden q'))*(Qnum q)) ((Zpos (Qden q))*(Qnum q')) with
     |Lt => true
     |_ => false
   end.

 Module Q_NOT_NORM <: RAT_OPS.

  Definition Rat := Q.

(*constants, operations over rationnals,
-MkRat builds a rationnal number from an integer and a positive
-RatEq is an eq relation over rationnals
-Rat_zero_test is a decidable test to the zero constant
-Rat_sign gives the sign of a rationnal : Z0 means it is zero, Zpos _, it is pos, ...
-Rat_pow builds a power of a rationnal, if the rat argument is
  normalized then the power is normalized
*)

   Definition  R0 := (0#1).
   Definition  R1 := (1#1).
   Definition  MkRat := Qmake.
   Definition  Norm := (fun x:Q => x).
   Definition  Rat_add := Qplus.
   Definition  Rat_opp := Qopp.
   Definition  Rat_prod := Qmult.
   Definition  Rat_sub := Qminus.
   Definition  Rat_inv := Qinv.
   Definition  Rat_div := Qdiv.
   Definition  RatEq := Qeq.
   Definition  Rat_zero_test := Qzero_test.
   Definition  Rat_lt := Qlt_dec.
   Definition  Rat_sign := Q_sign.
   Definition  Rat_pow := Qpow.
   Definition Rat_abs_val := Q_abs_val.

   Notation "a # b" := (MkRat a b) : Rat_scope.

   Infix "+" := Rat_add :Rat_scope.
   Notation "- x" := (Rat_opp x) : Rat_scope.
   Infix  "*" := Rat_prod : Rat_scope.
   Infix "-" := Rat_sub : Rat_scope.
   Notation "/ x" := (Rat_inv x): Rat_scope.
   Infix "/":= Rat_div : Rat_scope.

   Notation "x == y" := (RatEq x y) : Rat_scope.
(* plus tard on a dit ...

   Definition  RatEq_refl := Qeq_refl.
   Definition  RatEq_sym := Qeq_sym.
   Definition  RatEq_trans := Qeq_trans.
   Definition  Rat_abs_val := Q_abs_val.

   Definition  Rat_add_ext := Qplus_r_ext.
   Definition  Rat_opp_ext := Qopp_comp.
   Definition  Rat_prod_ext := Qmult_r_ext.
   Definition  Rat_inv_ext := Qinv_comp.

   Definition  Rat_opp_spec := Qopp_spec.
   Definition  Rat_sub_spec := Qsub_r_spec.
   Definition  Rat_div_spec := Qdiv_r_spec.
   Definition  Rat_zero_test_spec := Qzero_test_spec.

   Definition  Rat_0_l    := Q0_l.
   Definition  Rat_add_sym    := Qplus_r_sym.
   Definition  Rat_add_assoc  := Qplus_r_assoc.
   Definition  Rat_prod_1_l    := Qmult_r_1_l.
   Definition  Rat_prod_sym    := Qmult_r_sym.
   Definition  Rat_prod_assoc  := Qmult_r_assoc.
   Definition  Rat_distr_l  := Qdistr'_l.
*)
(*   Definition Rat_of_Z(x : Z) := (MkRat x 1).
   Definition Rat_of_pos(i:positive) := (Rat_of_Z (Zpos i)).
*)

 Open Scope Rat_scope.
 End Q_NOT_NORM.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Default Proof Using "Type".

Set Implicit Arguments.

(* * Signature reduction for symbol free formulas *)

Local Notation ø := vec_nil.

Section no_syms.

  Variable Σ : fo_signature.

  Definition Σ_empty_syms : fo_signature.
  Proof using Σ.
    exists Empty_set (rels Σ).
    + exact (fun _ => 1).
    + exact (ar_rels Σ).
  Defined.

  Notation Σ' := Σ_empty_syms.

  Implicit Types (t : fo_term (ar_syms Σ)) (A : fol_form Σ).

  Local Definition fo_term_no_sym t : incl (fo_term_syms t) nil -> nat.
  Proof.
    refine (match t with
      | in_var i   => fun _ => i
      | in_fot s _ => fun H => False_rect nat _
    end).
    apply (H s (or_introl eq_refl)).
  Defined.

  Local Fact fo_term_no_sym_pirr t H1 H2 : fo_term_no_sym t H1 = fo_term_no_sym t H2.
  Proof.
    revert t H1 H2; intros [ i | s v ] H1 H2; simpl; auto.
    destruct (H1 s).
  Qed.

  Fixpoint Σ_no_sym (A : fol_form Σ) : incl (fol_syms A) nil -> fol_form Σ'.
  Proof.
    refine (match A with
      | ⊥              => fun _ => ⊥
      | fol_atom r v   => fun H => @fol_atom Σ' r (vec_set_pos (fun p => in_var (fo_term_no_sym (vec_pos v p) _)))
      | fol_bin b A B  => fun H => fol_bin b (Σ_no_sym A _) (Σ_no_sym B _)
      | fol_quant q A  => fun H => fol_quant q (Σ_no_sym A _)
    end).
    + intros s Hs; apply H, in_flat_map; exists (vec_pos v p); split; auto; apply in_vec_list, in_vec_pos.
    + intros ? ?; apply H, in_app_iff; simpl; auto.
    + intros ? ?; apply H, in_app_iff; simpl; auto.
    + apply H.
  Defined.

  Variable (A : fol_form Σ) (HA : incl (fol_syms A) nil).

  Section semantics.

    Variable (X : Type).

    Local Fact fo_term_no_sym_sem t Ht M φ : @fo_term_sem _ X M φ t = φ (@fo_term_no_sym t Ht).
    Proof.
      revert t Ht; intros [ i | s v ] H; simpl; auto; destruct H.
    Qed.

    Section soundness.

      Hypothesis (M : fo_model Σ X).

      Let M' : fo_model Σ' X.
      Proof.
        split.
        + intros [].
        + apply (fom_rels M).
      Defined.

      Local Fact Σ_no_sym_sound φ : fol_sem M φ A <-> fol_sem M' φ (Σ_no_sym A HA).
      Proof.
        revert HA φ.
        induction A as [ | r v | b B HB C HC | q B HB ]; intros H φ.
        + simpl; tauto.
        + simpl fol_sem; apply fol_equiv_ext; f_equal.
          apply vec_pos_ext; intros p; rew vec; rew fot.
          apply fo_term_no_sym_sem.
        + apply fol_bin_sem_ext; auto.
        + apply fol_quant_sem_ext; auto.
      Qed.

      Hypothesis (Xf : finite_t X)
                 (Md : fo_model_dec M)
                 (phi : nat -> X)
                 (H : fol_sem M phi A).

      Local Fact Σ_no_sym_soundness : fo_form_fin_dec_SAT_in (Σ_no_sym A HA) X.
      Proof using Xf Md H.
        exists M', Xf, Md, phi.
        revert H; apply Σ_no_sym_sound.
      Qed.

    End soundness.

    Section completeness.

      Hypothesis (M' : fo_model Σ' X) (phi : nat -> X).

      Let M : fo_model Σ X.
      Proof.
       split.
        + intros _ _; exact (phi 0).
        + apply (fom_rels M').
      Defined.

      Local Fact Σ_no_sym_complete φ : fol_sem M φ A <-> fol_sem M' φ (Σ_no_sym A HA).
      Proof.
        revert HA φ.
        induction A as [ | r v | b B HB C HC | q B HB ]; intros H φ.
        + simpl; tauto.
        + simpl fol_sem; apply fol_equiv_ext; f_equal.
          apply vec_pos_ext; intros p; rew vec; rew fot.
          apply fo_term_no_sym_sem.
        + apply fol_bin_sem_ext; auto.
        + apply fol_quant_sem_ext; auto.
      Qed.

      Hypothesis (Xf : finite_t X)
                 (M'd : fo_model_dec M')
                 (H : fol_sem M' phi (Σ_no_sym A HA)).

      Local Fact Σ_no_sym_completeness : fo_form_fin_dec_SAT_in A X.
      Proof using Xf HA H M'd.
        exists M, Xf, M'd, phi.
        revert H; apply Σ_no_sym_complete.
      Qed.

    End completeness.

  End semantics.

  Theorem Σ_no_sym_correct : { B : fol_form Σ' | fo_form_fin_dec_SAT A <-> fo_form_fin_dec_SAT B }.
  Proof using HA.
    exists (Σ_no_sym A HA).
    split.
    + intros (X & M & H1 & H2 & phi & H3); exists X; apply Σ_no_sym_soundness with M phi; auto.
    + intros (X & M & H1 & H2 & phi & H3); exists X; apply Σ_no_sym_completeness with M phi; auto.
  Qed.

End no_syms.


Require Export PredMonad.Reflection2.OrderedType.

(* Neither of these work very well, and in fact get in the way sometimes. Also
their full generality has so far not been needed. So I am just storing them
here... *)

(***
 *** First-Order Ordered Type Functors
 ***)

(* A type portion of a first-order functor of a given arity *)
Fixpoint OTFunctor1 arity : Type :=
  match arity with
  | 0 => Type
  | S arity' => forall A {RA:OType A}, OTFunctor1 arity'
  end.

(* A relation portion of a first-order functor of a given arity *)
Fixpoint OTypeF1Fun arity : OTFunctor1 arity -> Type :=
  match arity with
  | 0 => OType
  | S arity' =>
    fun F => forall A {RA:OType A}, OTypeF1Fun arity' (F A RA)
  end.

(* Typeclass version of OTypeF1Fun *)
Class OTypeF1 arity F : Type :=
  otypeF1 : OTypeF1Fun arity F.

(* A list of arguments to a first-order functor *)
Inductive OTArgs : Type :=
| ArgsNil
| ArgsCons A {RA:OType A} (args:OTArgs)
.

(* Get the head argument of a list, or unit if we ran out *)
Definition OTArgs_head (args:OTArgs) : Type :=
  match args with
  | ArgsNil => unit
  | ArgsCons A args' => A
  end.

(* Get the head OType of a list, or unit if we ran out *)
Definition OTArgs_headOType (args:OTArgs) : OType (OTArgs_head args) :=
  match args with
  | ArgsNil => _
  | ArgsCons A args' => _
  end.

Instance OType_OTArgs_head args : OType (OTArgs_head args) :=
  OTArgs_headOType args.

(* Get the tail of a list of arguments, or the empty list if we ran out *)
Definition OTArgs_tail (args:OTArgs) : OTArgs :=
  match args with
  | ArgsNil => ArgsNil
  | ArgsCons A args' => args'
  end.

(* Apply a functor to a list of arguments. Note that we do not actually care how
long the list is, as we will just supply unit types if we run out of args. *)
Fixpoint OTFunctorApply arity : forall F:OTFunctor1 arity, OTArgs -> Type :=
  match arity return forall F:OTFunctor1 arity, OTArgs -> Type with
  | 0 => fun A _ => A
  | S arity' =>
    fun F args =>
      OTFunctorApply arity' (F (OTArgs_head args) _) (OTArgs_tail args)
  end.

(* Get out the OType from applying a functor *)
Instance OType_OTFunctorApply arity F (RF:OTypeF1 arity F) As :
  OType (OTFunctorApply arity F As).
Proof.
  revert F RF As; induction arity; intros; simpl.
  - assumption.
  - apply IHarity. apply RF.
Defined.

(* Get out the OType from applying a unary functor *)
Instance OType_OTFunctorApply1 F (RF:OTypeF1 1 F) A {RA:OType A} :
  OType (F A RA) := OType_OTFunctorApply 1 F RF (ArgsCons A ArgsNil).

(***
 *** Ordered Type Functors of Higher Kinds
 ***)

(* The language of kinds for type functors, built from * and -> *)
Inductive OKind : Type :=
| OKStar
| OKArrow (k1 k2:OKind)
.

(* The "semantics" of a kind, which is a type A plus a dependent type on A *)
Definition OKindSem := {A:Type & A -> Type}.

(* Typeclass for elements of the dependent type in an OKindSem *)
Class OKindSemRelation (sem:OKindSem) (A:projT1 sem) : Type :=
  okindSemRelation : projT2 sem A.

(* The type and relation types associated with kind k *)
Fixpoint OTFunctorTypes k : {A:Type & A -> Type} :=
  match k with
  | OKStar => existT _ Type OType
  | OKArrow k1 k2 =>
    existT
      (fun A => A -> Type)
      (forall A1 (R1:OKindSemRelation (OTFunctorTypes k1) A1),
          projT1 (OTFunctorTypes k2))
      (fun f => forall A1 R1, OKindSemRelation (OTFunctorTypes k2) (f A1 R1))
  end.
Arguments OTFunctorTypes !k.

(* Ordered type functors of kind k *)
Definition OTFunctor k : Type := projT1 (OTFunctorTypes k).

(* The relation portion of an ordered type functor of kind k *)
Class OTFunctorRel k (F: OTFunctor k) : Type :=
  otFunctorRel : projT2 (OTFunctorTypes k) F.

(* An OTFunctorRel at kind * is the same as an OType *)
Definition OType_OKindSemRelation
           A (RA: OKindSemRelation (OTFunctorTypes OKStar) A) :
  OType A := RA.

(* Only apply OType_OKindSemRelation when we have an OKindSemRelation in
the context *)
Hint Immediate OType_OKindSemRelation : typeclass_instances.

(* The unit type forms a trivial OTFunctor *)
Instance OTFunctorRel_unit : OTFunctorRel OKStar unit := OTunit.

(* Products form an OTFunctor *)
Instance OTFunctorRel_prod : OTFunctorRel
                               (OKArrow OKStar (OKArrow OKStar OKStar))
                               (fun A _ B _ => prod A B) :=
  fun A RA B RB => OTpair A B RA RB.

(* Sums form an OTFunctor *)
Instance OTFunctorRel_sum : OTFunctorRel
                               (OKArrow OKStar (OKArrow OKStar OKStar))
                               (fun A _ B _ => sum A B) :=
  fun A RA B RB => OTsum A B RA RB.

(* Pfuns form an OTFunctor *)
Instance OTFunctorRel_pfun : OTFunctorRel
                               (OKArrow OKStar (OKArrow OKStar OKStar))
                               (fun A _ B _ => A -o> B) :=
  fun A RA B RB => OTarrow A B.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Set Implicit Arguments.

Import WfExtensionality.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Lemma subtype_nom_upp_reduce :
  forall T1 L1 T1', T1 = (t_nom L1 T1') ->
               forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                            subtype T1 T2 = (eq_label L1 L2) && (subtype T1' T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


Require Import
  Coq.QArith.Qround Coq.QArith.Qpower
  MathClasses.interfaces.abstract_algebra
  MathClasses.theory.nat_pow
  MathClasses.theory.int_pow
  CoRN.algebra.RSetoid
  CoRN.metric2.Metric
  CoRN.metric2.MetricMorphisms
  CoRN.metric2.UniformContinuity
  CoRN.model.totalorder.QMinMax
  CoRN.util.Qdlog
  CoRN.stdlib_omissions.Q
  CoRN.reals.fast.CRsin
  CoRN.reals.fast.CRstreams
  CoRN.reals.fast.CRAlternatingSum
  CoRN.reals.fast.Compress
  CoRN.reals.faster.ARAlternatingSum.
Require Export
  CoRN.reals.faster.ARArith.

Local Open Scope mc_scope.

Section ARsin.
Context `{AppRationals AQ}.

Lemma AQmult_lt_0_compat : forall a b : AQ, 0 < a -> 0 < b -> 0 < a*b.
Proof.
  intros.
  apply (strictly_order_reflecting (cast AQ Q)).
  pose proof (rings.preserves_0 (f:=cast AQ Q)).
  rewrite H7.
  rewrite rings.preserves_mult.
  rewrite <- (Qmult_0_l ('b)).
  apply Qmult_lt_compat_r.
  rewrite <- H7.
  apply (strictly_order_preserving (cast AQ Q)), H6.
  rewrite <- H7.
  apply (strictly_order_preserving (cast AQ Q)), H5.
Qed.

Lemma ZtoQ : forall n:positive, AQtoQ (ZtoAQ (Zpos n)) == (Zpos n#1).
Proof.
  induction n.
  - change (Z.pos n~1) with (1+2*Z.pos n)%Z.
    pose proof (rings.preserves_plus (f:=cast Z AQ) 1 (2*Z.pos n)).
    rewrite H5. clear H5.
    rewrite rings.preserves_plus, rings.preserves_1.
    rewrite rings.preserves_1.
    pose proof (rings.preserves_mult (f:=cast Z AQ) 2 (Z.pos n)).
    rewrite H5. clear H5.
    rewrite rings.preserves_mult, IHn.
    rewrite rings.preserves_2, rings.preserves_2.
    unfold Qeq; simpl. rewrite Pos.mul_1_r. reflexivity.
  - change (Z.pos n~0) with (2*Z.pos n)%Z.
    pose proof (rings.preserves_mult (f:=cast Z AQ) 2 (Z.pos n)).
    rewrite H5.
    rewrite rings.preserves_mult, IHn.
    rewrite rings.preserves_2.
    pose proof (rings.preserves_2 (f:=cast AQ Q)).
    rewrite H6. reflexivity.
  - pose proof (rings.preserves_1 (f:=cast Z AQ)).
    rewrite H5. rewrite rings.preserves_1. reflexivity.
Qed.

Local Open Scope uc_scope.

Section sin_small.
  (* First define (sin a) as a decreasing alternating series on the segment [-1,1].
     a = num/den and -1 <= a <= 1. *)

Context {num den : AQ} (Pnd : -den ≤ num ≤ den) (dpos : 0 < den).

(*
Split the stream
  (-1)^i a^(2i+1) / (2i+1)!
up into the streams
  (-1)^i a^(2i+1)    and    (2i+1)!
because we do not have exact division
*)
Definition ARsinStream (px : positive*(AQ*AQ)) : AQ*AQ
  := (- fst (snd px) * num * num,
      snd (snd px) * den * den * ZtoAQ (Zpos (fst px)~0) * ZtoAQ (Zpos (fst px)~1)).

Lemma sinStream_pos : ∀ x : positive * (AQ * AQ),
    0 < snd (snd x) → 0 < snd (ARsinStream x).
Proof.
  assert (0 = ZtoAQ 0) as zero_int.
  { destruct H4. destruct aq_ints_mor, semiringmor_plus_mor.
    rewrite preserves_mon_unit. reflexivity. }
  intros. destruct x; simpl.
  simpl in H5.
  apply AQmult_lt_0_compat.
  apply AQmult_lt_0_compat.
  apply AQmult_lt_0_compat.
  apply AQmult_lt_0_compat.
  exact H5. exact dpos. exact dpos.
  rewrite zero_int.
  apply (strictly_order_preserving (cast Z AQ)).
  reflexivity.
  rewrite zero_int.
  apply (strictly_order_preserving (cast Z AQ)).
  reflexivity.
Qed.

Lemma sinStream_correct : ∀ p : positive,
    Str_pth _ (sinStream (AQtoQ num / AQtoQ den))
            p (1%positive, AQtoQ num / AQtoQ den)
    == let (_, r) := iterate _ (fS ARsinStream) p (1%positive, (num, den)) in
       AQtoQ (fst r) / AQtoQ (snd r).
Proof.
  assert (forall n:Z, AQtoQ (ZtoAQ n) == (n#1)).
  { intro n. destruct n as [|n|n].
    pose proof (rings.preserves_0 (f:=cast Z AQ)). rewrite H5. clear H5.
    rewrite rings.preserves_0. reflexivity.
    apply ZtoQ. change (Z.neg n) with (-Z.pos n)%Z.
    pose proof (rings.preserves_negate (f:=cast Z AQ)).
    rewrite H5. clear H5. rewrite rings.preserves_negate.
    rewrite ZtoQ. reflexivity. }
  apply Pos.peano_ind.
  - unfold Str_pth. simpl.
    do 6 rewrite rings.preserves_mult.
    rewrite rings.preserves_negate.
    rewrite H5, H5.
    unfold dec_recip, stdlib_rationals.Q_recip.
    unfold mult, stdlib_rationals.Q_mult.
    unfold negate, stdlib_rationals.Q_opp.
    field. intro abs.
    apply (strictly_order_preserving (cast AQ Q)) in dpos.
    rewrite rings.preserves_0, abs in dpos.
    exact (Qlt_irrefl 0 dpos).
  - intros p IHp. unfold Str_pth. unfold Str_pth in IHp.
    rewrite iterate_succ, iterate_succ.
    pose proof (sinStream_fst (AQtoQ num / AQtoQ den) p) as H7.
    unfold dec_recip, stdlib_rationals.Q_recip.
    unfold dec_recip, stdlib_rationals.Q_recip in IHp.
    unfold mult, stdlib_rationals.Q_mult.
    unfold mult, stdlib_rationals.Q_mult in IHp.
    unfold Qdiv in H7. unfold Qdiv.
    unfold Qdiv in IHp.
    unfold Q_as_MetricSpace, msp_car.
    unfold Q_as_MetricSpace, msp_car in IHp.
    destruct (iterate _ (sinStream (AQtoQ num * / AQtoQ den)%Q) p
            (1%positive, (AQtoQ num * / AQtoQ den)%Q)).
    simpl in H7. simpl in IHp. subst p0.
    unfold sinStream, snd, fst. rewrite IHp. clear IHp.
    pose proof (fS_fst ARsinStream p (num, den)).
    destruct (iterate _ (fS ARsinStream) p (1%positive, (num, den))) as [p0 p1].
    simpl in H6. simpl. subst p0.
    do 6 rewrite rings.preserves_mult.
    rewrite rings.preserves_negate.
    unfold mult, stdlib_rationals.Q_mult.
    unfold negate, stdlib_rationals.Q_opp.
    rewrite ZtoQ, ZtoQ.
    rewrite <- (Qmult_assoc (AQtoQ (snd p1) * AQtoQ den * AQtoQ den)).
    rewrite Qinv_mult_distr.
    setoid_replace (/ ((Z.pos (Pos.succ p)~0 # 1) * (Z.pos (Pos.succ p)~1 # 1)))
      with (1 # (Pos.succ p * (Pos.succ p)~1)~0) by reflexivity.
    do 2 rewrite Qinv_mult_distr. ring.
Qed.

Lemma AQsin_small_Qprf : -1 ≤ AQtoQ num / AQtoQ den ≤ 1.
Proof.
  split.
  - apply Qle_shift_div_l.
    pose proof (rings.preserves_0 (f:=cast AQ Q)).
    rewrite <- H5.
    apply (strictly_order_preserving (cast AQ Q)), dpos.
    setoid_replace (-1 * AQtoQ den) with (-AQtoQ den) by reflexivity.
    rewrite <- rings.preserves_negate.
    apply (order_preserving (cast AQ Q)), Pnd.
  - apply Qle_shift_div_r.
    pose proof (rings.preserves_0 (f:=cast AQ Q)).
    rewrite <- H5.
    apply (strictly_order_preserving (cast AQ Q)), dpos.
    rewrite Qmult_1_l.
    apply (order_preserving (cast AQ Q)), Pnd.
Qed.

Definition AQsin_small : msp_car AR
  := CRtoAR (inject_Q_CR (AQtoQ num / AQtoQ den))
     + AltSeries ARsinStream sinStream_pos
                 positive (CRsin.sinStream (AQtoQ num / AQtoQ den))
                 (num,den) (xH,AQtoQ num / AQtoQ den) sinStream_correct _
                 (sinStream_alt AQsin_small_Qprf)
                 dpos (sinStream_zl AQsin_small_Qprf).

Lemma AQsin_small_correct : 'AQsin_small = rational_sin (AQtoQ num / AQtoQ den).
Proof.
  rewrite rational_sin_correct,
  <- (rational_sin_small_correct AQsin_small_Qprf).
  unfold AQsin_small, rational_sin_small.
  rewrite ARtoCR_preserves_plus.
  apply ucFun2_wd.
  pose proof CRAR_id. unfold cast in H5.
  unfold cast. rewrite H5.
  reflexivity.
  apply AltSeries_correct.
Qed.

End sin_small.

Lemma AQsin_small_pos_wd :
  forall (n1 n2 d1 d2 : AQ) (p1 : -d1 ≤ n1 ≤ d1) (p2 : -d2 ≤ n2 ≤ d2)
    (d1pos : 0 < d1) (d2pos : 0 < d2),
    n1 = n2
    -> d1 = d2
    -> AQsin_small p1 d1pos = AQsin_small p2 d2pos.
Proof.
  assert (forall x y, ARtoCR x = ARtoCR y -> x = y) as H5.
  { intros x y H5. exact H5. }
  intros. apply H5.
  rewrite (AQsin_small_correct p1 d1pos).
  rewrite (AQsin_small_correct p2 d2pos).
  rewrite H6, H7. reflexivity.
Qed.

(** Sine's range can then be extended to [[0,3^n]] by [n] applications
of the identity [sin(x) = 3*sin(x/3) - 4*(sin(x/3))^3]. *)
Definition AQsin_poly_fun (x : AQ) : AQ := x * (3 - 4 * x ^ (2:N)).

Lemma AQsin_poly_fun_correct (q : AQ) :
  'AQsin_poly_fun q = sin_poly_fun ('q).
Proof.
  unfold AQsin_poly_fun, sin_poly_fun.
  rewrite nat_pow_2.
  rewrite rings.preserves_mult, rings.preserves_minus, ?rings.preserves_mult.
  rewrite rings.preserves_3, rings.preserves_4.
  now rewrite <-(associativity _ ('q) ('q : Q)).
Qed.

(* AQsin_poly_fun is not uniformly continuous because of x^3, but it will
   only be applied to sine values in [-1,1], a range on which it is
   uniformly continuous. *)
Lemma AQsin_poly_fun_bound_correct
  : forall q : AQ, msp_eq (' AQsin_poly_fun (ucFun (AQboundAbs_uc 1) q))
                     (sin_poly_fun (Qmax (- (1)) (Qmin 1 (' q)))).
Proof.
  intro q. apply Qball_0.
  rewrite AQsin_poly_fun_correct.
  f_equiv.
  unfold AQboundAbs_uc. simpl.
  change ('1) with (1:AQ).
  rewrite ?aq_preserves_max, ?aq_preserves_min.
  now rewrite ?rings.preserves_negate, ?rings.preserves_1.
Qed.

Definition AQsin_poly_uc : msp_car (AQ_as_MetricSpace --> AQ_as_MetricSpace)
  := unary_uc (cast AQ (msp_car Q_as_MetricSpace))
              (λ q : AQ, AQsin_poly_fun (ucFun (AQboundAbs_uc 1) q))
              sin_poly_uc AQsin_poly_fun_bound_correct.

Definition ARsin_poly : msp_car (AR --> AR)
  := uc_compose ARcompress (Cmap AQPrelengthSpace AQsin_poly_uc).

Lemma ARtoCR_preserves_sin_poly (x : msp_car AR)
  : 'ucFun ARsin_poly x = ucFun sin_poly ('x).
Proof.
  change ('ucFun ARcompress (ucFun (Cmap AQPrelengthSpace AQsin_poly_uc) x)
    = ucFun compress (ucFun (Cmap QPrelengthSpace sin_poly_uc) ('x))).
  rewrite ARcompress_correct, compress_correct.
  now apply preserves_unary_fun.
Qed.

(* When x = sin y, this function computes sin (y*3^n). *)
Fixpoint ARsin_poly_iter (n : nat) (x : msp_car AR) : msp_car AR :=
  match n with
  | O => x
  | S n' => ucFun ARsin_poly (ARsin_poly_iter n' x)
  end.

Definition AQsin_bounded {n : nat} {num den : AQ}
           (Pnd : - (den * 3^n) ≤ num ≤ den * 3^n)
           (dpos : 0 < den * 3^n) : msp_car AR
  := ARsin_poly_iter n (AQsin_small Pnd dpos).

Lemma ARsin_poly_iter_wd : forall n x y,
    x = y -> ARsin_poly_iter n x = ARsin_poly_iter n y.
Proof.
  induction n.
  - intros. exact H5.
  - intros.
    change (ucFun ARsin_poly (ARsin_poly_iter n x)
            = ucFun ARsin_poly (ARsin_poly_iter n y)).
    rewrite (IHn x y H5).
    reflexivity.
Qed.

Lemma AQsin_bounded_correct {n : nat} {num den : AQ}
      (Pnd : -(den * 3^n) ≤ num ≤ den * 3^n) (dpos : 0 < den * 3^n) :
  'AQsin_bounded Pnd dpos = rational_sin ('num / 'den).
Proof.
  revert num den dpos Pnd.
  induction n; intros.
  - unfold AQsin_bounded. simpl.
    rewrite AQsin_small_correct.
    change (3^0%nat) with 1.
    rewrite rings.mult_1_r. reflexivity.
  - unfold AQsin_bounded.
    change (' ucFun ARsin_poly (ARsin_poly_iter n (AQsin_small Pnd dpos))
            = rational_sin (' num / ' den)).
    rewrite ARtoCR_preserves_sin_poly.
    unfold AQsin_bounded in IHn.
    assert (le (-(den * 3 * 3 ^ n)) num /\ num ≤ den * 3 * 3 ^ n) as H5.
    { rewrite <- (associativity den 3). exact Pnd. }
    assert (0 < den * 3 * 3 ^ n) as H6.
    { rewrite <- (associativity den 3). exact dpos. }
    setoid_replace (ARsin_poly_iter n (AQsin_small Pnd dpos))
      with (ARsin_poly_iter n (AQsin_small H5 H6)).
    rewrite IHn.
    change (Qdiv ('num) ('(den * 3))) with (('num : Q) / '(den * 3)).
    rewrite rings.preserves_mult, rings.preserves_3.
    rewrite dec_fields.dec_recip_distr, associativity.
    apply rational_sin_poly.
    apply ARsin_poly_iter_wd.
    apply AQsin_small_pos_wd. reflexivity.
    rewrite <- (associativity den 3). reflexivity.
Qed.

Definition AQsin_bound (a : AQ) : nat := CRsin.sin_bound ('a).

Lemma AQsin_bound_correct : forall (a:AQ),
    -(1 * 3 ^ AQsin_bound a) ≤ a ≤ 1 * 3 ^ AQsin_bound a.
Proof.
  intro a. unfold AQsin_bound.
  pose proof (CRsin.sin_bound_correct ('a)).
  split; apply (order_reflecting (cast AQ Q)).
  - rewrite rings.preserves_negate.
    destruct H4, aq_ring, ring_monoid.
    destruct commonoid_mon. rewrite monoid_left_id.
    rewrite preserves_nat_pow.
    rewrite rings.preserves_3.
    rewrite <-(int_pow_nat_pow (f:=cast nat Z)).
    rewrite <- (Zpower_Qpower 3).
    apply H5. apply (Nat2Z.inj_le 0), le_0_n.
  - destruct H4, aq_ring, ring_monoid.
    destruct commonoid_mon. rewrite monoid_left_id.
    rewrite preserves_nat_pow.
    rewrite rings.preserves_3.
    rewrite <-(int_pow_nat_pow (f:=cast nat Z)).
    rewrite <- (Zpower_Qpower 3).
    apply H5. apply (Nat2Z.inj_le 0), le_0_n.
Qed.

Lemma AQsin_bound_pos : forall a, 0 < 1 * 3 ^ AQsin_bound a.
Proof.
  intro a.
  destruct H4, aq_ring, ring_monoid.
  destruct commonoid_mon. rewrite monoid_left_id.
  apply (strictly_order_reflecting (cast AQ Q)).
  rewrite preserves_nat_pow.
  rewrite rings.preserves_3.
  rewrite <- (int_pow_nat_pow (f:=cast nat Z)).
  rewrite rings.preserves_0.
  apply (Qpower_0_lt 3 (Z.of_nat (AQsin_bound a))).
  reflexivity.
Qed.

Definition AQsin (a:AQ) : msp_car AR
  := AQsin_bounded (AQsin_bound_correct a) (AQsin_bound_pos a).

Lemma AQsin_correct : forall a, 'AQsin a = rational_sin ('a).
Proof.
  intro a.
  mc_setoid_replace ('a : Q) with ('a / '1 : Q).
   now apply AQsin_bounded_correct.
  rewrite rings.preserves_1, dec_fields.dec_recip_1.
  rewrite Qmult_1_r. reflexivity.
Qed.

Lemma AQsin_prf {a : AQ} (pA : ¬0 ≤ a) : 0 ≤ -a.
Proof. apply rings.flip_nonpos_negate. now apply orders.le_flip. Qed.

Definition ARsin_uc : msp_car (AQ_as_MetricSpace --> AR)
  := unary_complete_uc
       QPrelengthSpace (cast AQ (msp_car Q_as_MetricSpace)) AQsin sin_uc AQsin_correct.

Definition ARsin : msp_car (AR --> AR)
  := Cbind AQPrelengthSpace ARsin_uc.

Lemma ARtoCR_preserves_sin x : ' ucFun ARsin x = ucFun sin_slow ('x).
Proof. apply preserves_unary_complete_fun. Qed.

End ARsin.


(* Preprocessing OT example,
  as in https://www.cs.umd.edu/~jkatz/gradcrypto2/f13/lecture5.pdf .

   In preprocessing OT, we show that the sender and receiver
can leverage an initial OT on two uniform bitstrings to perform an OT later on. This is advantageous, because the 'online' part can be done very fast (it only requires xor), while the 'offline' part requires expensive cryptography.

 The protocol is proven semi-honest secure, in the case when
the receiver is corrupt.

 *)

Require Import List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core Ipdl.Lems Lib.TupleLems Lib.Dist Ipdl.Tacs Pars Big.
Require Import OTIdeal Lib.Set Typ Lib.SeqOps.
Require Import Permutation.

Open Scope bool_scope.

Lemma new_pars_undep {chan} {t1 t2} (c2 : chan t2) (rs : chan t1 -> seq ipdl) r r' :
  (forall (t : Type) (c0 : chan t), can_read c0 r -> reads_from c0 r') ->
  (c1 <- new t1 ;; pars [:: Out c2 (_ <-- Read c1 ;; r'), Out c1 r & rs c1]) =p
  (c1 <- new t1 ;; pars [:: Out c2 (r'), Out c1 r & rs c1]) .
  intros.
  apply EqCongNew => c1.
  symmetry.
  apply pars_mkdep; rewrite //=.
Qed.

Section OTPre.
  Context {chan : Type -> Type}.
  (* OT Channels *)
  Context (L : nat) (m : chan (L.-bv * L.-bv)) (i : chan bool) (o : chan L.-bv).

  (* We assume that B, the receiver in the top-level OT protocol, is semi-honest. *)

  Context (leakC : chan bool) (leak_base_o : chan L.-bv) (leaky : chan (L.-bv * L.-bv)).

  Definition OTPreA (base_m : chan (L.-bv * L.-bv)) (y : chan (L.-bv * L.-bv)) (z : chan bool) :=
    k <- new (L.-bv * L.-bv) ;;
    pars [::
            k ::= (Samp Unif);
            base_m ::= (copy k);
            y ::= (
                  m01 <-- Read m ;;
                  k01 <-- Read k ;;
                  z <-- Read z ;;
                  Ret ([pair i => (m01 # i) +t (k01 # (i (+) z)) ] )) ].

  Definition OTPreB (base_i : chan bool) (base_o : chan L.-bv) (y : chan (L.-bv * L.-bv)) (z : chan bool) :=
    c <- new bool ;;
    pars [::
            c ::= (Samp Unif) ;
            leakC ::= (copy c) ;
            base_i ::= (copy c) ;
            leak_base_o ::= (copy base_o) ;
            z ::= (
                  i <-- Read i ;;
                  c <-- Read c ;;
                  Ret (i (+) c) );
            leaky ::= (copy y);
            o ::= (
                  b <-- Read i ;;
                  y01 <-- Read y ;;
                  k_c <-- Read base_o ;;
                  Ret (((y01 # b) +t k_c)) ) ].

(* ******     *)

  Definition OTPre_Sim (leako : chan L.-bv)
    :=
  j <- new L.-bv ;;
  pars [::
          Out leaky (
            j <-- Read j ;;
            i <-- Read i ;;
            o <-- Read leako ;;
            x <-- Samp Unif ;;
            Ret (
                if i then (x, o +t j) else (o +t j, x) ) );
          Out leakC (Samp Unif) ;
          Out j (Samp Unif) ;
          Out leak_base_o (copy j)
          ].

  Ltac perm_swap_l n m :=
    match goal with
      | [ |- Permutation ?xs _] =>
        rewrite (Perm_swap n m xs); rewrite /swap //= /lset //= end.

  Lemma OTPre_sim_t leako :
    ipdl_t [:: tag leaky; tag leakC; tag leak_base_o] (OTPre_Sim leako).
    rewrite /OTPre_Sim.
    repeat type_tac.
    perm_swap_l 0 1.
    perm_swap_l 1 2.
  Qed.

  Definition OTPre :=
    y <- new (L.-bv * L.-bv) ;;
    z <- new bool ;;
    base_i <- new bool ;;
    base_o <- new L.-bv ;;
    base_m <- new (L.-bv * L.-bv) ;;
    pars [::
            OTPreA base_m y z;
            OTPreB base_i base_o y z;
            OTIdeal _ base_i base_m base_o ].

  Lemma OTPre_eq :
    OTPre =p
             (leako <- new L.-bv ;;
              pars [::
                      OTIdeal _ i m o;
                      OTIdeal _ i m leako;
                      OTPre_Sim leako]).
    unfold OTPre.
    etransitivity.
    rewrite /OTPreA.
    setoid_rewrite newPars.
    setoid_rewrite pars_pars; simpl.
    rewrite /OTPreB.
    swap_tac 0 3.
    setoid_rewrite newPars.
    setoid_rewrite pars_pars; simpl.
    rewrite /OTIdeal.
    setoid_rewrite (EqNewExch (L.-bv * L.-bv) (L.-bv * L.-bv)).
    setoid_rewrite (EqNewExch (L.-bv * L.-bv) bool) at 2.
    swap_tac 0 10.
    under_new swap_at 0 0 1.
    simpl.
    swap_tac 1 7.
    setoid_rewrite pars_fold.
    swap_tac 0 1.
    swap_tac 0 2.
    setoid_rewrite (EqNewExch L.-bv (L.-bv * L.-bv)).
    setoid_rewrite (EqNewExch L.-bv bool).
    under_new rewrite new_pars_inline; [ apply EqRefl | done].
    under_new simp_at 0.
    simpl.
    swap_tac 0 5.
    under_new swap_at 0 0 2.
    simpl.
    setoid_rewrite pars_fold.
    under_new simp_at 0.
    under_new swap_at 0 0 1.
    simpl.
    setoid_rewrite (EqNewExch bool (L.-bv * L.-bv)).
    setoid_rewrite (EqNewExch bool bool).
    under_new rewrite new_pars_inline; [ apply EqRefl | done].
    simpl.
    swap_tac 0 4.
    under_new swap_at 0 0 1.
    simpl.
    setoid_rewrite pars_fold.
    setoid_rewrite (EqNewExch (L.-bv * L.-bv) bool).
    setoid_rewrite (EqNewExch (L.-bv * L.-bv) (L.-bv * L.-bv)).
    setoid_rewrite (EqNewExch (L.-bv * L.-bv) bool).
    swap_tac 0 2.
    swap_tac 1 5.
    under_new rewrite new_pars_inline; [ apply EqRefl | done].
    under_new simp_at 0.
    simpl.
    swap_tac 0 3.
    under_new swap_at 0 0 3.
    simpl.
    setoid_rewrite pars_fold.
    under_new simp_at 0.
    setoid_rewrite (EqNewExch bool (L.-bv * L.-bv)).
    setoid_rewrite (EqNewExch bool bool).
    swap_tac 1 4.
    under_new swap_at 0 0 2.
    under_new rewrite new_pars_inline; [ apply EqRefl | done].
    under_new simp_at 0.
    simpl.
    swap_tac 0 2.
    under_new swap_at 0 0 2.
    simpl.
    setoid_rewrite pars_fold.
    under_new simp_at 0.
    simpl.
    swap_tac 0 1.
    apply EqCongNew => c .
    apply EqCongNew => d .
    edit_tac 0.
    (* Simplifying o *)
        r_swap 1 6.
        rewrite EqReadSame.
        apply EqBind_r => x_i.
        r_swap 1 3.
        rewrite /copy.
        simp_rxn.
        rewrite EqReadSame.
        apply EqBind_r => x_d.
        apply EqBind_r => x_m.
        rewrite EqReadSame.
        apply EqBind_r => x_c.
        instantiate (1 := fun _ =>
                       Ret (if x_i then x_m.2 else x_m.1)).
        simpl.
        destruct (x_i), x_d; simpl; rewrite xortA xortK xort0; done.
        apply EqRefl.
        apply _.
        apply _.
   simpl; swap_tac 1 5.
   under_new swap_at 0 0 1.
   under_new rewrite new_pars_undep; rewrite //=.
   apply EqRefl.
   rewrite EqNewExch.
   swap_tac 1 4.
   under_new swap_at 0 0 2.
   under_new rewrite new_pars_undep; rewrite //=.
   apply EqRefl.
   (* Rerandomize c1 *)
   etransitivity.
        apply EqCongNew => c .
        swap_tac 0 1.
        swap_tac 1 4.
        etransitivity.
        apply EqCongNew => c1 .
        rewrite pars_mkdep //=.
        apply pars_cons_cong.
        instantiate ( 1 :=
                       Out c1 (b <-- Read c ;;
                               x <-- Samp Unif  ;;
                               y <-- Samp Unif ;;
                               Ret (if b then (y, x) else (x, y) ))).
        apply EqCongReact.
        apply EqBind_r => x.
        destruct x.
        etransitivity.
        rewrite EqSampBind.
        apply EqBind_r => x.
        rewrite EqSampBind.
        apply EqBind_r => y.
        rewrite EqSampRet //=.
        apply EqRxnRefl.
        r_swap 0 1.
        apply EqBind_r => x.
        apply EqBind_r => y.
        done.

        etransitivity.
        rewrite EqSampBind.
        apply EqBind_r => x.
        rewrite EqSampBind.
        apply EqBind_r => y.
        rewrite EqSampRet //=.
        apply EqRxnRefl.
        apply EqBind_r => x.
        apply EqBind_r => y.
        done.
        done.

        under_new swap_at 0 0 1.
        setoid_rewrite <- pars_fold at 1.
        under_new swap_at 0 0 2.
        simpl; setoid_rewrite <- pars_fold at 1.
        swap_tac 0 1.
        swap_tac 0 5.
        under_new swap_at 0 0 1.
        setoid_rewrite (EqNewExch (L.-bv * L.-bv) L.-bv) at 1.
        setoid_rewrite (EqNewExch (L.-bv * L.-bv) L.-bv) at 1.
        unfold copy.
        under_new simp_at 0.
        under_new rewrite new_pars_inline; [ apply EqRefl | done].
        under_new simp_at 0.
        simpl;swap_tac 0 7.
        under_new swap_at 0 0 3.
        simpl; setoid_rewrite pars_fold at 1.
        under_new simp_at 0.

        (* now inline the new defs *)
        etransitivity.
        apply EqCongNew => c0 .
        apply EqCongNew => c1 .
        swap_tac 0 6.
        edit_tac 0.
        apply EqBind_r => x.
        apply EqBind_r => y.
        rewrite EqReadSame.
        apply EqBind_r => b.
        instantiate (1 := fun _ => Ret y).
        simpl.
        destruct b; simpl; done.
        swap_tac 1 2.
        swap_at 0 0 2.
        rewrite -pars_mkdep //=.
        swap_tac 1 4.
        rewrite -pars_mkdep //=.
        apply EqRefl.
        simpl; swap_tac 0 6.
        setoid_rewrite pars_fold at 1.

        (* Now rerandomize leaky *)
        apply EqCongNew => c0 .
        edit_tac 0.
        r_swap 0 5.
        r_swap 0 5.
        r_swap 0 5.
        r_swap 0 5.
        r_swap 0 5.
        r_swap 0 3.
        r_swap 1 2.
        rewrite EqReadSame.
        apply EqBind_r => xc.
        apply EqBind_r => xc0.
        apply EqBind_r => xi.
        apply EqBind_r => xm.
        unfold mkpair; simpl.
        instantiate (1 := fun xm =>
                       x <-- Samp (@Unif [finType of L.-bv] _)  ;;
                       Ret (if xi then _ else _ )).
        simpl.
        destruct xc.
        rewrite addbT negbK.
        destruct xi; simpl.
        symmetry.

        instantiate (1 := (x, xm.2 +t xc0)).

        rewrite (EqBind_r_samp_bijection _ _ _ _ (fun (x : L.-bv) => xm.1 +t x)) //=.
        apply uniform_Unif.
        apply xort_inj_l.

        instantiate (1 := (xm.1 +t xc0, x)).
        rewrite (EqBind_r_samp_bijection _ _ _ _ (fun (x : L.-bv) => xm.2 +t x)) //=.
        apply EqBind_r; intro.
        rewrite -xortA xortK (xortC (tzero _)) xort0 //=.
        apply uniform_Unif.
        apply xort_inj_l.

        destruct xi; simpl.

        symmetry.
        rewrite (EqBind_r_samp_bijection _ _ _ _ (fun (x : L.-bv) => xm.1 +t x)) //=.
        apply uniform_Unif.
        apply xort_inj_l.

        symmetry.
        rewrite (EqBind_r_samp_bijection _ _ _ _ (fun (x : L.-bv) => xm.2 +t x)) //=.
        apply uniform_Unif.
        apply xort_inj_l.

        swap_tac 1 3.
        rewrite -pars_mkdep //=.
        apply EqRefl.
        rewrite EqNewExch.
        swap_tac 0 2.
        setoid_rewrite pars_fold.

   (**  Now working on ideal world **)
   symmetry.
   unfold OTIdeal, OTPre_Sim.
   swap_tac 0 2.
   setoid_rewrite newPars.
   setoid_rewrite pars_pars; simpl.
   setoid_rewrite (EqNewExch L.-bv L.-bv).
   under_new swap_at 0 0 2.
   simpl; swap_tac 1 4.
   setoid_rewrite pars_fold.
   under_new simp_at 0.
   apply EqCongNew => c .
   symmetry; swap_tac 0 1; symmetry.

   (* Now matching up *)
   apply pars_cons_cong.
   apply EqCongReact.
   r_swap 1 3.
   rewrite EqReadSame.
   r_swap 0 2.
   apply EqBind_r => xc.
   apply EqBind_r => xi.
   apply EqBind_r => xm.
   apply EqBind_r => b.
   destruct xi; simpl.
   rewrite xortC; done.
   rewrite xortC; done.
   swap_tac 0 2; apply pars_cons_cong.
   symmetry; apply EqCongReact; rewrite EqBindRet; done.
   swap_tac 0 1; apply pars_cons_cong.
   done.
   swap_tac 0 1; apply pars_cons_cong.
   done.
   done.
   apply _.
 Qed.

Lemma OTPre_t : ipdl_t [:: tag o; tag leak_base_o; tag leaky; tag leakC] OTPre.
  rewrite /OTPre /OTPreA /OTPreB /OTIdeal.
  repeat type_tac.
  perm_match.
Qed.

  End OTPre.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* ** Hilbert's tenth problem is undecidable *)

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac.

From Undecidability.Synthetic Require Import Undecidability.
Require Import Undecidability.Synthetic.ReducibilityFacts.

Require Import Undecidability.TM.TM.

Require Import Undecidability.PCP.PCP.
Require Import Undecidability.PCP.Reductions.HaltTM_1_to_PCPb.

From Undecidability.MinskyMachines
  Require Import MM PCPb_to_MM.

From Undecidability.FRACTRAN
  Require Import FRACTRAN FRACTRAN_undec MM_FRACTRAN.

From Undecidability.H10
  Require Import H10 FRACTRAN_DIO.

From Undecidability.H10.Dio
  Require Import dio_logic dio_elem dio_single.

Import ReductionChainNotations UndecidabilityNotations.

Require Import Undecidability.TM.TM_undec.

Set Implicit Arguments.

Theorem DIO_SINGLE_SAT_H10 : DIO_SINGLE_SAT ⪯ H10.
Proof.
  apply reduces_dependent; exists.
  intros (E,v).
  destruct (dio_poly_eq_pos E) as (n & p & q & H).
  exists (existT _ n (dp_inst_par _ v p, dp_inst_par _ v q)).
  unfold DIO_SINGLE_SAT, H10.
  rewrite H.
  unfold dio_single_pred.
  split; intros (phi & H1); exists phi; revert H1; cbn;
    rewrite !dp_inst_par_eval; auto.
Qed.

Check FRACTRAN_undec.

(* DLW: Below is a prefered identical statement with a nice notation
    tactic proposed by M. Wuttke

Theorem Hilberts_Tenth : HaltTM 1 ⪯ PCPb
                      /\ PCPb ⪯ MM_HALTING
                      /\ MM_HALTING ⪯ FRACTRAN_HALTING
                      /\ FRACTRAN_HALTING ⪯ DIO_LOGIC_SAT
                      /\ DIO_LOGIC_SAT ⪯ DIO_ELEM_SAT
                      /\ DIO_ELEM_SAT ⪯ DIO_SINGLE_SAT
                      /\ DIO_SINGLE_SAT ⪯ H10.
*)

(*
  reduction chain as described in
    Dominique Larchey-Wendling, Yannick Forster:
    Hilbert's Tenth Problem in Coq. FSCD 2019: 27:1-27:20
*)

Theorem Hilberts_Tenth :
  ⎩ HaltTM 1 ⪯ₘ PCPb ⪯ₘ MM_HALTING ⪯ₘ FRACTRAN_HALTING ⪯ₘ DIO_LOGIC_SAT ⪯ₘ DIO_ELEM_SAT ⪯ₘ DIO_SINGLE_SAT ⪯ₘ H10 ⎭.
Proof.
  msplit 6.
  + apply HaltTM_1_to_PCPb.
  + apply PCPb_MM_HALTING.
  + apply MM_FRACTRAN_HALTING.
  + apply FRACTRAN_HALTING_DIO_LOGIC_SAT.
  + apply DIO_LOGIC_ELEM_SAT.
  + apply DIO_ELEM_SINGLE_SAT.
  + apply DIO_SINGLE_SAT_H10.
Qed.

Check Hilberts_Tenth.

Theorem H10_undec : undecidable H10.
Proof.
  apply (undecidability_from_reducibility HaltTM_1_undec).
  reduce with chain Hilberts_Tenth.
Qed.

Check H10_undec.


Require Export atomicsyntax implicativesyntax universalsyntax conjunctivesyntax disjunctivesyntax existentialsyntax termsyntax.

Section form.
Context {Sigma : Signature}.
Inductive form  : Type :=
  | In_form_atomic : ( form_atomic   ) -> form
  | In_form_implicative : ( form_implicative form  ) -> form
  | In_form_universal : ( form_universal form  ) -> form
  | In_form_conjunctive : ( form_conjunctive form  ) -> form
  | In_form_disjunctive : ( form_disjunctive form  ) -> form
  | In_form_existential : ( form_existential form  ) -> form .

Lemma congr_In_form_atomic  { s0 : form_atomic   } { t0 : form_atomic   } (H1 : s0 = t0) : In_form_atomic  s0 = In_form_atomic  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_implicative  { s0 : form_implicative form  } { t0 : form_implicative form  } (H1 : s0 = t0) : In_form_implicative  s0 = In_form_implicative  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_universal  { s0 : form_universal form  } { t0 : form_universal form  } (H1 : s0 = t0) : In_form_universal  s0 = In_form_universal  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_conjunctive  { s0 : form_conjunctive form  } { t0 : form_conjunctive form  } (H1 : s0 = t0) : In_form_conjunctive  s0 = In_form_conjunctive  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_disjunctive  { s0 : form_disjunctive form  } { t0 : form_disjunctive form  } (H1 : s0 = t0) : In_form_disjunctive  s0 = In_form_disjunctive  t0 .
Proof. congruence. Qed.

Lemma congr_In_form_existential  { s0 : form_existential form  } { t0 : form_existential form  } (H1 : s0 = t0) : In_form_existential  s0 = In_form_existential  t0 .
Proof. congruence. Qed.

Global Instance retract_form_universal_form  : retract (form_universal form) form := Build_retract In_form_universal (fun x => match x with
| In_form_universal s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_universal t'  => fun H => congr_In_form_universal ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_implicative_form  : retract (form_implicative form) form := Build_retract In_form_implicative (fun x => match x with
| In_form_implicative s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_implicative t'  => fun H => congr_In_form_implicative ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_existential_form  : retract (form_existential form) form := Build_retract In_form_existential (fun x => match x with
| In_form_existential s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_existential t'  => fun H => congr_In_form_existential ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_disjunctive_form  : retract (form_disjunctive form) form := Build_retract In_form_disjunctive (fun x => match x with
| In_form_disjunctive s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_disjunctive t'  => fun H => congr_In_form_disjunctive ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_conjunctive_form  : retract (form_conjunctive form) form := Build_retract In_form_conjunctive (fun x => match x with
| In_form_conjunctive s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_conjunctive t'  => fun H => congr_In_form_conjunctive ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Global Instance retract_form_atomic_form  : retract (form_atomic ) form := Build_retract In_form_atomic (fun x => match x with
| In_form_atomic s  => Datatypes.Some s
| _ => Datatypes.None
end) (fun s => eq_refl) (fun s t => match t with
| In_form_atomic t'  => fun H => congr_In_form_atomic ((eq_sym) (Some_inj H))
| _ => some_none_explosion
end) .

Fixpoint subst_form   (sigmaterm : ( fin ) -> term ) (s : form ) : form  :=
    match s return form  with
    | In_form_atomic  s0 =>   subst_form_atomic form _ sigmaterm s0
    | In_form_implicative  s0 =>   subst_form_implicative form subst_form _ sigmaterm s0
    | In_form_universal  s0 =>   subst_form_universal form subst_form _ sigmaterm s0
    | In_form_conjunctive  s0 =>   subst_form_conjunctive form subst_form _ sigmaterm s0
    | In_form_disjunctive  s0 =>   subst_form_disjunctive form subst_form _ sigmaterm s0
    | In_form_existential  s0 =>   subst_form_existential form subst_form _ sigmaterm s0
    end.

Fixpoint idSubst_form  (sigmaterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = (var_term ) x) (s : form ) : subst_form sigmaterm s = s.
Proof. destruct s;
  [ eapply idSubst_form_atomic
  | eapply idSubst_form_implicative
  | eapply idSubst_form_universal
  | eapply idSubst_form_conjunctive
  | eapply idSubst_form_disjunctive
  | eapply idSubst_form_existential
  ]; eauto.
Defined.
(*
Fixpoint ext_form   (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (Eqterm : forall x, sigmaterm x = tauterm x) (s : form ) : subst_form sigmaterm s = subst_form tauterm s :=
    match s return subst_form sigmaterm s = subst_form tauterm s with
    | In_form_atomic  s0 =>  ((ext_form_atomic form sigmaterm tauterm Eqterm) s0)
    | In_form_implicative  s0 =>  ((ext_form_implicative form sigmaterm tauterm Eqterm) s0)
    | In_form_universal  s0 =>  ((ext_form_universal form up_term_form upExt_term_form sigmaterm tauterm Eqterm) s0)
    | In_form_conjunctive  s0 =>  ((ext_form_conjunctive form sigmaterm tauterm Eqterm) s0)
    | In_form_disjunctive  s0 =>  ((ext_form_disjunctive form sigmaterm tauterm Eqterm) s0)
    | In_form_existential  s0 =>  ((ext_form_existential form up_term_form upExt_term_form sigmaterm tauterm Eqterm) s0)
    end.
*)
Fixpoint compSubstSubst_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (thetaterm : ( fin ) -> term ) (Eqterm : forall x, ((funcomp) (subst_term tauterm) sigmaterm) x = thetaterm x) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form thetaterm s.
Proof. destruct s;
  [ eapply compSubstSubst_form_atomic
  | eapply compSubstSubst_form_implicative
  | eapply compSubstSubst_form_universal
  | eapply compSubstSubst_form_conjunctive
  | eapply compSubstSubst_form_disjunctive
  | eapply compSubstSubst_form_existential
  ]; eauto.
Defined.

Lemma instId_form  : subst_form (var_term ) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_form (var_term ) (fun n => eq_refl) ((id) x))). Qed.

Lemma compComp_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) (s : form ) : subst_form tauterm (subst_form sigmaterm s) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) s .
Proof. exact (compSubstSubst_form sigmaterm tauterm (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_form    (sigmaterm : ( fin ) -> term ) (tauterm : ( fin ) -> term ) : (funcomp) (subst_form tauterm) (subst_form sigmaterm) = subst_form ((funcomp) (subst_term tauterm) sigmaterm) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_form sigmaterm tauterm n)). Qed.

(*
Global Instance Subst_term   : Subst1 (( fin ) -> term ) (term ) (term ) := @subst_term   .

Global Instance Subst_form   : Subst1 (( fin ) -> term ) (form ) (form ) := @subst_form   .

Global Instance VarInstance_term  : Var (fin) (term ) := @var_term  .

Notation "x '__term'" := (var_term x) (at level 5, format "x __term") : subst_scope.

Notation "x '__term'" := (@ids (_) (_) VarInstance_term x) (at level 5, only printing, format "x __term") : subst_scope.

Notation "'var'" := (var_term) (only printing, at level 1) : subst_scope.

Class Up_term X Y := up_term : ( X ) -> Y.

Notation "↑__term" := (up_term) (only printing) : subst_scope.

Notation "↑__term" := (up_term_term) (only printing) : subst_scope.

Global Instance Up_term_term   : Up_term (_) (_) := @up_term_term   .

Notation "s [ sigmaterm ]" := (subst_term sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_term sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_universal sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_universal sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_implicative sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_implicative sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_existential sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_existential sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_disjunctive sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_disjunctive sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_conjunctive sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_conjunctive sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form_atomic sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form_atomic sigmaterm) (at level 1, left associativity, only printing) : fscope.

Notation "s [ sigmaterm ]" := (subst_form sigmaterm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmaterm ]" := (subst_form sigmaterm) (at level 1, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_term,  Subst_form,  VarInstance_term.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_term,  Subst_form,  VarInstance_term in *.
 *)

End form.

(* Ltac asimpl' := repeat first [progress rewrite ?instId_term| progress rewrite ?compComp_term| progress rewrite ?compComp'_term| progress rewrite ?instId_form_universal| progress rewrite ?compComp_form_universal| progress rewrite ?compComp'_form_universal| progress rewrite ?instId_form_implicative| progress rewrite ?compComp_form_implicative| progress rewrite ?compComp'_form_implicative| progress rewrite ?instId_form_existential| progress rewrite ?compComp_form_existential| progress rewrite ?compComp'_form_existential| progress rewrite ?instId_form_disjunctive| progress rewrite ?compComp_form_disjunctive| progress rewrite ?compComp'_form_disjunctive| progress rewrite ?instId_form_conjunctive| progress rewrite ?compComp_form_conjunctive| progress rewrite ?compComp'_form_conjunctive| progress rewrite ?instId_form_atomic| progress rewrite ?compComp_form_atomic| progress rewrite ?compComp'_form_atomic| progress rewrite ?instId_form| progress rewrite ?compComp_form| progress rewrite ?compComp'_form| progress rewrite ?varL_term| progress (unfold up_ren, up_term_term)| progress (cbn [subst_term subst_form_universal subst_form_implicative subst_form_existential subst_form_disjunctive subst_form_conjunctive subst_form_atomic subst_form])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_term in *| progress rewrite ?compComp_term in *| progress rewrite ?compComp'_term in *| progress rewrite ?instId_form_universal in *| progress rewrite ?compComp_form_universal in *| progress rewrite ?compComp'_form_universal in *| progress rewrite ?instId_form_implicative in *| progress rewrite ?compComp_form_implicative in *| progress rewrite ?compComp'_form_implicative in *| progress rewrite ?instId_form_existential in *| progress rewrite ?compComp_form_existential in *| progress rewrite ?compComp'_form_existential in *| progress rewrite ?instId_form_disjunctive in *| progress rewrite ?compComp_form_disjunctive in *| progress rewrite ?compComp'_form_disjunctive in *| progress rewrite ?instId_form_conjunctive in *| progress rewrite ?compComp_form_conjunctive in *| progress rewrite ?compComp'_form_conjunctive in *| progress rewrite ?instId_form_atomic in *| progress rewrite ?compComp_form_atomic in *| progress rewrite ?compComp'_form_atomic in *| progress rewrite ?instId_form in *| progress rewrite ?compComp_form in *| progress rewrite ?compComp'_form in *| progress rewrite ?varL_term in *| progress (unfold up_ren, up_term_term in * )| progress (cbn [subst_term subst_form_universal subst_form_implicative subst_form_existential subst_form_disjunctive subst_form_conjunctive subst_form_atomic subst_form] in * )| fsimpl in *].
 *)

Ltac substify := auto_unfold.

Ltac renamify := auto_unfold.