Require Export Coq.ZArith.BinIntDef.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Logic.Eqdep_dec.
Require Import bbv.ZLib.
Require Import bbv.ZHints.
Require Import bbv.N_Z_nat_conversions.
Require bbv.Word.
Require Import riscv.util.ZBitOps.
Require Import riscv.util.prove_Zeq_bitwise.
Require Import riscv.util.Tactics.
Require Import riscv.util.div_mod_to_quot_rem.
Local Open Scope Z_scope.

(** The two axioms [uwordToZ_ZToWord] and [ZToWord_uwordToZ] fully specify the data type
    [word sz] with respect to its constructor [ZToWord] and its destructor [uwordToZ].
    Therefore, we will never have to unfold [ZToWord] or [uwordToZ] in the word library. *)
Module Type WORD.

  Parameter word: Z -> Set.

  Parameter ZToWord: forall (sz: Z) (x: Z), word sz.

  Parameter uwordToZ: forall {sz: Z} (w: word sz), Z.

  Axiom uwordToZ_ZToWord: forall sz n,
    uwordToZ (ZToWord sz n) = n mod 2 ^ sz.

  Axiom ZToWord_uwordToZ: forall {sz: Z} (a : word sz),
    ZToWord sz (uwordToZ a) = a.

End WORD.

Module Word(W: WORD).
  Export W.

  Section Derived.

    Context {sz: Z}.

    Lemma uwordToZ_inj: forall {a b: word sz},
        uwordToZ a = uwordToZ b -> a = b.
    Proof.
      intros.
      rewrite <- (ZToWord_uwordToZ a).
      rewrite <- (ZToWord_uwordToZ b).
      f_equal.
      assumption.
    Qed.

    Lemma mod_eq_ZToWord_eq: forall {a b: Z},
        a mod 2 ^ sz = b mod 2 ^ sz ->
        ZToWord sz a = ZToWord sz b.
    Proof.
      intros.
      apply uwordToZ_inj.
      rewrite? uwordToZ_ZToWord.
      assumption.
    Qed.

    Lemma ZToWord_eq_mod_eq: forall {a b: Z},
        ZToWord sz a = ZToWord sz b ->
        a mod 2 ^ sz = b mod 2 ^ sz.
    Proof.
      intros.
      rewrite <-? uwordToZ_ZToWord.
      f_equal.
      assumption.
    Qed.

    Lemma uwordToZ_mod: forall (a: word sz),
        uwordToZ a mod 2 ^ sz = uwordToZ a.
    Proof.
      intros.
      rewrite <- (ZToWord_uwordToZ a) at 2.
      rewrite uwordToZ_ZToWord.
      reflexivity.
    Qed.

    Lemma uwordToZ_ne: forall {a b: word sz},
        uwordToZ a <> uwordToZ b ->
        a <> b.
    Proof.
      intros a b E C. apply E. f_equal. assumption.
    Qed.

  End Derived.

  Definition wmsb{sz: Z}(a: word sz): bool := Z.testbit (uwordToZ a) (sz - 1).

  Definition swordToZ{sz: Z}(a: word sz): Z :=
    if wmsb a then uwordToZ a - 2 ^ sz else uwordToZ a.

  Definition wu_unop(f: Z -> Z)(sz: Z)(a: word sz): word sz :=
    ZToWord sz (f (uwordToZ a)).

  Definition wu_binop(f: Z -> Z -> Z)(sz: Z)(a b: word sz): word sz :=
    ZToWord sz (f (uwordToZ a) (uwordToZ b)).

  Definition wu_binop_t{T: Type}(f: Z -> Z -> T)(sz: Z)(a b: word sz): T :=
    f (uwordToZ a) (uwordToZ b).

  Definition ws_unop(f: Z -> Z)(sz: Z)(a: word sz): word sz :=
    ZToWord sz (f (swordToZ a)).

  Definition ws_binop(f: Z -> Z -> Z)(sz: Z)(a b: word sz): word sz :=
    ZToWord sz (f (swordToZ a) (swordToZ b)).

  Definition ws_binop_t{T: Type}(f: Z -> Z -> T)(sz: Z)(a b: word sz): T :=
    f (swordToZ a) (swordToZ b).

  Hint Unfold wmsb swordToZ
       wu_unop wu_binop wu_binop_t
       ws_unop ws_binop ws_binop_t
       proj1_sig
    : unf_word_all.

  Section ArithOps.

    Context {sz: Z}.

    Definition wopp := ws_unop Z.opp sz.

    Definition wadd := wu_binop Z.add sz.
    Definition wsub := wu_binop Z.sub sz.
    Definition wmul := wu_binop Z.mul sz.

    Definition wsadd := ws_binop Z.add sz.
    Definition wssub := ws_binop Z.sub sz.
    Definition wsmul := ws_binop Z.mul sz.

  End ArithOps.

  Hint Unfold wopp wadd wsub wmul wsadd wssub wsmul : unf_word_all.

  Ltac make_mod_nonzero :=
    let C := fresh in
    match goal with
    | |- context [_ mod ?m] =>
      assert (m = 0 \/ m <> 0) as C by omega;
      destruct C as [C | C];
      [ rewrite C in *; rewrite? Zmod_0_r; reflexivity | ]
    end.

  Ltac mod0_exists_quotient H :=
    apply Z.mod_divide in H;
    [ let k := fresh "k" in let E := fresh "E" in unfold Z.divide in H; destruct H as [k E] | ].

  Lemma mod_eq_from_diff: forall {a b m: Z},
      (a - b) mod m = 0 ->
      a mod m = b mod m.
  Proof.
    intros.
    make_mod_nonzero.
    mod0_exists_quotient H; [|assumption].
    replace a with (b + k * m) by omega.
    apply Z_mod_plus_full.
  Qed.

  Lemma mod_eq_to_diff: forall {a b m : Z},
      a mod m = b mod m ->
      (a - b) mod m = 0.
  Proof.
    intros.
    make_mod_nonzero.
    apply Z.mod_divide; [assumption|].
    unfold Z.divide.
    div_mod_to_quot_rem.
    subst a b r0.
    exists (q - q0).
    ring.
  Qed.

  Ltac prove_mod_0 :=
    match goal with
    | |- ?a mod ?m = 0 => ring_simplify a
    end;
    rewrite? Zplus_mod_idemp_l;
    rewrite? Zplus_mod_idemp_r;
    rewrite? Zminus_mod_idemp_l;
    rewrite? Zminus_mod_idemp_r;
    rewrite? Zmult_mod_idemp_l;
    rewrite? Zmult_mod_idemp_r;
    match goal with
    | |- ?a mod ?m = 0 => ring_simplify a
    end;
    rewrite? Z.pow_2_r;
    first
      (* base cases: *)
      [ apply Z_mod_mult
      | apply Z_mod_mult'
      | apply Z_mod_same_full
      | apply Zmod_0_l
      (* cases with recursion (the last two might turn a true goal into a false one): *)
      | apply Z_mod_zero_opp_full
      | apply add_mod_0
      | apply sub_mod_0
(* | match goal with
      | |- ?G => fail 1000 "failed to solve" G
      end *)
      ];
    [> prove_mod_0 .. ].

  Ltac word_destruct :=
    intuition idtac;
    repeat autounfold with unf_word_all in *;
    repeat match goal with
           | w: word ?sz |- _ =>
             pose proof (ZToWord_uwordToZ w);
             pose proof (uwordToZ_mod w);
             let w' := fresh w in forget (uwordToZ w) as w'; subst w
           end;
    rewrite? uwordToZ_ZToWord in *;
    repeat match goal with
           | H: (?x =? ?y) = true |- _ =>
             apply Z.eqb_eq in H; try subst x; try subst y
           | H: ZToWord _ ?x = ZToWord _ ?y |- _ =>
             apply ZToWord_eq_mod_eq in H; try subst x; try subst y
           end;
    repeat match goal with
           | |- context[if ?b then _ else _] => let E := fresh "E" in destruct b eqn: E
           end.

  Ltac word_eq_pre :=
    repeat match goal with
           | H: ?a mod ?m = ?b mod ?m |- _ =>
             apply mod_eq_to_diff in H;
             match type of H with
             | ?a mod ?m = 0 => ring_simplify a in H
             end
           end;
    apply mod_eq_ZToWord_eq;
    auto;
    try match goal with
        | H: ?b mod ?m = ?b |- _  = ?b => refine (eq_trans _ H)
        end;
    try match goal with
        | H: ?a mod ?m = ?a |- ?a = _  => refine (eq_trans (eq_sym H) _)
        end;
    rewrite? Zplus_mod_idemp_l;
    rewrite? Zplus_mod_idemp_r;
    rewrite? Zminus_mod_idemp_l;
    rewrite? Zminus_mod_idemp_r;
    rewrite? Zmult_mod_idemp_l;
    rewrite? Zmult_mod_idemp_r;
    apply mod_eq_from_diff.

  Ltac word_solver := word_destruct; word_eq_pre; prove_mod_0.

  Section ArithOpsEquiv.

    Context {sz: Z}.

    Lemma wadd_wsadd: forall a b: word sz,
        wadd a b = wsadd a b.
    Proof. word_solver. Qed.

    Lemma wsub_wssub: forall a b: word sz,
        wsub a b = wssub a b.
    Proof. word_solver. Qed.

    Lemma wmul_wsmul: forall a b: word sz,
        wmul a b = wsmul a b.
    Proof. word_solver. Qed.

  End ArithOpsEquiv.

  Section MoreOps.

    Context {sz: Z}.

    Definition wudiv  := wu_binop Z.div sz.
    Definition wuquot := wu_binop Z.quot sz.
    Definition wumod  := wu_binop Z.modulo sz.
    Definition wurem  := wu_binop Z.rem sz.

    Definition wsdiv  := ws_binop Z.div sz.
    Definition wsquot := ws_binop Z.quot sz.
    Definition wsmod  := ws_binop Z.modulo sz.
    Definition wsrem  := ws_binop Z.rem sz.

    Definition wor   := wu_binop Z.lor sz.
    Definition wand  := wu_binop Z.land sz.
    Definition wxor  := wu_binop Z.lxor sz.

    Definition weqb := wu_binop_t Z.eqb sz.

    Definition weq_dec(x y: word sz): {x = y} + {x <> y}.
      destruct (Z.eq_dec (uwordToZ x) (uwordToZ y)).
      - left. apply uwordToZ_inj. assumption.
      - right. apply uwordToZ_ne. assumption.
    Defined.

    Definition wuleb := wu_binop_t Z.leb sz.
    Definition wultb := wu_binop_t Z.ltb sz.
    Definition wugeb := wu_binop_t Z.geb sz.
    Definition wugtb := wu_binop_t Z.gtb sz.

    Definition wsleb := ws_binop_t Z.leb sz.
    Definition wsltb := ws_binop_t Z.ltb sz.
    Definition wsgeb := ws_binop_t Z.geb sz.
    Definition wsgtb := ws_binop_t Z.gtb sz.

    Definition wshiftl  := wu_binop Z.shiftl sz.
    Definition wshiftr  := wu_binop Z.shiftr sz.
    Definition wshiftra := ws_binop Z.shiftr sz.

  End MoreOps.

  Hint Unfold
       wudiv wuquot wumod wurem
       wsdiv wsquot wsmod wsrem
       wor wand wxor
       weqb
       wuleb wultb wugeb wugtb
       wsleb wsltb wsgeb wsgtb
       wshiftl wshiftr wshiftra
    : unf_word_all.

  Definition wucast{sz: Z}(sz': Z)(w: word sz): word sz' :=
    ZToWord sz' (uwordToZ w).

  Definition wscast{sz: Z}(sz': Z)(w: word sz): word sz' :=
    ZToWord sz' (swordToZ w).

  Definition wappend{sz1 sz2: Z}(w1: word sz1)(w2: word sz2): word (sz1 + sz2) :=
    ZToWord (sz1 + sz2) (Z.lor (Z.shiftl (uwordToZ w1) sz2) (uwordToZ w2)).

  Definition wsplit_lo(sz1 sz2: Z)(w: word (sz1 + sz2)): word sz2 :=
    wucast sz2 w.

  Definition wsplit_hi(sz1 sz2: Z)(w: word (sz1 + sz2)): word sz1 :=
    ZToWord sz1 (Z.shiftr (uwordToZ w) sz2).

  Definition lobits(sz: Z)(w: word (sz + sz)): word sz := wsplit_lo sz sz w.

  Definition hibits(sz: Z)(w: word (sz + sz)): word sz := wsplit_hi sz sz w.

  Hint Unfold wucast wscast wappend wsplit_lo wsplit_hi lobits hibits : unf_word_all.

  Ltac word_omega_pre :=
    repeat match goal with
           | n: Z |- _ =>
             let B := fresh in assert (0 < n) by omega;
                               unique pose proof (pow2_times2 n B)
           | _: context[2 ^ ?n] |- _ =>
             let B := fresh in assert (0 <= n) by omega;
                               unique pose proof (pow2_pos n B)
           | _: context[?a mod ?m] |- _ =>
             let B := fresh in assert (0 < m) by omega;
                               unique pose proof (Z.mod_pos_bound a m B)
           | H: ?a mod 2 ^ _ = ?a      |- _ => apply mod_pow2_same_bounds in H; [|omega]
           | H: Z.testbit _ _ = true   |- _ => apply testbit_true_nonneg in H; [|omega..]
           | H: Z.testbit _ _ = false  |- _ => apply testbit_false_nonneg in H; [|omega..]
           | H1: ?a <= ?b, H2: ?b < ?c  |- _ => unique pose proof (conj H1 H2)
           | H: - 2 ^ _ <= ?n < 2 ^ _   |- _ => unique pose proof (signed_bounds_to_sz_pos _ _ H)
           end.

  Ltac word_omega := word_omega_pre; omega.

  Ltac word_bitwise_pre :=
    apply mod_eq_ZToWord_eq;
    rewrite <-? Z.land_ones by omega;
    (repeat match goal with
            | H: ?a mod 2 ^ _ = ?a |- _ => apply mod_pow2_same_bounds in H; [|omega]
            end).

  Ltac word_bitwise := word_destruct; word_bitwise_pre; prove_Zeq_bitwise.

  Lemma wappend_split: forall sz1 sz2 (w : word (sz1 + sz2)),
      0 <= sz1 ->
      0 <= sz2 ->
      wappend (wsplit_hi sz1 sz2 w) (wsplit_lo sz1 sz2 w) = w.
  Proof. word_bitwise. Qed.

  Lemma wsplit_lo_wappend: forall {sz1 sz2} (w1: word sz1) (w2: word sz2),
      0 <= sz1 ->
      0 <= sz2 ->
      wsplit_lo sz1 sz2 (wappend w1 w2) = w2.
  Proof. word_bitwise. Qed.

  Lemma wsplit_hi_wappend: forall {sz1 sz2} (w1: word sz1) (w2: word sz2),
      0 <= sz1 ->
      0 <= sz2 ->
      wsplit_hi sz1 sz2 (wappend w1 w2) = w1.
  Proof. word_bitwise. Qed.

  Lemma wappend_inj: forall {sz1 sz2} (a : word sz1) (b : word sz2) (c : word sz1) (d : word sz2),
      0 <= sz1 ->
      0 <= sz2 ->
      wappend a b = wappend c d ->
      a = c /\ b = d.
  Proof.
    intros.
    pose proof (wsplit_lo_wappend a b H H0).
    pose proof (wsplit_hi_wappend a b H H0).
    pose proof (wsplit_lo_wappend c d H H0).
    pose proof (wsplit_hi_wappend c d H H0).
    split; congruence.
  Qed.

  Lemma word_ring: forall sz,
      ring_theory (ZToWord sz 0) (ZToWord sz 1) wadd wmul wsub wopp eq.
  Proof.
    intros. constructor; word_solver.
  Qed.

  Lemma word_ring_morph_Z: forall sz,
      ring_morph (ZToWord sz 0) (ZToWord sz 1) wadd  wmul  wsub  wopp  eq
                 0              1              Z.add Z.mul Z.sub Z.opp Z.eqb
                 (ZToWord sz).
  Proof.
    intros. constructor; word_solver.
  Qed.

  Lemma weqb_spec: forall {sz: Z} (a b : word sz),
      weqb a b = true <-> a = b.
  Proof.
    word_destruct.
    - reflexivity.
    - apply Z.eqb_eq; word_omega.
  Qed.

  Lemma weqb_true: forall {sz} (x y : word sz), weqb x y = true -> x = y.
  Proof.
    eapply @weqb_spec.
  Qed.

  Lemma weqb_eq: forall {sz} (a b: word sz), a = b -> weqb a b = true.
  Proof.
    eapply @weqb_spec.
  Qed.

  Lemma weqb_false: forall {sz} (a b: word sz), weqb a b = false -> a <> b.
  Proof.
    intros. destruct (weqb a b) eqn: E.
    - discriminate.
    - intro C. subst. rewrite weqb_eq in E; congruence.
  Qed.

  Lemma weqb_ne: forall {sz} (a b: word sz), a <> b -> weqb a b = false.
  Proof.
    intros. destruct (weqb a b) eqn: E.
    - apply weqb_true in E. contradiction.
    - reflexivity.
  Qed.

  Lemma swordToZ_bound: forall sz (a : word sz),
      0 < sz ->
      - 2 ^ (sz - 1) <= swordToZ a < 2 ^ (sz - 1).
  Proof. word_destruct; word_omega. Qed.

  Lemma uwordToZ_bound: forall sz (a : word sz),
      0 < sz ->
      0 <= uwordToZ a < 2 ^ sz.
  Proof. word_destruct; word_omega. Qed.

  Lemma swordToZ_ZToWord: forall sz n,
      - 2 ^ (sz - 1) <= n < 2 ^ (sz - 1) ->
      swordToZ (ZToWord sz n) = n.
  Proof.
    word_destruct; word_omega_pre;
      assert (sz = 1 \/ 1 < sz) as C by omega;
      (destruct C as [C | C];
       [subst sz;
        repeat match goal with
               | _: context[2 ^ ?x] |- _ =>
                 let r := eval cbv in (2 ^ x) in change (2 ^ x) with r in *
               end;
        assert (n = -1 \/ n = 0) as C by omega;
        destruct C; subst n; cbv in E; try reflexivity; congruence |]);
      match goal with
      | _: context[?a mod ?m] |- _ =>
        let B := fresh in
        assert (m <> 0) by omega;
          pose proof (Z.mod_eq a m B) as M
      end;
      assert (- 2 ^ (sz - 1) <= n <= 2 ^ (sz - 1) + 1) as B by omega;
      (apply (range_div_pos _ _ _ (2 ^ sz)) in B; [|omega]);
      assert (2 ^ (sz - 1) mod 2 ^ sz = 2 ^ (sz - 1)) by (apply Z.mod_small; omega);
      rewrite Z.div_opp_l_nz in B by omega;
      rewrite Z.div_small in B by omega;
      (rewrite (Z.div_small (2 ^ (sz - 1) + 1) (2 ^ sz)) in B;
       [ assert (n / 2 ^ sz = 0 \/ n / 2 ^ sz = -1) as R by omega;
         destruct R as [R | R]; rewrite R in M; omega
       | split; try omega;
         rewrite H4;
         pose proof (Z.pow_gt_1 2 (sz - 1));
         omega ]).
  Qed.

  Lemma ZToWord_swordToZ: forall sz (a : word sz),
      ZToWord sz (swordToZ a) = a.
  Proof. word_solver. Qed.

End Word.

(** Different ways to instantiate WORD: *)

(* Note: we don't use this because see below *)
Module SigmaWord <: WORD.

  Lemma sigma_canonicalize_eq: forall {A : Type},
    (forall x1 x2 : A, {x1 = x2} + {x1 <> x2}) ->
    forall (canonicalize: A -> A) (x1 x2: A) (p1: canonicalize x1 = x1) (p2: canonicalize x2 = x2),
      x1 = x2 ->
      exist (fun x => canonicalize x = x) x1 p1 = exist (fun x => canonicalize x = x) x2 p2.
  Proof.
    intros.
    subst x2.
    f_equal.
    apply (UIP_dec X p1 p2).
  Qed.

  Definition word(sz: Z) := { x: Z | x mod 2 ^ sz = x }.

  Definition ZToWord(sz: Z)(x: Z): word sz := exist _ (x mod 2 ^ sz) (Zmod_mod x (2 ^ sz)).

  Definition uwordToZ{sz: Z}: word sz -> Z := @proj1_sig Z (fun x => x mod 2 ^ sz = x).

  Lemma uwordToZ_ZToWord: forall {sz: Z} (n: Z),
      uwordToZ (ZToWord sz n) = n mod 2 ^ sz.
  Proof.
    intros. reflexivity.
  Qed.

  Lemma ZToWord_uwordToZ: forall {sz: Z} (a : word sz),
      ZToWord sz (uwordToZ a) = a.
  Proof.
    intros. destruct a as [a Ma]. unfold ZToWord, uwordToZ.
    simpl.
    apply (sigma_canonicalize_eq Z.eq_dec).
    assumption.
  Qed.

  (* Prints a huge term, and is very slow, therefore this implementation is not usable
  Eval cbv in (ZToWord 4 3).
  *)
End SigmaWord.

(* Instead, we can just use bbv.Word: *)
Module BbvWord <: WORD.

  Definition word(sz: Z) := bbv.Word.word (Z.to_nat sz).

  (* Note: we do not reuse bbv.Word.ZToWord, because that would make the proof of
   uwordToZ_ZToWord below very hard *)
  Definition ZToWord(sz: Z)(x: Z): word sz :=
    bbv.Word.NToWord (Z.to_nat sz) (Z.to_N (x mod 2 ^ sz)).

  Definition uwordToZ{sz: Z}(w: word sz): Z := bbv.Word.uwordToZ w.

  Lemma neg_size: forall sz (a: word sz),
      sz < 0 ->
      a = Word.wzero (Z.to_nat sz).
  Proof.
    intros. unfold word in *.
    remember (Z.to_nat sz) as n.
    destruct a.
    - reflexivity.
    - exfalso. rewrite Z_to_nat_neg in Heqn by assumption. discriminate.
  Qed.

  Lemma uwordToZ_ZToWord: forall {sz: Z} (n: Z),
      uwordToZ (ZToWord sz n) = n mod 2 ^ sz.
  Proof.
    intros.
    unfold uwordToZ, ZToWord, bbv.Word.uwordToZ.
    assert (sz < 0 \/ 0 <= sz) as C by omega.
    destruct C as [C | C].
    - rewrite Z.pow_neg_r by assumption. rewrite Zmod_0_r.
      rewrite Z_to_nat_neg by omega. reflexivity.
    - pose proof (pow2_pos _ C).
      rewrite Word.wordToN_NToWord_2.
      + apply Z2N.id. apply Z.mod_pos_bound. assumption.
      + rewrite NatLib.pow2_N. change 2%nat with (Z.to_nat 2).
        rewrite <- Z2Nat.inj_pow by omega.
        rewrite Z_nat_N.
        pose proof (Z.mod_pos_bound n (2 ^ sz) H).
        apply Z2N.inj_lt; omega.
  Qed.

  Lemma ZToWord_uwordToZ: forall {sz: Z} (a : word sz),
      ZToWord sz (uwordToZ a) = a.
  Proof.
    intros.
    unfold uwordToZ, ZToWord, bbv.Word.uwordToZ.
    assert (sz < 0 \/ 0 <= sz) as C by omega.
    destruct C as [C | C].
    - rewrite Z.pow_neg_r by assumption. rewrite Zmod_0_r.
      rewrite neg_size by assumption.
      apply Word.NToWord_0.
    - rewrite Z2N.inj_mod.
      + rewrite N2Z.id.
        rewrite N.mod_small.
        * apply  Word.NToWord_wordToN.
        * pose proof (Word.wordToN_bound a) as P.
          rewrite NatLib.pow2_N in P. change 2%nat with (Z.to_nat 2) in P.
          rewrite <- Z2Nat.inj_pow in P by omega.
          rewrite Z_nat_N in P.
          exact P.
      + apply N2Z.is_nonneg.
      + apply pow2_pos. assumption.
  Qed.

  (* fast, as desired:
  Eval cbv in (ZToWord 64 (-42)).
  *)
End BbvWord.

(* The problems with SigmaWord are:
   - cbv will reduce its argument (P : A -> Prop) to huge terms
   - cbv will reduce its proof argument of type (P x) to possibly huge terms
   We can solve this by reimplementing sigma types by fixing the (P : A -> Prop) argument,
   and making sure proof terms always are just eq_refl, as follows: *)
Module RecordWord <: WORD.

  Record word_record{sz: Z} := Build_word {
    word_val: Z;
    word_mod: word_val mod 2 ^ sz = word_val
  }.

  Definition word: Z -> Set := @word_record.

  Definition minimize_eq_proof{A: Type}(eq_dec: forall (x y: A), {x = y} + {x <> y}){x y: A}
    (pf: x = y): x = y :=
    match eq_dec x y with
    | left p => p
    | right n => match n pf: False with end
    end.

  Definition ZToWord(sz: Z)(x: Z): word sz :=
    Build_word sz (x mod 2 ^ sz) (minimize_eq_proof Z.eq_dec (Zmod_mod x (2 ^ sz))).

  Definition uwordToZ{sz: Z}: word sz -> Z := word_val.

  Lemma uwordToZ_ZToWord: forall {sz: Z} (n: Z),
      uwordToZ (ZToWord sz n) = n mod 2 ^ sz.
  Proof.
    intros. reflexivity.
  Qed.

  Lemma sigma_canonicalize_eq: forall {A : Type},
    (forall x1 x2 : A, {x1 = x2} + {x1 <> x2}) ->
    forall (canonicalize: A -> A) (x1 x2: A) (p1: canonicalize x1 = x1) (p2: canonicalize x2 = x2),
      x1 = x2 ->
      exist (fun x => canonicalize x = x) x1 p1 = exist (fun x => canonicalize x = x) x2 p2.
  Proof.
    intros.
    subst x2.
    f_equal.
    apply (UIP_dec X p1 p2).
  Qed.

  Lemma Build_word_eq: forall (sz x1 x2: Z) (p1: x1 mod 2 ^ sz = x1) (p2: x2 mod 2 ^ sz = x2),
      x1 = x2 ->
      Build_word sz x1 p1 = Build_word sz x2 p2.
  Proof.
    intros.
    subst x2.
    f_equal.
    apply UIP_dec.
    apply Z.eq_dec.
  Qed.

  Lemma ZToWord_uwordToZ: forall {sz: Z} (a : word sz),
      ZToWord sz (uwordToZ a) = a.
  Proof.
    intros. destruct a as [a Ma]. unfold ZToWord, uwordToZ.
    simpl.
    apply Build_word_eq.
    assumption.
  Qed.

  (* fast, as desired:
  Eval cbv in (ZToWord 64 (-42)).
  *)

End RecordWord.

Module Export WordLib := Word RecordWord.


(* Note: n is a parameter, not an index *)
Inductive MemoryBank: nat -> Set :=
| Bit: bool -> MemoryBank 1
| Combine: forall n, MemoryBank n -> MemoryBank n -> MemoryBank (S n).


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

Import fol_notations.

Set Implicit Arguments.

(* * Expanding from Σ=({f^n};{P^1}) to any signature *)

Tactic Notation "iff" "equal" := apply fol_equiv_ext.

Local Notation ø := vec_nil.

Section Sig_n1_Sig.

  Variable (n : nat) (Σ' : fo_signature) (f : syms Σ') (p : rels Σ').

  Notation Σ := (Σn1 n).

  Hypothesis (Hf : ar_syms _ f = n).
  Hypothesis (Hp : ar_rels _ p = 1).

  Let Fixpoint convert_t (t : fo_term (ar_syms Σ)) : fo_term (ar_syms Σ').
  Proof.
    refine (match t with
      | in_var i   => in_var i
      | in_fot s v => @in_fot _ (ar_syms Σ') f (vec_map convert_t (cast v _))
    end); now simpl.
  Defined.

  Fixpoint Σn1_Σ (A : fol_form Σ) : fol_form Σ'.
  Proof.
    refine (match A with
      | ⊥              => ⊥
      | fol_atom   _ v => fol_atom p (vec_map convert_t (cast v _))
      | fol_bin b A B  => fol_bin b (Σn1_Σ A) (Σn1_Σ B)
      | fol_quant q A  => fol_quant q (Σn1_Σ A)
     end); now simpl.
  Defined.

  Notation convert := Σn1_Σ.

  Section soundness.

    Variables (X : Type) (M : fo_model Σ X) (phi : nat -> X).

    Let M' : fo_model Σ' X.
    Proof.
      split.
      + intros s.
        destruct (eq_nat_dec (ar_syms _ s) n) as [ E | D ].
        * intros v; apply (fom_syms M tt); revert v; rewrite E; trivial.
        * intros; apply (phi 0).
      + intros r.
        destruct (eq_nat_dec (ar_rels _ r) 1) as [ E | D ].
        * intros v; apply (fom_rels M tt); revert v; rewrite E; trivial.
        * intros; exact True.
    Defined.

    Let convert_t_sound t φ : fo_term_sem M φ t = fo_term_sem M' φ (convert_t t).
    Proof.
      induction t as [ i | [] v IH ]; simpl; auto.
      destruct (eq_nat_dec (ar_syms Σ' f) n) as [ H | [] ]; auto.
      rewrite vec_map_map; generalize H Hf; intros -> H'.
      unfold eq_rect_r; simpl; f_equal.
      apply vec_pos_ext; intros j; rewrite !vec_pos_map.
      rewrite IH; repeat f_equal.
      rewrite (eq_nat_pirr H' eq_refl); auto.
    Qed.

    Let convert_sound A φ : fol_sem M φ A <-> fol_sem M' φ (convert A).
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros φ.
      + simpl; tauto.
      + simpl.
        destruct (eq_nat_dec (ar_rels Σ' p) 1) as [ H | [] ]; auto.
        generalize H Hp; intros -> H'.
        unfold eq_rect_r; simpl; f_equal.
        rewrite (eq_nat_pirr H' eq_refl); simpl.
        rewrite !vec_map_map.
        apply fol_equiv_ext; f_equal.
        apply vec_pos_ext; intros j; rewrite !vec_pos_map; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (Mdec : fo_model_dec M)
               (A : fol_form Σ)
               (HA : fol_sem M phi A).

    Local Fact convert_soundness : fo_form_fin_dec_SAT (convert A).
    Proof.
      exists X, M', Xfin.
      exists.
      { intros r v; simpl in *.
        destruct (eq_nat_dec (ar_rels Σ' r) 1); try tauto; apply Mdec. }
      exists phi; apply convert_sound; auto.
    Qed.

  End soundness.

  Section completeness.

    Variables (X : Type) (M' : fo_model Σ' X).

    Let M : fo_model Σ X.
    Proof.
      split.
      + intros []; simpl; intros v.
        apply (fom_syms M' f); rewrite Hf; trivial.
      + intros []; simpl; intros v.
        apply (fom_rels M' p); rewrite Hp; trivial.
    Defined.

    Let convert_t_complete t φ : fo_term_sem M φ t = fo_term_sem M' φ (convert_t t).
    Proof.
      induction t as [ i | [] v IH ]; simpl; auto.
      f_equal; generalize Hf; intros ->.
      unfold eq_rect_r; simpl; f_equal.
      apply vec_pos_ext; intros j; rewrite !vec_pos_map.
      rewrite IH; repeat f_equal.
    Qed.

    Let convert_complete A φ : fol_sem M φ A <-> fol_sem M' φ (convert A).
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros φ.
      + simpl; tauto.
      + simpl.
        apply fol_equiv_ext; f_equal; generalize Hp; intros ->.
        unfold eq_rect_r; simpl; f_equal.
        apply vec_pos_ext; intros j; rewrite !vec_pos_map; auto.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

    Hypothesis (Xfin : finite_t X)
               (M'dec : fo_model_dec M')
               (phi : nat -> X)
               (A : fol_form Σ)
               (HA : fol_sem M' phi (convert A)).

    Local Fact convert_completeness : fo_form_fin_dec_SAT A.
    Proof.
      exists X, M, Xfin.
      exists.
      { intros [] v; apply M'dec. }
      exists phi; apply convert_complete; auto.
    Qed.

  End completeness.

  Theorem Σn1_Σ_correct A :
              fo_form_fin_dec_SAT A
          <-> fo_form_fin_dec_SAT (Σn1_Σ A).
  Proof.
    split.
    + intros (X & M & H1 & H2 & phi & H3).
      apply convert_soundness with X M phi; auto.
    + intros (X & M & H1 & H2 & phi & H3).
      apply convert_completeness with X M phi; auto.
  Qed.

End Sig_n1_Sig.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export Cring.
Require Export Integral_domain.
Require Export Ncring_initial.
Require Export Omega.

Instance Zcri: (Cring (Rr:=Zr)).
red. exact Z.mul_comm. Defined.

Lemma Z_one_zero: 1%Z <> 0%Z.
omega.
Qed.

Instance Zdi : (Integral_domain (Rcr:=Zcri)).
constructor.
exact Zmult_integral. exact Z_one_zero. Defined.


Require Import rt.util.all rt.util.divround.
Require Import rt.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) (s := ts) (x0 := 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 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].
        rewrite eqn_leq; apply/andP; split; first by apply cumulative_service_le_job_cost.
        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.
        }
        rewrite leq_eqVlt; apply/orP; left; rewrite eq_sym.
        by apply COMPLETED.
      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.


Definition cong_pi1 :=
fun (A1 A2 : Type) (B1 : A1 -> Type) (B2 : A2 -> Type) (p1 : ∑ x : A1, B1 x)
  (p2 : ∑ x : A2, B2 x) (hA : A1 ≅ A2) (hB : forall p : Pack A1 A2, B1 (ProjT1 p) ≅ B2 (ProjT2 p))
  (hp : p1 ≅ p2) =>
match hA with
| @heqPair _ _ _ _ pT pA =>
    let pA0 : transport eq_refl A1 = A2 :=
      Logic.eq_ind pT (fun pT0 : Type = Type => transport pT0 A1 = A2) pA eq_refl (K pT) in
    match
      pA0 in (_ = y)
      return
        (forall (B3 : y -> Type) (p3 : ∑ x : y, B3 x),
         (forall p : Pack A1 y, B1 (ProjT1 p) ≅ B3 (ProjT2 p)) -> p1 ≅ p3 -> pi1 p1 ≅ pi1 p3)
    with
    | eq_refl =>
        fun (B3 : A1 -> Type) (p3 : ∑ x : A1, B3 x)
          (hB0 : forall p : Pack A1 A1, B1 (ProjT1 p) ≅ B3 (ProjT2 p)) (hp0 : p1 ≅ p3) =>
        let pB : B1 = B3 :=
          funext
            (fun x : A1 =>
             let h :
               B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})
               ≅ B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |}) :=
               hB0 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |} in
             match h with
             | @heqPair _ _ _ _ pT0 pB =>
                 let pB0 :
                   transport eq_refl
                     (B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) =
                   B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |}) :=
                   Logic.eq_ind pT0
                     (fun pT1 : Type = Type =>
                      transport pT1 (B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) =
                      B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) pB eq_refl
                     (K pT0) in
                 pB0
             end) in
        match
          pB in (_ = y)
          return
            (forall p4 : ∑ x : A1, y x,
             (forall p : Pack A1 A1, B1 (ProjT1 p) ≅ y (ProjT2 p)) -> p1 ≅ p4 -> pi1 p1 ≅ pi1 p4)
        with
        | eq_refl =>
            fun (p4 : ∑ x : A1, B1 x) (_ : forall p : Pack A1 A1, B1 (ProjT1 p) ≅ B1 (ProjT2 p))
              (hp1 : p1 ≅ p4) =>
            match hp1 with
            | @heqPair _ _ _ _ pT0 pp =>
                let pp0 : transport eq_refl p1 = p4 :=
                  Logic.eq_ind pT0
                    (fun pT1 : (∑ x : A1, B1 x) = (∑ x : A1, B1 x) => transport pT1 p1 = p4) pp
                    eq_refl (K pT0) in
                match pp0 in (_ = y) return (pi1 p1 ≅ pi1 y) with
                | eq_refl => heq_refl (pi1 p1)
                end
            end
        end p3 hB0 hp0
    end B2 p2 hB hp
end
     : forall (A1 A2 : Type) (B1 : A1 -> Type) (B2 : A2 -> Type) (p1 : ∑ x : A1, B1 x)
         (p2 : ∑ x : A2, B2 x),
       A1 ≅ A2 -> (forall p : Pack A1 A2, B1 (ProjT1 p) ≅ B2 (ProjT2 p)) -> p1 ≅ p2 -> pi1 p1 ≅ pi1 p2.


(*
Section toto.

Variable f : nat -> nat.
Hypothesis foo : f 0 = 0.
Lemma L1 : forall k:nat, k = 0 -> f k = k.
intros.
rewrite H.
apply foo.
Qed.

Hypothesis f10 : f 1 = f 0.

Lemma L2 : f (f 1) = 0.
replace (f 1) with 0.
apply foo.
transitivity (f 0); symmetry; trivial.

End.

*)


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__lessthancongruence.
Require Export lemma__lessthantransitive.
Require Export lemma__partnotequalwhole.
Require Export logic.
Definition lemma__midpointunique : forall A B C D, (euclidean__defs.Midpoint A B C) -> ((euclidean__defs.Midpoint A D C) -> (B = D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
assert (* Cut *) ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H1.
- assert ((euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D D C)) as H1 by exact H0.
assert ((euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D D C)) as __TmpHyp by exact H1.
destruct __TmpHyp as [H2 H3].
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H4 by exact H.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp0 by exact H4.
destruct __TmpHyp0 as [H5 H6].
split.
-- exact H5.
-- exact H6.
- assert (* Cut *) ((euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D D C)) as H2.
-- assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H2 by exact H1.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp by exact H2.
destruct __TmpHyp as [H3 H4].
assert ((euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D D C)) as H5 by exact H0.
assert ((euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D D C)) as __TmpHyp0 by exact H5.
destruct __TmpHyp0 as [H6 H7].
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as H8 by exact H.
assert ((euclidean__axioms.BetS A B C) /\ (euclidean__axioms.Cong A B B C)) as __TmpHyp1 by exact H8.
destruct __TmpHyp1 as [H9 H10].
split.
--- exact H6.
--- exact H7.
-- assert (* Cut *) (euclidean__axioms.Cong A B A B) as H3.
--- destruct H2 as [H3 H4].
destruct H1 as [H5 H6].
apply (@euclidean__axioms.cn__congruencereflexive A B).
--- assert (* Cut *) (~(euclidean__axioms.BetS C D B)) as H4.
---- intro H4.
assert (* Cut *) (euclidean__axioms.BetS B D C) as H5.
----- destruct H2 as [H5 H6].
destruct H1 as [H7 H8].
apply (@euclidean__axioms.axiom__betweennesssymmetry C D B H4).
----- assert (* Cut *) (euclidean__axioms.BetS A B D) as H6.
------ destruct H2 as [H6 H7].
destruct H1 as [H8 H9].
apply (@euclidean__axioms.axiom__innertransitivity A B D C H8 H5).
------ assert (* Cut *) (euclidean__defs.Lt A B A D) as H7.
------- exists B.
split.
-------- exact H6.
-------- exact H3.
------- assert (* Cut *) (euclidean__axioms.Cong A D C D) as H8.
-------- destruct H2 as [H8 H9].
destruct H1 as [H10 H11].
assert (* Cut *) ((euclidean__axioms.Cong D A C D) /\ ((euclidean__axioms.Cong D A D C) /\ (euclidean__axioms.Cong A D C D))) as H12.
--------- apply (@lemma__congruenceflip.lemma__congruenceflip A D D C H9).
--------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H16.
-------- assert (* Cut *) (euclidean__defs.Lt A B C D) as H9.
--------- destruct H2 as [H9 H10].
destruct H1 as [H11 H12].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A B A D C D H7 H8).
--------- assert (* Cut *) (euclidean__axioms.BetS C D B) as H10.
---------- destruct H2 as [H10 H11].
destruct H1 as [H12 H13].
exact H4.
---------- assert (* Cut *) (euclidean__axioms.Cong C D C D) as H11.
----------- destruct H2 as [H11 H12].
destruct H1 as [H13 H14].
apply (@euclidean__axioms.cn__congruencereflexive C D).
----------- assert (* Cut *) (euclidean__defs.Lt C D C B) as H12.
------------ exists D.
split.
------------- exact H10.
------------- exact H11.
------------ assert (* Cut *) (euclidean__defs.Lt A B C B) as H13.
------------- destruct H2 as [H13 H14].
destruct H1 as [H15 H16].
apply (@lemma__lessthantransitive.lemma__lessthantransitive A B C D C B H9 H12).
------------- assert (* Cut *) (euclidean__axioms.Cong C B B C) as H14.
-------------- destruct H2 as [H14 H15].
destruct H1 as [H16 H17].
apply (@euclidean__axioms.cn__equalityreverse C B).
-------------- assert (* Cut *) (euclidean__defs.Lt A B B C) as H15.
--------------- destruct H2 as [H15 H16].
destruct H1 as [H17 H18].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A B C B B C H13 H14).
--------------- assert (* Cut *) (euclidean__axioms.Cong B C A B) as H16.
---------------- destruct H2 as [H16 H17].
destruct H1 as [H18 H19].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B A B C H19).
---------------- assert (* Cut *) (euclidean__defs.Lt A B A B) as H17.
----------------- destruct H2 as [H17 H18].
destruct H1 as [H19 H20].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A B B C A B H15 H16).
----------------- assert (* Cut *) (exists E, (euclidean__axioms.BetS A E B) /\ (euclidean__axioms.Cong A E A B)) as H18.
------------------ destruct H2 as [H18 H19].
destruct H1 as [H20 H21].
exact H17.
------------------ destruct H18 as [E H19].
destruct H19 as [H20 H21].
destruct H2 as [H22 H23].
destruct H1 as [H24 H25].
assert (* Cut *) (~(euclidean__axioms.Cong A E A B)) as H26.
------------------- apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A E B H20).
------------------- apply (@H26 H21).
---- assert (* Cut *) (~(euclidean__axioms.BetS C B D)) as H5.
----- intro H5.
assert (* Cut *) (euclidean__axioms.BetS D B C) as H6.
------ destruct H2 as [H6 H7].
destruct H1 as [H8 H9].
apply (@euclidean__axioms.axiom__betweennesssymmetry C B D H5).
------ assert (* Cut *) (euclidean__axioms.BetS A D B) as H7.
------- destruct H2 as [H7 H8].
destruct H1 as [H9 H10].
apply (@euclidean__axioms.axiom__innertransitivity A D B C H7 H6).
------- assert (* Cut *) (euclidean__axioms.Cong A D A D) as H8.
-------- destruct H2 as [H8 H9].
destruct H1 as [H10 H11].
apply (@euclidean__axioms.cn__congruencereflexive A D).
-------- assert (* Cut *) (euclidean__defs.Lt A D A B) as H9.
--------- exists D.
split.
---------- exact H7.
---------- exact H8.
--------- assert (* Cut *) (euclidean__axioms.Cong A B C B) as H10.
---------- destruct H2 as [H10 H11].
destruct H1 as [H12 H13].
assert (* Cut *) ((euclidean__axioms.Cong B A C B) /\ ((euclidean__axioms.Cong B A B C) /\ (euclidean__axioms.Cong A B C B))) as H14.
----------- apply (@lemma__congruenceflip.lemma__congruenceflip A B B C H13).
----------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H18.
---------- assert (* Cut *) (euclidean__defs.Lt A D C B) as H11.
----------- destruct H2 as [H11 H12].
destruct H1 as [H13 H14].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A D A B C B H9 H10).
----------- assert (* Cut *) (euclidean__axioms.BetS C B D) as H12.
------------ destruct H2 as [H12 H13].
destruct H1 as [H14 H15].
exact H5.
------------ assert (* Cut *) (euclidean__axioms.Cong C B C B) as H13.
------------- destruct H2 as [H13 H14].
destruct H1 as [H15 H16].
apply (@euclidean__axioms.cn__congruencereflexive C B).
------------- assert (* Cut *) (euclidean__defs.Lt C B C D) as H14.
-------------- exists B.
split.
--------------- exact H12.
--------------- exact H13.
-------------- assert (* Cut *) (euclidean__defs.Lt A D C D) as H15.
--------------- destruct H2 as [H15 H16].
destruct H1 as [H17 H18].
apply (@lemma__lessthantransitive.lemma__lessthantransitive A D C B C D H11 H14).
--------------- assert (* Cut *) (euclidean__axioms.Cong C D D C) as H16.
---------------- destruct H2 as [H16 H17].
destruct H1 as [H18 H19].
apply (@euclidean__axioms.cn__equalityreverse C D).
---------------- assert (* Cut *) (euclidean__defs.Lt A D D C) as H17.
----------------- destruct H2 as [H17 H18].
destruct H1 as [H19 H20].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A D C D D C H15 H16).
----------------- assert (* Cut *) (euclidean__axioms.Cong D C C D) as H18.
------------------ destruct H2 as [H18 H19].
destruct H1 as [H20 H21].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric D C D C H16).
------------------ assert (* Cut *) (euclidean__defs.Lt A D C D) as H19.
------------------- destruct H2 as [H19 H20].
destruct H1 as [H21 H22].
exact H15.
------------------- assert (* Cut *) (euclidean__axioms.Cong D C A D) as H20.
-------------------- destruct H2 as [H20 H21].
destruct H1 as [H22 H23].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric D A D C H21).
-------------------- assert (* Cut *) (euclidean__axioms.Cong C D A D) as H21.
--------------------- destruct H2 as [H21 H22].
destruct H1 as [H23 H24].
assert (* Cut *) ((euclidean__axioms.Cong C D D A) /\ ((euclidean__axioms.Cong C D A D) /\ (euclidean__axioms.Cong D C D A))) as H25.
---------------------- apply (@lemma__congruenceflip.lemma__congruenceflip D C A D H20).
---------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
exact H28.
--------------------- assert (* Cut *) (euclidean__defs.Lt A D A D) as H22.
---------------------- destruct H2 as [H22 H23].
destruct H1 as [H24 H25].
apply (@lemma__lessthancongruence.lemma__lessthancongruence A D C D A D H19 H21).
---------------------- assert (* Cut *) (exists F, (euclidean__axioms.BetS A F D) /\ (euclidean__axioms.Cong A F A D)) as H23.
----------------------- destruct H2 as [H23 H24].
destruct H1 as [H25 H26].
exact H22.
----------------------- destruct H23 as [F H24].
destruct H24 as [H25 H26].
destruct H2 as [H27 H28].
destruct H1 as [H29 H30].
assert (* Cut *) (~(euclidean__axioms.Cong A F A D)) as H31.
------------------------ apply (@lemma__partnotequalwhole.lemma__partnotequalwhole A F D H25).
------------------------ apply (@H31 H26).
----- assert (* Cut *) (euclidean__axioms.BetS C D A) as H6.
------ destruct H2 as [H6 H7].
destruct H1 as [H8 H9].
apply (@euclidean__axioms.axiom__betweennesssymmetry A D C H6).
------ assert (* Cut *) (euclidean__axioms.BetS C B A) as H7.
------- destruct H2 as [H7 H8].
destruct H1 as [H9 H10].
apply (@euclidean__axioms.axiom__betweennesssymmetry A B C H9).
------- assert (* Cut *) (B = D) as H8.
-------- destruct H2 as [H8 H9].
destruct H1 as [H10 H11].
apply (@euclidean__axioms.axiom__connectivity C B D A H7 H6 H5 H4).
-------- exact H8.
Qed.


Require Export fintype.
Require Export header_extensible.
Inductive tm (n_tm : nat) : Type :=
  | var_tm : forall _ : fin n_tm, tm n_tm
  | app :
      forall p : nat,
      forall _ : tm n_tm, forall _ : cod (fin p) (tm n_tm), tm n_tm
  | lam : forall p : nat, forall _ : tm (plus p n_tm), tm n_tm.
Lemma congr_app {p : nat} {m_tm : nat} {s0 : tm m_tm}
  {s1 : cod (fin p) (tm m_tm)} {t0 : tm m_tm} {t1 : cod (fin p) (tm m_tm)}
  (H0 : eq s0 t0) (H1 : eq s1 t1) : eq (app m_tm p s0 s1) (app m_tm p t0 t1).
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app m_tm p x s1) H0))
                (ap (fun x => app m_tm p t0 x) H1)).
Qed.
Lemma congr_lam {p : nat} {m_tm : nat} {s0 : tm (plus p m_tm)}
  {t0 : tm (plus p m_tm)} (H0 : eq s0 t0) :
  eq (lam m_tm p s0) (lam m_tm p t0).
Proof.
exact (eq_trans eq_refl (ap (fun x => lam m_tm p x) H0)).
Qed.
Definition upRen_tm_tm {m : nat} {n : nat} (xi : forall _ : fin m, fin n) :
  forall _ : fin (S m), fin (S n) := up_ren xi.
Definition upRen_list_tm_tm (p : nat) {m : nat} {n : nat}
  (xi : forall _ : fin m, fin n) :
  forall _ : fin (plus p m), fin (plus p n) := upRen_p p xi.
Fixpoint ren_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm) (s : tm m_tm) : tm n_tm :=
  match s with
  | var_tm _ s0 => var_tm n_tm (xi_tm s0)
  | app _ p s0 s1 => app n_tm p (ren_tm xi_tm s0) (cod_map (ren_tm xi_tm) s1)
  | lam _ p s0 => lam n_tm p (ren_tm (upRen_list_tm_tm p xi_tm) s0)
  end.
Definition up_tm_tm {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) : forall _ : fin (S m), tm (S n_tm) :=
  scons (var_tm (S n_tm) var_zero) (funcomp (ren_tm shift) sigma).
Definition up_list_tm_tm (p : nat) {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) :
  forall _ : fin (plus p m), tm (plus p n_tm) :=
  scons_p p (funcomp (var_tm (plus p n_tm)) (zero_p p))
    (funcomp (ren_tm (shift_p p)) sigma).
Fixpoint subst_tm {m_tm : nat} {n_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm n_tm) (s : tm m_tm) : tm n_tm :=
  match s with
  | var_tm _ s0 => sigma_tm s0
  | app _ p s0 s1 =>
      app n_tm p (subst_tm sigma_tm s0) (cod_map (subst_tm sigma_tm) s1)
  | lam _ p s0 => lam n_tm p (subst_tm (up_list_tm_tm p sigma_tm) s0)
  end.
Definition upId_tm_tm {m_tm : nat} (sigma : forall _ : fin m_tm, tm m_tm)
  (Eq : forall x, eq (sigma x) (var_tm m_tm x)) :
  forall x, eq (up_tm_tm sigma x) (var_tm (S m_tm) x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition upId_list_tm_tm {p : nat} {m_tm : nat}
  (sigma : forall _ : fin m_tm, tm m_tm)
  (Eq : forall x, eq (sigma x) (var_tm m_tm x)) :
  forall x, eq (up_list_tm_tm p sigma x) (var_tm (plus p m_tm) x) :=
  fun n =>
  scons_p_eta (var_tm (plus p m_tm))
    (fun n => ap (ren_tm (shift_p p)) (Eq n)) (fun n => eq_refl).
Fixpoint idSubst_tm {m_tm : nat} (sigma_tm : forall _ : fin m_tm, tm m_tm)
(Eq_tm : forall x, eq (sigma_tm x) (var_tm m_tm x)) (s : tm m_tm) :
eq (subst_tm sigma_tm s) s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (idSubst_tm sigma_tm Eq_tm s0)
        (cod_id (idSubst_tm sigma_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (idSubst_tm (up_list_tm_tm p sigma_tm) (upId_list_tm_tm _ Eq_tm) s0)
  end.
Definition upExtRen_tm_tm {m : nat} {n : nat} (xi : forall _ : fin m, fin n)
  (zeta : forall _ : fin m, fin n) (Eq : forall x, eq (xi x) (zeta x)) :
  forall x, eq (upRen_tm_tm xi x) (upRen_tm_tm zeta x) :=
  fun n =>
  match n with
  | Some fin_n => ap shift (Eq fin_n)
  | None => eq_refl
  end.
Definition upExtRen_list_tm_tm {p : nat} {m : nat} {n : nat}
  (xi : forall _ : fin m, fin n) (zeta : forall _ : fin m, fin n)
  (Eq : forall x, eq (xi x) (zeta x)) :
  forall x, eq (upRen_list_tm_tm p xi x) (upRen_list_tm_tm p zeta x) :=
  fun n => scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n)).
Fixpoint extRen_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm)
(zeta_tm : forall _ : fin m_tm, fin n_tm)
(Eq_tm : forall x, eq (xi_tm x) (zeta_tm x)) (s : tm m_tm) :
eq (ren_tm xi_tm s) (ren_tm zeta_tm s) :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ p s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (cod_ext (extRen_tm xi_tm zeta_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (extRen_tm (upRen_list_tm_tm p xi_tm) (upRen_list_tm_tm p zeta_tm)
           (upExtRen_list_tm_tm _ _ Eq_tm) s0)
  end.
Definition upExt_tm_tm {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) (tau : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (sigma x) (tau x)) :
  forall x, eq (up_tm_tm sigma x) (up_tm_tm tau x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition upExt_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (sigma : forall _ : fin m, tm n_tm) (tau : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (sigma x) (tau x)) :
  forall x, eq (up_list_tm_tm p sigma x) (up_list_tm_tm p tau x) :=
  fun n =>
  scons_p_congr (fun n => eq_refl) (fun n => ap (ren_tm (shift_p p)) (Eq n)).
Fixpoint ext_tm {m_tm : nat} {n_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm n_tm)
(tau_tm : forall _ : fin m_tm, tm n_tm)
(Eq_tm : forall x, eq (sigma_tm x) (tau_tm x)) (s : tm m_tm) :
eq (subst_tm sigma_tm s) (subst_tm tau_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (cod_ext (ext_tm sigma_tm tau_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (ext_tm (up_list_tm_tm p sigma_tm) (up_list_tm_tm p tau_tm)
           (upExt_list_tm_tm _ _ Eq_tm) s0)
  end.
Definition up_ren_ren_tm_tm {k : nat} {l : nat} {m : nat}
  (xi : forall _ : fin k, fin l) (zeta : forall _ : fin l, fin m)
  (rho : forall _ : fin k, fin m)
  (Eq : forall x, eq (funcomp zeta xi x) (rho x)) :
  forall x,
  eq (funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x) (upRen_tm_tm rho x) :=
  up_ren_ren xi zeta rho Eq.
Definition up_ren_ren_list_tm_tm {p : nat} {k : nat} {l : nat} {m : nat}
  (xi : forall _ : fin k, fin l) (zeta : forall _ : fin l, fin m)
  (rho : forall _ : fin k, fin m)
  (Eq : forall x, eq (funcomp zeta xi x) (rho x)) :
  forall x,
  eq (funcomp (upRen_list_tm_tm p zeta) (upRen_list_tm_tm p xi) x)
    (upRen_list_tm_tm p rho x) := up_ren_ren_p Eq.
Fixpoint compRenRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : forall _ : fin m_tm, fin k_tm)
(zeta_tm : forall _ : fin k_tm, fin l_tm)
(rho_tm : forall _ : fin m_tm, fin l_tm)
(Eq_tm : forall x, eq (funcomp zeta_tm xi_tm x) (rho_tm x)) (s : tm m_tm) :
eq (ren_tm zeta_tm (ren_tm xi_tm s)) (ren_tm rho_tm s) :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ p s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (cod_comp (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (compRenRen_tm (upRen_list_tm_tm p xi_tm)
           (upRen_list_tm_tm p zeta_tm) (upRen_list_tm_tm p rho_tm)
           (up_ren_ren_p Eq_tm) s0)
  end.
Definition up_ren_subst_tm_tm {k : nat} {l : nat} {m_tm : nat}
  (xi : forall _ : fin k, fin l) (tau : forall _ : fin l, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp tau xi x) (theta x)) :
  forall x, eq (funcomp (up_tm_tm tau) (upRen_tm_tm xi) x) (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition up_ren_subst_list_tm_tm {p : nat} {k : nat} {l : nat} {m_tm : nat}
  (xi : forall _ : fin k, fin l) (tau : forall _ : fin l, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp tau xi x) (theta x)) :
  forall x,
  eq (funcomp (up_list_tm_tm p tau) (upRen_list_tm_tm p xi) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ _ n)
    (scons_p_congr (fun z => scons_p_head' _ _ z)
       (fun z =>
        eq_trans (scons_p_tail' _ _ (xi z)) (ap (ren_tm (shift_p p)) (Eq z)))).
Fixpoint compRenSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : forall _ : fin m_tm, fin k_tm)
(tau_tm : forall _ : fin k_tm, tm l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp tau_tm xi_tm x) (theta_tm x)) (s : tm m_tm) :
eq (subst_tm tau_tm (ren_tm xi_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (cod_comp (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (compRenSubst_tm (upRen_list_tm_tm p xi_tm) (up_list_tm_tm p tau_tm)
           (up_list_tm_tm p theta_tm) (up_ren_subst_list_tm_tm _ _ _ Eq_tm)
           s0)
  end.
Definition up_subst_ren_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : forall _ : fin k, tm l_tm)
  (zeta_tm : forall _ : fin l_tm, fin m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (ren_tm zeta_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x)
    (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n =>
      eq_trans
        (compRenRen_tm shift (upRen_tm_tm zeta_tm) (funcomp shift zeta_tm)
           (fun x => eq_refl) (sigma fin_n))
        (eq_trans
           (eq_sym
              (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                 (fun x => eq_refl) (sigma fin_n)))
           (ap (ren_tm shift) (Eq fin_n)))
  | None => eq_refl
  end.
Definition up_subst_ren_list_tm_tm {p : nat} {k : nat} {l_tm : nat}
  {m_tm : nat} (sigma : forall _ : fin k, tm l_tm)
  (zeta_tm : forall _ : fin l_tm, fin m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (ren_tm zeta_tm) sigma x) (theta x)) :
  forall x,
  eq
    (funcomp (ren_tm (upRen_list_tm_tm p zeta_tm)) (up_list_tm_tm p sigma) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ _ n)
    (scons_p_congr (fun x => ap (var_tm (plus p m_tm)) (scons_p_head' _ _ x))
       (fun n =>
        eq_trans
          (compRenRen_tm (shift_p p) (upRen_list_tm_tm p zeta_tm)
             (funcomp (shift_p p) zeta_tm) (fun x => scons_p_tail' _ _ x)
             (sigma n))
          (eq_trans
             (eq_sym
                (compRenRen_tm zeta_tm (shift_p p)
                   (funcomp (shift_p p) zeta_tm) (fun x => eq_refl) (sigma n)))
             (ap (ren_tm (shift_p p)) (Eq n))))).
Fixpoint compSubstRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm k_tm)
(zeta_tm : forall _ : fin k_tm, fin l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp (ren_tm zeta_tm) sigma_tm x) (theta_tm x))
(s : tm m_tm) :
eq (ren_tm zeta_tm (subst_tm sigma_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (cod_comp (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (compSubstRen_tm (up_list_tm_tm p sigma_tm)
           (upRen_list_tm_tm p zeta_tm) (up_list_tm_tm p theta_tm)
           (up_subst_ren_list_tm_tm _ _ _ Eq_tm) s0)
  end.
Definition up_subst_subst_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : forall _ : fin k, tm l_tm) (tau_tm : forall _ : fin l_tm, tm m_tm)
  (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (subst_tm tau_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x)
    (up_tm_tm theta x) :=
  fun n =>
  match n with
  | Some fin_n =>
      eq_trans
        (compRenSubst_tm shift (up_tm_tm tau_tm)
           (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl) (sigma fin_n))
        (eq_trans
           (eq_sym
              (compSubstRen_tm tau_tm shift (funcomp (ren_tm shift) tau_tm)
                 (fun x => eq_refl) (sigma fin_n)))
           (ap (ren_tm shift) (Eq fin_n)))
  | None => eq_refl
  end.
Definition up_subst_subst_list_tm_tm {p : nat} {k : nat} {l_tm : nat}
  {m_tm : nat} (sigma : forall _ : fin k, tm l_tm)
  (tau_tm : forall _ : fin l_tm, tm m_tm) (theta : forall _ : fin k, tm m_tm)
  (Eq : forall x, eq (funcomp (subst_tm tau_tm) sigma x) (theta x)) :
  forall x,
  eq (funcomp (subst_tm (up_list_tm_tm p tau_tm)) (up_list_tm_tm p sigma) x)
    (up_list_tm_tm p theta x) :=
  fun n =>
  eq_trans (scons_p_comp' (funcomp (var_tm (plus p l_tm)) (zero_p p)) _ _ n)
    (scons_p_congr
       (fun x => scons_p_head' _ (fun z => ren_tm (shift_p p) _) x)
       (fun n =>
        eq_trans
          (compRenSubst_tm (shift_p p) (up_list_tm_tm p tau_tm)
             (funcomp (up_list_tm_tm p tau_tm) (shift_p p))
             (fun x => eq_refl) (sigma n))
          (eq_trans
             (eq_sym
                (compSubstRen_tm tau_tm (shift_p p) _
                   (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n)))
             (ap (ren_tm (shift_p p)) (Eq n))))).
Fixpoint compSubstSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : forall _ : fin m_tm, tm k_tm)
(tau_tm : forall _ : fin k_tm, tm l_tm)
(theta_tm : forall _ : fin m_tm, tm l_tm)
(Eq_tm : forall x, eq (funcomp (subst_tm tau_tm) sigma_tm x) (theta_tm x))
(s : tm m_tm) :
eq (subst_tm tau_tm (subst_tm sigma_tm s)) (subst_tm theta_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (cod_comp (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (compSubstSubst_tm (up_list_tm_tm p sigma_tm)
           (up_list_tm_tm p tau_tm) (up_list_tm_tm p theta_tm)
           (up_subst_subst_list_tm_tm _ _ _ Eq_tm) s0)
  end.
Definition rinstInst_up_tm_tm {m : nat} {n_tm : nat}
  (xi : forall _ : fin m, fin n_tm) (sigma : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (funcomp (var_tm n_tm) xi x) (sigma x)) :
  forall x,
  eq (funcomp (var_tm (S n_tm)) (upRen_tm_tm xi) x) (up_tm_tm sigma x) :=
  fun n =>
  match n with
  | Some fin_n => ap (ren_tm shift) (Eq fin_n)
  | None => eq_refl
  end.
Definition rinstInst_up_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (xi : forall _ : fin m, fin n_tm) (sigma : forall _ : fin m, tm n_tm)
  (Eq : forall x, eq (funcomp (var_tm n_tm) xi x) (sigma x)) :
  forall x,
  eq (funcomp (var_tm (plus p n_tm)) (upRen_list_tm_tm p xi) x)
    (up_list_tm_tm p sigma x) :=
  fun n =>
  eq_trans (scons_p_comp' _ _ (var_tm (plus p n_tm)) n)
    (scons_p_congr (fun z => eq_refl)
       (fun n => ap (ren_tm (shift_p p)) (Eq n))).
Fixpoint rinst_inst_tm {m_tm : nat} {n_tm : nat}
(xi_tm : forall _ : fin m_tm, fin n_tm)
(sigma_tm : forall _ : fin m_tm, tm n_tm)
(Eq_tm : forall x, eq (funcomp (var_tm n_tm) xi_tm x) (sigma_tm x))
(s : tm m_tm) : eq (ren_tm xi_tm s) (subst_tm sigma_tm s) :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ p s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (cod_ext (rinst_inst_tm xi_tm sigma_tm Eq_tm) s1)
  | lam _ p s0 =>
      congr_lam
        (rinst_inst_tm (upRen_list_tm_tm p xi_tm) (up_list_tm_tm p sigma_tm)
           (rinstInst_up_list_tm_tm _ _ Eq_tm) s0)
  end.
Lemma rinstInst_tm {m_tm : nat} {n_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin n_tm) :
  eq (ren_tm xi_tm) (subst_tm (funcomp (var_tm n_tm) xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.
Lemma instId_tm {m_tm : nat} : eq (subst_tm (var_tm m_tm)) id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.
Lemma rinstId_tm {m_tm : nat} : eq (@ren_tm m_tm m_tm id) id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.
Lemma varL_tm {m_tm : nat} {n_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm n_tm) :
  eq (funcomp (subst_tm sigma_tm) (var_tm m_tm)) sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).
Qed.
Lemma varLRen_tm {m_tm : nat} {n_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin n_tm) :
  eq (funcomp (ren_tm xi_tm) (var_tm m_tm)) (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun x => eq_refl)).
Qed.
Lemma renRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) (s : tm m_tm) :
  eq (ren_tm zeta_tm (ren_tm xi_tm s)) (ren_tm (funcomp zeta_tm xi_tm) s).
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.
Lemma renRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) :
  eq (funcomp (ren_tm zeta_tm) (ren_tm xi_tm))
    (ren_tm (funcomp zeta_tm xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.
Lemma compRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) (s : tm m_tm) :
  eq (ren_tm zeta_tm (subst_tm sigma_tm s))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s).
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.
Lemma compRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (zeta_tm : forall _ : fin k_tm, fin l_tm) :
  eq (funcomp (ren_tm zeta_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compRen_tm sigma_tm zeta_tm n)).
Qed.
Lemma renComp_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) (s : tm m_tm) :
  eq (subst_tm tau_tm (ren_tm xi_tm s)) (subst_tm (funcomp tau_tm xi_tm) s).
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.
Lemma renComp'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : forall _ : fin m_tm, fin k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) :
  eq (funcomp (subst_tm tau_tm) (ren_tm xi_tm))
    (subst_tm (funcomp tau_tm xi_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => renComp_tm xi_tm tau_tm n)).
Qed.
Lemma compComp_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) (s : tm m_tm) :
  eq (subst_tm tau_tm (subst_tm sigma_tm s))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s).
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.
Lemma compComp'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : forall _ : fin m_tm, tm k_tm)
  (tau_tm : forall _ : fin k_tm, tm l_tm) :
  eq (funcomp (subst_tm tau_tm) (subst_tm sigma_tm))
    (subst_tm (funcomp (subst_tm tau_tm) sigma_tm)).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
                (fun n => compComp_tm sigma_tm tau_tm n)).
Qed.

Arguments var_tm {n_tm}.

Arguments app {n_tm}.

Arguments lam {n_tm}.

Global Instance Subst_tm { m_tm : nat } { n_tm : nat } : Subst1 ((fin) (m_tm) -> tm (n_tm)) (tm (m_tm)) (tm (n_tm)) := @subst_tm (m_tm) (n_tm) .

Global Instance Ren_tm { m_tm : nat } { n_tm : nat } : Ren1 ((fin) (m_tm) -> (fin) (n_tm)) (tm (m_tm)) (tm (n_tm)) := @ren_tm (m_tm) (n_tm) .

Global Instance VarInstance_tm { m_tm : nat } : Var ((fin) (m_tm)) (tm (m_tm)) := @var_tm (m_tm) .

Notation "x '__tm'" := (var_tm x) (at level 5, format "x __tm") : subst_scope.

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

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

Class Up_tm X Y := up_tm : X -> Y.

Notation "↑__tm" := (up_tm) (only printing) : subst_scope.

Notation "↑__tm" := (up_tm_tm) (only printing) : subst_scope.

Global Instance Up_tm_tm { m : nat } { n_tm : nat } : Up_tm (_) (_) := @up_tm_tm (m) (n_tm) .

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

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

Notation "s ⟨ xitm ⟩" := (ren_tm xitm s) (at level 7, left associativity, only printing) : subst_scope.

Notation "⟨ xitm ⟩" := (ren_tm xitm) (at level 1, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_tm,  Ren_tm,  VarInstance_tm.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_tm,  Ren_tm,  VarInstance_tm in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_tm| progress rewrite ?compComp_tm| progress rewrite ?compComp'_tm| progress rewrite ?rinstId_tm| progress rewrite ?compRen_tm| progress rewrite ?compRen'_tm| progress rewrite ?renComp_tm| progress rewrite ?renComp'_tm| progress rewrite ?renRen_tm| progress rewrite ?renRen'_tm| progress rewrite ?varL_tm| progress rewrite ?varLRen_tm| progress (unfold up_ren, upRen_tm_tm, upRen_list_tm_tm, up_tm_tm, up_list_tm_tm)| progress (cbn [subst_tm ren_tm])| 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_tm in *| progress rewrite ?compComp_tm in *| progress rewrite ?compComp'_tm in *| progress rewrite ?rinstId_tm in *| progress rewrite ?compRen_tm in *| progress rewrite ?compRen'_tm in *| progress rewrite ?renComp_tm in *| progress rewrite ?renComp'_tm in *| progress rewrite ?renRen_tm in *| progress rewrite ?renRen'_tm in *| progress rewrite ?varL_tm in *| progress rewrite ?varLRen_tm in *| progress (unfold up_ren, upRen_tm_tm, upRen_list_tm_tm, up_tm_tm, up_list_tm_tm in *)| progress (cbn [subst_tm ren_tm] in *)| fsimpl in *].

Ltac substify := auto_unfold; try repeat (erewrite rinstInst_tm).

Ltac renamify := auto_unfold; try repeat (erewrite <- rinstInst_tm).


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

Class Semigroup (A : Type) : Type := mkSemigroup
  { binop : A -> A -> A
  ; assoc : forall a b c : A,
      binop a (binop b c) = binop (binop a b) c
  }.

Inductive Cost : nat -> Type -> Type :=
  mkCost : forall n A, A -> Cost n A.

Definition unCost {n A} (c : Cost n A) :=
  match c with
  | mkCost _ x => x
  end.

Lemma unCost_mkCost_id {n A} : forall x : A, unCost (mkCost n x) = x.
Proof. reflexivity. Qed.

Definition pure {n A} (x : A) := mkCost n x.

Definition bind {m n A B} (ma : Cost m A) (k : A -> Cost n B) : Cost (m + n) B.
  destruct ma as [m A x].
  refine (mkCost _ (unCost (k x))).
Defined.

Fixpoint doTimes {A m} (S : Semigroup A) n (c : Cost m A) (acc : A) : Cost (n * m) A :=
  match n with
  | 0    => pure acc
  | S n' => bind c (fun a => doTimes S n' c (binop acc a))
  end.

Require Import Arith List Program String.

Open Scope string_scope.
Lemma append_assoc (s1 s2 s3 : string) : s1 ++ s2 ++ s3 = (s1 ++ s2) ++ s3.
Proof.
  induction s1.
  - reflexivity.
  - now cbn; rewrite IHs1.
Qed.

Instance list_Semigroup A : Semigroup (list A) :=
  mkSemigroup (@app_assoc A).
Instance string_Semigroup : Semigroup string :=
  mkSemigroup append_assoc.

Program Fixpoint day n : Cost (fact n) string :=
  match n with
  | 0    => pure "."
  | S n' => doTimes string_Semigroup n (day n') "$"
  end.

Compute day 4.