From Coq Require Import ZArith Reals Psatz.
From Flocq Require Import Binary.
From mathcomp Require Import all_ssreflect ssralg all_algebra seq matrix.

Import List ListNotations.

From vcfloat Require Import FPLang FPLangOpt RAux Rounding Reify Float_notations Automate.
Set Bullet Behavior "Strict Subproofs".

Require Import floatlib.

Section WITHNANS.
Context {NANS: Nans}.

Definition sum ty (a b : ftype ty) : ftype ty := BPLUS a b.

Definition list_to_vec_float {ty} {n:nat}
(l : list (ftype ty)): 'cV[ftype ty]_n :=
\col_(i < n) (List.nth (nat_of_ord i) l (Zconst ty 0)).

(** Define matrix_addition **)
Definition addmx_float {ty} {m n:nat} (A B: 'M[ftype ty]_(m,n))
  : 'M[ftype ty]_(m,n) :=
  \matrix_(i, j) (sum ty (A i j) (B i j)).

Fixpoint vec_to_list_float {ty} {n:nat} (m:nat) (v :'cV[ftype ty]_n.+1)
   : list (ftype ty) :=
   match m with
   | O => []
   | S p => [v (@inord n p) ord0] ++ vec_to_list_float p v
   end.

Definition vec_to_list_float_1 {ty} {n:nat} (m:nat) (v :'cV[ftype ty]_n.+1) :=
  rev (vec_to_list_float m v).

Lemma nth_vec_to_list_float {ty} {n:nat} i m (v :'cV[ftype ty]_n.+1) d:
  (i < m)%nat ->
  nth (m.-1 -i) (@vec_to_list_float _ n m v) d = v (@inord n i) ord0.
Proof.
intros.
elim: m i H => [ | m IHm] i H.
+ by [].
+ simpl.
  rewrite leq_eqVlt in H.
  assert ((i == m) \/ (i < m)%nat).
  { by apply /orP. } destruct H0.
  - assert (i = m). { by apply /eqP. }
    rewrite H1. simpl.
    assert ((m - m)%nat = 0%N).
    { apply /eqP. rewrite subn_eq0. by []. } by rewrite H2 /=.
  - assert (nth (m.-1 - i) (vec_to_list_float m v)
                d = v (inord i) ord0).
    { by apply IHm. }
    rewrite -H1. rewrite -[in RHS]predn_sub.
    rewrite -subn_gt0 in H0. rewrite -predn_sub in H1.
    by destruct (m - i)%nat.
Qed.

Definition dotprod_r {t: type} (v1 v2: list (ftype t)) : ftype t :=
  fold_right (fun x12 s => BFMA (fst x12) (snd x12) s)
                 (Zconst t 0) (List.combine v1 v2)  .

Lemma combine_rev {ty}:
forall (v1 v2: vector ty),
  length v1 = length v2 ->
  (combine (rev v1) (rev v2)) = rev (combine v1 v2).
Proof.
intros.
elim: v1 v2 H => [ |s v1 IHv1] v2 H.
+ simpl;auto.
+ destruct v2.
  - by simpl in H.
  - specialize (IHv1 v2).
    assert (length v1 = length v2).
    { simpl in H. lia. } specialize (IHv1 H0).
    simpl. rewrite -IHv1.
    assert (length (rev v1) = length (rev v2)).
    { by rewrite !rev_length. }
    clear IHv1 H H0.
    elim: (rev v1) (rev v2) H1  => [ |a1 v3 IHv3] v4 H.
    * destruct v4.
      ++ simpl;auto.
      ++ by simpl in H.
    * destruct v4.
      ++ by simpl in H.
      ++ simpl. rewrite IHv3; try by [].
         simpl in H. lia.
Qed.

Lemma dotprod_rev_equiv {ty} (v1 v2: vector ty):
  length v1 = length v2 ->
  dotprod (rev v1) (rev v2) = dotprod_r v1 v2.
Proof.
intros.
unfold dotprod, dotprod_r.
assert (combine (rev v1) (rev v2) = rev (combine v1 v2)).
{ by rewrite combine_rev. } rewrite H0.
rewrite <-fold_left_rev_right.
rewrite rev_involutive. reflexivity.
Qed.

(** The issue is that b could appear more than once in the list.
    So the current version of lemma is not correct
***)
(*
Lemma fold_right_except_zero {A B}
  (f: B -> A -> A) (a : A) (L: list B) (b :  B) :
  In b L ->
  (forall s d, In s L -> s <> b -> f s d = d) ->
  fold_right f a L = f b a.
Admitted.
*)

Definition mulmx_float {ty} {m n p : nat}
  (A: 'M[ftype ty]_(m.+1,n.+1)) (B: 'M[ftype ty]_(n.+1,p.+1)) :
  'M[ftype ty]_(m.+1,p.+1):=
  \matrix_(i, k)
    let l1 := vec_to_list_float n.+1 (\row_(j < n.+1) A i j)^T in
    let l2 := vec_to_list_float n.+1 (\col_(j < n.+1) B j k) in
    @dotprod_r ty l1 l2.

Definition opp_mat {ty} {m n: nat} (A : 'M[ftype ty]_(m.+1, n.+1))
  : 'M[ftype ty]_(m.+1, n.+1) :=
  \matrix_(i,j) (BOPP (A i j)).

Definition sub_mat {ty} {m n: nat} (A B : 'M[ftype ty]_(m.+1, n.+1))
  : 'M[ftype ty]_(m.+1, n.+1) :=
  \matrix_(i,j) (BMINUS (A i j) (B i j)).

Notation "A +f B" := (addmx_float A B) (at level 80).
Notation "-f A" := (opp_mat A) (at level 50).
Notation "A *f B" := (mulmx_float A B) (at level 70).
Notation "A -f B" := (sub_mat A B) (at level 80).

Definition A1_inv_J {ty} {n:nat} (A: 'M[ftype ty]_n.+1) : 'cV[ftype ty]_n.+1 :=
  \col_i (BDIV (Zconst ty 1) (A i i)).

Definition A2_J {ty} {n:nat} (A: 'M[ftype ty]_n.+1):
  'M[ftype ty]_n.+1 :=
  \matrix_(i,j)
    if (i==j :> nat) then (Zconst ty 0) else A i j.

Definition diag_vector_mult {ty} {n:nat} (v1 v2: 'cV[ftype ty]_n.+1)
  : 'cV[ftype ty]_n.+1 :=
  \col_i (BMULT (nth (n.+1.-1 -i) (vec_to_list_float n.+1 v1) (Zconst ty 0))
            (nth (n.+1.-1 - i) (vec_to_list_float n.+1 v2) (Zconst ty 0))).

Definition jacobi_iter {ty} {n:nat} x0 b (A: 'M[ftype ty]_n.+1) :
  'cV[ftype ty]_n.+1 :=
   let r := b -f ((A2_J A) *f x0) in
   diag_vector_mult (A1_inv_J A) r.

Definition X_m_jacobi {ty} {n:nat} m x0 b (A: 'M[ftype ty]_n.+1) :
  'cV[ftype ty]_n.+1 :=
   Nat.iter m  (fun x0 => jacobi_iter x0 b A) x0.

Definition matrix_inj' {t} (A: matrix t) m n  d d': 'M[ftype t]_(m,n):=
    \matrix_(i < m, j < n)
     nth j (nth i A d) d'.

Definition matrix_inj {t} (A: matrix t) m n  : 'M[ftype t]_(m,n):=
  matrix_inj' A m n [::] (Zconst t 0).

Definition vector_inj' {t} (v: vector t) n d : 'cV[ftype t]_n :=
   \col_(i < n) nth i v d.

Definition vector_inj {t} (v: vector t) n : 'cV[ftype t]_n :=
   vector_inj' v n (Zconst t 0).

Lemma length_veclist {ty} {n m:nat} (v: 'cV[ftype ty]_n.+1):
  length (@vec_to_list_float _ n m v) = m.
Proof.
induction m.
+ simpl. auto.
+ simpl. by rewrite IHm.
Qed.

Definition FT2R_mat {m n: nat} {ty} (A : 'M[ftype ty]_(m.+1, n.+1)) :
   'M[R]_(m.+1, n.+1):=
  \matrix_(i, j) FT2R (A i j).

End WITHNANS.


Add LoadPath "C:\Users\Hp\Documents\CoqGit\Rel" as CoqRelDir.

Load RelEuclDiv.

Definition CongMod (k : rel) (x y : rel) : Prop :=
  ( ∃ q : rel, x == q*k + y ).

Notation "x ≡ y 'mod' k" := (CongMod k x y) (at level 50).

Instance sym_CongMod (k : rel) : Symmetric (CongMod k).
Proof.
  move => x y.
  case => q => Ck_xy.
  unfold "_ ≡ _ 'mod' _".
  exists (-q). ring [Ck_xy].
Qed.

Instance refl_CongMod (k : rel) : Reflexive (CongMod k).
Proof.
  move => x.
  exists O_Z. ring.
Qed.

Instance trans_CongMod (k : rel) : Transitive (CongMod k).
Proof.
  move => x y z.
  case => q_xy Ck_xy.
  case => q_yz Ck_yz.
  exists (q_xy + q_yz).
  ring [Ck_xy Ck_yz].
Qed.

Instance equiv_CongMod (k : rel) : Equivalence (CongMod k).
Proof.
  split.
  apply refl_CongMod.
  apply sym_CongMod.
  apply trans_CongMod.
Qed.

Instance CongMod_Proper (k : rel) : Proper (rel_eq ==> rel_eq ==> iff) (CongMod k).
Proof.
  move => x x' Eqxx' y y' Eqyy'.
  unfold "_ ≡ _ mod _ ".
  split.
    case => q H. exists q.
    setoid_rewrite <-Eqxx'.
    setoid_rewrite <-Eqyy'.
    assumption.
    case => q H. exists q.
    setoid_rewrite Eqxx'.
    setoid_rewrite Eqyy'.
    assumption.
Qed.

Example test_CongMod_Propper : forall k x y z t : rel,
  (x == y) -> (y == z) -> (z == t) -> ( x ≡ t mod k ) .
Proof.
  move => k x y z t.
  move => -> -> ->.
  reflexivity.
Qed.

Lemma simpl_CongMod0 : ∀ y M : rel, M > O_Z -> O_Z <= y -> y < M -> O_Z ≡ y mod M -> O_Z == y.
Proof.
  move => y M Mspos y_pos y_infM.
  unfold CongMod.
  intro congr; inversion congr; clear congr.

  assert ((x == O_Z) \/ (x > O_Z) \/ (x < O_Z)) as Disj.
  case x as [x_0 x_1].
  unfold "==", "<", O_Z.
  lia.

  case Disj.

  + move => Eqx0.
    setoid_rewrite Eqx0 in H.
    ring_simplify in H; fold O_Z in H.
    assumption.

  + case => Hx.
    assert (x * M + y > O_Z).
      assert (O_Z < x * M) as H1 by apply relspos_prod => //.
      apply (@rel_plusProper_ltle O_Z (x * M) H1 O_Z y) => //.
    rewrite <-H in H0.
    unfold O_Z, rel_lt in H0; lia.

    assert (x * M + y < O_Z ).
      assert (x * M <= - M) as H1 by apply rel_spos_sneg_prod => //.
      assert (x * M < - y) as H2.
        assert (- M < - y) by apply rel_minusProper_lt => //.
        apply (@rel_lelt_lt (x * M) (- M) (- y)) => //.
        assert (y <= y) by reflexivity.
      pose H3 := (@rel_plusProper_ltle (x * M) (- y) H2 y y H0).
      ring_simplify in H3; fold O_Z in H3; assumption.
      rewrite <-H in H0. unfold "<", O_Z in H0. lia.
Qed.


Require Export P14.

(** **** Exercise: 3 stars, optional (inequiv_exercise)  *)
(** Prove that an infinite loop is not equivalent to [SKIP] *)

Theorem loop_never_stops : forall st st',
  ~(loop / st \\ st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef
           eqn:Heqloopdef.
  induction contra; inversion Heqloopdef.
  - (* WhileEnd *) rewrite H1 in H. inversion H.
  - (* WhileLoop *) subst. contradiction.
Qed.

Theorem inequiv_exercise:
  ~ cequiv (WHILE BTrue DO SKIP END) SKIP.
Proof.
  intro H.
  eapply loop_never_stops with empty_state empty_state.
  unfold loop. apply H. constructor.
Qed.


Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d : day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday :
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition negb' (b : bool) : bool :=
  if b then false
  else true.

Example test_negb1 : (negb true) = false.
Proof. simpl. reflexivity. Qed.

Example test_negb2 : (negb false) = true.
Proof. simpl. reflexivity. Qed.

Definition andb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition andb' (b1 : bool) (b2 : bool) : bool :=
  if b1 then b2
  else false.

Notation "x && y" := (andb x y).

Example test_andb1 : (andb true false) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb2 : (andb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb3 : (andb false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb4 : (andb true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb5 : true && true && false = false.
Proof. simpl. reflexivity. Qed.

Definition orb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Definition orb' (b1 : bool) (b2 : bool) : bool :=
  if b1 then true
  else b2.

Notation "x || y" := (orb x y).

Example test_orb1 : (orb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb2 : (orb false false) = false.
Proof. simpl. reflexivity. Qed.

Example test_orb3 : (orb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb4 : (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_orb5 : false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition nandb (b1 : bool) (b2 : bool) : bool :=
  negb (andb b1 b2).

Example test_nandb1 : (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb2 : (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb3 : (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nandb4 : (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b1 : bool) (b2 : bool) (b3 : bool) : bool :=
  andb b1 (andb b2 b3).

Example test_monochrome : (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.

Example test_andb32 : (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb33 : (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.

Example test_andb34 : (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | primary p => false
  | _ => true
  end.

Example test_monochrome1 : (monochrome (black)) = true.
Proof. simpl. reflexivity. Qed.

Example test_monochrome2 : (monochrome (white)) = true.
Proof. simpl. reflexivity. Qed.

Example test_monochrome3 : (monochrome (primary blue)) = false.
Proof. simpl. reflexivity. Qed.

Definition isred (c : color) : bool :=
  match c with
  | primary red => true
  | _ => false
  end.

Compute (isred (primary red)).
Compute (isred (black)).
Compute (isred (white)).
Compute (isred (primary blue)).
Compute (isred (primary green)).

Example test_isred1 : (isred (primary red)) = true.
Proof. simpl. reflexivity. Qed.

Example test_isred2 : (isred (primary blue)) = false.
Proof. simpl. reflexivity. Qed.

Example test_isred3 : (isred black) = false.
Proof. simpl. reflexivity. Qed.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.
  Inductive bit : Type :=
    | B0
    | B1.

  Inductive nybble : Type :=
    | bits (b0 b1 b2 b3 : bit).

  Check (bits B1 B0 B1 B0)
    : nybble.

  Definition all_zero (nb : nybble) : bool :=
    match nb with
    | bits B0 B0 B0 B0 => true
    | _ => false
    end.

  Compute (all_zero (bits B1 B0 B1 B0)).

  Compute (all_zero (bits B0 B0 B0 B0)).
End TuplePlayground.

Module NatPlayground.
  Inductive nat : Type :=
    | O
    | S (n : nat).

  Inductive nat' : Type :=
    | stop
    | tick (foo : nat').

  Definition pred (n : nat) : nat :=
    match n with
    | O => O
    | S n' => n'
    end.
End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1 : odd 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_odd2 : odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.
  Fixpoint plus (n : nat) (m : nat) : nat :=
    match n with
    | O => m
    | S n' => S (plus n' m)
    end.

  Compute (plus 3 2).

  Fixpoint mult (n m : nat) : nat :=
    match n with
    | O => O
    | S n' => plus m (mult n' m)
    end.

  Fixpoint minus (n m : nat) : nat :=
    match n, m with
    | O, _ => O
    | _, O => n
    | S n', S m' => minus n' m'
    end.
End NatPlayground2.

Fixpoint exp (b p : nat) : nat :=
  match p with
  | O => S O
  | S p' => mult b (exp b p')
  end.

Fixpoint factorial (n : nat) : nat :=
  match n with
  | O => S O
  | S n' => mult n (factorial n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                    (at level 50, left associativity)
                    : nat_scope.

Notation "x - y" := (minus x y)
                    (at level 50, left associativity)
                    : nat_scope.

Notation "x * y" := (mult x y)
                    (at level 40, left associativity)
                    : nat_scope.

Check ((0 + 1) + 1) : nat.

Fixpoint eqb (n m : nat) : bool :=
  match n, m with
  | O, O => true
  | S n', S m' => eqb n' m'
  | _, _ => false
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Example test_eqb1 : eqb 0 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_eqb2 : eqb 1 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_eqb3 : eqb 4 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_eqb4 : 1 =? 1 = true.
Proof. simpl. reflexivity. Qed.

Fixpoint leb (n m : nat) : bool :=
  match n, m with
  | O, _ => true
  | S n', S m' => leb n' m'
  | _, _ => false
  end.

Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.

Example test_leb1 : leb 0 0 = true.
Proof. simpl. reflexivity. Qed.

Example test_leb2 : leb 1 3 = true.
Proof. simpl. reflexivity. Qed.

Example test_leb3 : leb 5 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_leb4 : 1 <=? 2 = true.
Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  if eqb n m then false
  else leb n m.

Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.

Example test_ltb1 : ltb 0 1 = true.
Proof. simpl. reflexivity. Qed.

Example test_ltb2 : ltb 0 0 = false.
Proof. simpl. reflexivity. Qed.

Example test_ltb3 : ltb 5 2 = false.
Proof. simpl. reflexivity. Qed.

Example test_ltb4 : 1 <? 2 = true.
Proof. simpl. reflexivity. Qed.

Theorem plus_0_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_0_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_0_n'' : forall n : nat, 0 + n = n.
Proof.
  intros m. reflexivity. Qed.

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof.
  intros n. reflexivity. Qed.

Theorem mult_0_l : forall n : nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m : nat,
  n = m ->
  n + m = m + m.

Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity. Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m ->
  m = o ->
  n + m = m + o.

Proof.
  intros n m o.
  intros H.
  intros G.
  rewrite -> H.
  rewrite -> G.
  reflexivity. Qed.

Check mult_n_O.

Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros n. destruct n as [| n'] eqn : E.
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn : E.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn : Eb.
  - destruct c eqn : Ec.
    + reflexivity.
    + reflexivity.
  - destruct c eqn : Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn : Eb.
  { destruct c eqn : Ec.
    { reflexivity. }
    { reflexivity. } }
  { destruct c eqn : Ec.
    { reflexivity. }
    { reflexivity. } }
Qed.

Theorem andb3_exchange : forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn : Eb.
  - destruct c eqn : Ec.
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn : Ec.
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn : Ed.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros b c. destruct c eqn : Ec.
  - reflexivity.
  - intros H. rewrite <- H. destruct b eqn : Eb.
    + reflexivity.
    + reflexivity.
Qed.

Theorem plus_1_neq_0' : forall n : nat,
  (n + 1) =? 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative'' : forall b c,
  andb c b = andb b c.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [|n].
    - reflexivity.
    - reflexivity.
Qed.

(* Level means precendence level, 1 + 2 * 3 * 4 -> (1 + ((2 * 3) * 4)) *)
(* Coq tries to understand context with scopes, type_scope *)
Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.

Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

(* plus' is performing structural recursion on `n` (descreasing)
  That implies that all calls of plus' will terminate.
  Coq demands that. *)
Fixpoint plus' (n m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus' n' m)
  end.

Theorem identity_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool), (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros f H b.
  rewrite -> H.
  rewrite -> H.
  destruct b eqn : Eb.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_eq_orb :
  forall (b c : bool), (andb b c = orb b c) ->
  b = c.
Proof.
  intros [] c.
  - simpl. intros H. rewrite <- H. reflexivity.
  - simpl. intros H. rewrite <- H. reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B0 (n : bin)
  | B1 (n : bin).

Fixpoint incr (b : bin) : bin :=
  match b with
  | Z => B1 Z
  | B0 b' => B1 b'
  | B1 b' => B0 (incr b')
  end.

Fixpoint bin_to_nat (b : bin) : nat :=
  match b with
  | Z => 0
  | B0 b' => 2 * (bin_to_nat b')
  | B1 b' => 1 + 2 * (bin_to_nat b')
  end.

Example test_bin_incr1 : (incr (B1 Z)) = B0 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr2 : (incr (B0 (B1 Z))) = B1 (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr3 : (incr (B1 (B1 Z))) = B0 (B0 (B1 Z)).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr4 : bin_to_nat (B0 (B1 Z)) = 2.
Proof. simpl. reflexivity. Qed.

Example test_bin_incr5 :
        bin_to_nat (incr (B1 Z)) = 1 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.

Example test_bin_incr6 :
        bin_to_nat (incr (incr (B1 Z))) = 2 + bin_to_nat (B1 Z).
Proof. simpl. reflexivity. Qed.


Require Export PredMonad.Ordered6.OrderedType.

(***
 *** The monad typeclass
 ***)

Class MonadOps (M: OType -> OType) : Type :=
  { returnM : forall {A}, A -o> M A;
    bindM : forall {A B}, M A -o> (A -o> M B) -o> M B }.

Class Monad M `{MOps:MonadOps M} : Prop :=
  {
    monad_return_bind :
      forall A B (f: A -o> M B) x,
        bindM @o@ (returnM @o@ x) @o@ f =o= f @o@ x;

    monad_bind_return :
      forall A (m : M A), bindM @o@ m @o@ returnM =o= m;

    monad_assoc :
      forall A B C m (f: A -o> M B) (g: B -o> M C),
        bindM @o@ (bindM @o@ m @o@ f) @o@ g
        =o=
        bindM @o@ m @o@ (mkOTerm _ (fun x => bindM @o@ (f @o@ x) @o@ g));
  }.

(* Helpful bind notation *)
Notation "'do' x <- m1 ; m2" :=
  (bindM @o@ m1 @o@ (mkOTerm _ (fun x => m2))) (at level 60, right associativity).

(* Add the monad laws to the OT rewrite set *)
Hint Rewrite @monad_return_bind @monad_bind_return @monad_assoc : OT.

(***
 *** The Identity Monad
 ***)

Definition Identity (A:OType) := A.

Instance IdMonad_MonadOps : MonadOps Identity :=
  { returnM := fun A => mkOTerm (A -o> Identity A) (fun x => x);
    bindM := fun A B =>
               mkOTerm (A -o> (A -o> B) -o> B)
                       (fun m (f:Pfun A B) => f @o@ m) }.

Instance IdMonad : Monad Identity.
Proof.
  constructor; intros; simpl; reflexivity.
Qed.


Set Implicit Arguments.
Require Import List Morphisms FinFun.
From Undecidability.HOU Require Import std.tactics std.ars.basic std.ars.confluence.
Import ListNotations.

Set Default Proof Using "Type".

Section ListRelations.

  Variable (X : Type) (R: X -> X -> Prop).
  Inductive lstep: list X -> list X -> Prop :=
  | stepHead s s' A: R s s' -> lstep (s :: A) (s' :: A)
  | stepTail s A A': lstep A A' -> lstep (s :: A) (s :: A').

  Hint Constructors lstep : core.

  Lemma lstep_cons_nil S:
    lstep S nil -> False.
  Proof.
    intros. inv H.
  Qed.

  Lemma lsteps_cons_nil s S:
    star lstep (s :: S) nil -> False.
  Proof.
    intros. remember (s :: S) as S'. remember nil as T.  revert S s HeqS' HeqT.
    induction H.
    - intros; subst; discriminate.
    - intros; subst. inv H; eapply IHstar; eauto.
  Qed.

  Lemma lstep_nil_cons S:
    lstep nil S -> False.
  Proof.
    intros H. inv H.
  Qed.

  Lemma lsteps_nil_cons s S:
    star lstep nil (s :: S) -> False.
  Proof.
    intros H. inv H.
    eapply lstep_nil_cons; eauto.
  Qed.

  Lemma lsteps_cons_inv s t S T:
    star lstep (s :: S) (t :: T) -> star R s t /\ star lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst. intuition.
    - subst. inv H.
      + destruct (IHstar s' t S T); eauto.
      + destruct (IHstar s t A' T); eauto.
  Qed.

  Global Instance lsteps_cons :
    Proper (star R ++> star lstep ++> star lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; eauto.
  Qed.

  Lemma confluence_lstep:
    confluent R -> confluent lstep.
  Proof.
    intros conf ?. induction x; intros.
    - inv H. inv H0. exists nil; eauto. inv H. inv H1.
    - destruct y, z; try solve [exfalso; eapply lsteps_cons_nil; eauto].
      eapply lsteps_cons_inv in H; eapply lsteps_cons_inv in H0.
      intuition; destruct (IHx _ _ H2 H3) as [V].
      destruct (conf _ _ _ H1 H) as [v].
      exists (v :: V).
      now rewrite H5, H0. now rewrite H6, H4.
  Qed.

  Hint Resolve confluence_lstep : core.

  Lemma normal_lstep_in A:
    Normal lstep A -> forall x, In x A  -> Normal R x.
  Proof.
    induction A; cbn; intuition; subst; eauto.
    intros ? H1. eapply H. constructor. eassumption.
    eapply IHA; eauto. intros ? H2. eapply H.
    econstructor 2; eauto.
  Qed.

  Lemma normal_in_lstep A:
    (forall x, In x A  -> Normal R x) -> Normal lstep A.
  Proof.
    induction A; cbn; intuition.
    - intros ? H1. inv H1.
    - intros ? H1. inv H1.
      eapply H; eauto.
      eapply IHA; eauto.
  Qed.

  Lemma lstep_normal_cons_l a A:
    Normal lstep (a :: A) -> Normal R a.
  Proof. intros ? ? ?. eapply H; econstructor; eauto. Qed.

  Lemma lstep_normal_cons_r a A:
    Normal lstep (a :: A) -> Normal lstep A.
  Proof. intros ? ? ?. eapply H; econstructor 2; eauto. Qed.

  Lemma lstep_normal_cons a A:
    Normal R a -> Normal lstep A -> Normal lstep (a :: A).
  Proof. intros ? ? ? ?. inv H1; firstorder.  Qed.

  Lemma lstep_normal_nil:
    Normal lstep nil.
  Proof. intros ? H; inv H. Qed.

  Hint Resolve
       lstep_normal_nil
       lstep_normal_cons_l
       lstep_normal_cons_r
       lstep_normal_cons : core.

  Hint Resolve normal_lstep_in normal_in_lstep : core.

  Lemma equiv_lstep_cons_inv s t S T:
    equiv lstep (s :: S) (t :: T) -> equiv R s t /\ equiv lstep S T.
  Proof.
    intros H. remember (s :: S) as S'. remember (t :: T) as T'.
    revert s t S T HeqS' HeqT'.
    induction H; intros.
    - subst. injection HeqT' as ??; subst; intuition.
    - subst. inv H.
      + destruct x'. eapply lstep_cons_nil in H1 as [].
        edestruct IHstar; eauto. inv H1.
        * intuition.
          transitivity x; eauto.
        * intuition. transitivity x'; eauto.
      + destruct x'. eapply lstep_nil_cons in H1 as [].
        edestruct IHstar; eauto. inv H1; intuition.
        * transitivity x; eauto.
        * transitivity x'; eauto.
  Qed.

  Global Instance equiv_lstep_cons_proper:
    Proper (equiv R ++> equiv lstep ++> equiv lstep) cons.
  Proof.
    intros ??; induction 1; intros ??; induction 1; eauto.
    - rewrite <-IHstar. destruct H.
      eauto. symmetry. eauto.
    - rewrite <-(IHstar x0 x0); try reflexivity.
      destruct H. eauto. symmetry. eauto.
    - rewrite <-IHstar0.
      destruct H1. eauto. symmetry. eauto.
  Qed.

  Lemma not_equiv_lstep_nil_cons a A:
    ~ equiv lstep nil (a :: A).
  Proof.
    intros H; inv H; inv H0; inv H.
  Qed.

  Lemma list_equiv_ind (P: list X -> list X -> Prop):
    P nil nil ->
    (forall s t S T, equiv R s t -> equiv lstep S T -> P S T -> P (s :: S) (t :: T)) ->
    forall S T, equiv lstep S T -> P S T.
  Proof.
    intros B IH S T H; induction S in T, H |-*; destruct T; eauto.
    - exfalso; eapply not_equiv_lstep_nil_cons; eauto.
    - exfalso; eapply not_equiv_lstep_nil_cons; symmetry; eauto.
    - eapply equiv_lstep_cons_inv in H as (? & ?).
      eapply IH; eauto.
  Qed.

End ListRelations.

#[export] Hint Constructors lstep : core.

#[export] Hint Resolve
     lstep_normal_nil
     lstep_normal_cons_l
     lstep_normal_cons_r
     lstep_normal_cons : core.

#[export] Hint Resolve confluence_lstep : core.
#[export] Hint Resolve normal_lstep_in normal_in_lstep : core.


(* ********************************************** *)
(* Types and Semantics for Programming Languages  *)
(* ********************************************** *)

(* Place an X in front of the appropriate statement *)
(* [ ]  I have done Problems 1 and 2 *)
(* [ ]  I have done Problems 1 and 3 *)

Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Export Maps.
Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive member {X : Type} : X -> list X -> Prop :=
   | member_here : forall x xs, member x (x::xs)
   | member_later : forall (x:X) xs x y,
       member x xs -> member x (y::xs).

Theorem app_member_left: forall (X:Type) (x:X) (xs ys : list X),
   member x xs -> member x (xs++ys).
Proof.
  intros.
  induction H.
  - simpl. apply member_here.
  - simpl. apply member_later. assumption. assumption.
Qed.

Theorem app_member_right : forall (X:Type) (x:X) (xs ys : list X),
   member x ys -> member x (xs ++ ys).
Proof.
  intros.
  induction xs.
  - simpl. assumption.
  - simpl. apply member_later. assumption... assumption.
Qed.

Theorem or_app_member: forall (X:Type) (x:X) (xs ys : list X),
    member x xs \/ member x ys -> member x (xs ++ ys).
Proof.
    intros.
    destruct H.
    - apply app_member_left. assumption.
    - apply app_member_right. assumption.
Qed.

Theorem app_or_member: forall (X:Type) (x:X) (xs ys : list X),
     member x (xs ++ ys) -> member x xs \/ member x ys.
Proof.
   intros.
   induction xs.
   - simpl in H. simpl. right. assumption.
   - simpl in H. inversion H. subst.
     + left. apply member_here.
     + subst. apply IHxs in H2. destruct H2.
       * left. apply member_later. assumption. assumption.
       * right. assumption.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* Arithmetic and boolean expressions *)

Definition state := total_map nat.

Definition ble_nat := leb.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation " 'REPEAT' c 'UNTIL' b 'END'" :=
  (CRepeat c b) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (t_update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''

  | E_RepeatEnd : forall c st st' b,
      c / st || st' ->
      beval st' b = true ->
      (REPEAT c UNTIL b END) / st || st'

  | E_RepeatLoop : forall c st st' st'' b,
      c / st || st' ->
      beval st' b = false ->
      (REPEAT c UNTIL b END) / st' || st'' ->
      (REPEAT c UNTIL b END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (t_update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  + (* "b is true" *)
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  + (* "b is false" *)
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
  + (* Case "E_WhileEnd" *)
    split. assumption. apply bexp_eval_false. assumption.
  + (* Case "E_WhileLoop" *)
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

Lemma hoare_repeat : forall P Q b c,
  {{P}} c {{Q}} ->
  (fun st => Q st /\ ~ (bassn b st)) ->>  P ->
  {{P}} (REPEAT c UNTIL b END) {{fun st => Q st /\ bassn b st}}.
Proof.
  intros P Q b c HHoare HP st st' He.
  remember (REPEAT c UNTIL b END) as wcom eqn:Heqwcom.
  induction He;
    try (inversion Heqwcom); subst; clear Heqwcom.
    - split.  apply (HHoare st st'). assumption. assumption.
      apply bexp_eval_true. assumption.
    - intros. apply IHHe2. reflexivity.
      apply (HP st'). split.
      apply (HHoare st st'). assumption. assumption.
      apply bexp_eval_false. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty
  | Tree : ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tbranch : tm -> tm -> tm -> tm
  | tleaf : tm
.

(* Values *)

(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)
(* STOPPED HERE *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse
  | v_branch : forall t1 t2 t3,
     value t2 ->
     value (tbranch t1 t2 t3)
  | v_leaf :
      value tleaf
.

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20, right associativity).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Definition relation a := a -> a -> Prop.

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation "t1 '==>*' t2" := (multi step t1 t2) (at level 40).

(* Contexts *)

Definition context := partial_map ty.

(* Typing relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      update Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  induction Ht; subst Gamma...
  + (* Case "T_Var" *)
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  + (* Case "T_App" *)
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    - (* t1 is a value *)
      destruct IHHt2...
      * (* t2 is also a value *)
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      * (* t2 steps *)
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    - (* t1 steps *)
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  + (* Case "T_If" *)
    right. destruct IHHt1...

    - (* t1 is a value *)
      destruct (cannonical_forms_bool t1); subst; eauto.

    - (* t1 also steps *)
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* $Id: String.v 14641 2011-11-06 11:59:10Z herbelin $ *)

(** Contributed by Laurent Théry (INRIA);
    Adapted to Coq V8 by the Coq Development Team *)

Require Import Arith.
Require Import Ascii.
Declare ML Module "string_syntax_plugin".

(** *** Definition of strings *)

(** Implementation of string as list of ascii characters *)

Inductive string : Set :=
  | EmptyString : string
  | String : ascii -> string -> string.

Delimit Scope string_scope with string.
Bind Scope string_scope with string.
Open Local Scope string_scope.

(** Equality is decidable *)

Definition string_dec : forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
 decide equality; apply ascii_dec.
Defined.

(** *** Concatenation of strings *)

Reserved Notation "x ++ y" (right associativity, at level 60).

Fixpoint append (s1 s2 : string) : string :=
  match s1 with
  | EmptyString => s2
  | String c s1' => String c (s1' ++ s2)
  end

where "s1 ++ s2" := (append s1 s2) : string_scope.

(******************************)
(** Length                    *)
(******************************)

Fixpoint length (s : string) : nat :=
  match s with
  | EmptyString => 0
  | String c s' => S (length s')
  end.

(******************************)
(** Nth character of a string *)
(******************************)

Fixpoint get (n : nat) (s : string) {struct s} : option ascii :=
  match s with
  | EmptyString => None
  | String c s' => match n with
                   | O => Some c
                   | S n' => get n' s'
                   end
  end.

(** Two lists that are identical through get are syntactically equal *)

Theorem get_correct :
  forall s1 s2 : string, (forall n : nat, get n s1 = get n s2) <-> s1 = s2.
Proof.
intros s1; elim s1; simpl in |- *.
intros s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros a s1' Rec s2; case s2; simpl in |- *; split; auto.
intros H; generalize (H 0); intros H1; inversion H1.
intros; discriminate.
intros H; generalize (H 0); simpl in |- *; intros H1; inversion H1.
case (Rec s).
intros H0; rewrite H0; auto.
intros n; exact (H (S n)).
intros H; injection H; intros H1 H2 n; case n; auto.
rewrite H2; trivial.
rewrite H1; auto.
Qed.

(** The first elements of [s1 ++ s2] are the ones of [s1] *)

Theorem append_correct1 :
 forall (s1 s2 : string) (n : nat),
 n < length s1 -> get n s1 = get n (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n H; inversion H.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
intros n0 H; apply Rec; auto.
apply lt_S_n; auto.
Qed.

(** The last elements of [s1 ++ s2] are the ones of [s2] *)

Theorem append_correct2 :
 forall (s1 s2 : string) (n : nat),
 get n s2 = get (n + length s1) (s1 ++ s2).
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2 n; rewrite plus_comm; simpl in |- *; auto.
intros a s1' Rec s2 n; case n; simpl in |- *; auto.
generalize (Rec s2 0); simpl in |- *; auto. intros.
rewrite <- Plus.plus_Snm_nSm; auto.
Qed.

(** *** Substrings *)

(** [substring n m s] returns the substring of [s] that starts
    at position [n] and of length [m];
    if this does not make sense it returns [""] *)

Fixpoint substring (n m : nat) (s : string) : string :=
  match n, m, s with
  | 0, 0, _ => EmptyString
  | 0, S m', EmptyString => s
  | 0, S m', String c s' => String c (substring 0 m' s')
  | S n', _, EmptyString => s
  | S n', _, String c s' => substring n' m s'
  end.

(** The substring is included in the initial string *)

Theorem substring_correct1 :
 forall (s : string) (n m p : nat),
 p < m -> get p (substring n m s) = get (p + n) s.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros p H; inversion H.
intros m' p; case p; simpl in |- *; auto.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Lt.lt_S_n; auto.
intros n' m p H; rewrite <- Plus.plus_Snm_nSm; simpl in |- *; auto.
Qed.

(** The substring has at most [m] elements *)

Theorem substring_correct2 :
 forall (s : string) (n m p : nat), m <= p -> get p (substring n m s) = None.
Proof.
intros s; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros a s' Rec; intros n; case n; simpl in |- *; auto.
intros m; case m; simpl in |- *; auto.
intros m' p; case p; simpl in |- *; auto.
intros H; inversion H.
intros n0 H; apply Rec; simpl in |- *; auto.
apply Le.le_S_n; auto.
Qed.

(** *** Test functions *)

(** Test if [s1] is a prefix of [s2] *)

Fixpoint prefix (s1 s2 : string) {struct s2} : bool :=
  match s1 with
  | EmptyString => true
  | String a s1' =>
      match s2 with
      | EmptyString => false
      | String b s2' =>
          match ascii_dec a b with
          | left _ => prefix s1' s2'
          | right _ => false
          end
      end
  end.

(** If [s1] is a prefix of [s2], it is the [substring] of length
    [length s1] starting at position [O] of [s2] *)

Theorem prefix_correct :
 forall s1 s2 : string,
 prefix s1 s2 = true <-> substring 0 (length s1) s2 = s1.
Proof.
intros s1; elim s1; simpl in |- *; auto.
intros s2; case s2; simpl in |- *; split; auto.
intros a s1' Rec s2; case s2; simpl in |- *; auto.
split; intros; discriminate.
intros b s2'; case (ascii_dec a b); simpl in |- *; auto.
intros e; case (Rec s2'); intros H1 H2; split; intros H3; auto.
rewrite e; rewrite H1; auto.
apply H2; injection H3; auto.
intros n; split; intros; try discriminate.
case n; injection H; auto.
Qed.

(** Test if, starting at position [n], [s1] occurs in [s2]; if
    so it returns the position *)

Fixpoint index (n : nat) (s1 s2 : string) : option nat :=
  match s2, n with
  | EmptyString, 0 =>
      match s1 with
      | EmptyString => Some 0
      | String a s1' => None
      end
  | EmptyString, S n' => None
  | String b s2', 0 =>
      if prefix s1 s2 then Some 0
      else
        match index 0 s1 s2' with
        | Some n => Some (S n)
        | None => None
        end
   | String b s2', S n' =>
      match index n' s1 s2' with
      | Some n => Some (S n)
      | None => None
      end
  end.

(* Dirty trick to avoid locally that prefix reduces itself *)
Opaque prefix.

(** If the result of [index] is [Some m], [s1] in [s2] at position [m] *)

Theorem index_correct1 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m -> substring m (length s1) s2 = s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1; auto.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
case H0; simpl in |- *; auto.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H1; apply H; injection H1; intros H2; injection H2; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [Some m],
    [s1] does not occur in [s2] before [m] *)

Theorem index_correct2 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = Some m ->
 forall p : nat, n <= p -> p < m -> substring p (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
intros H; injection H; intros H1; rewrite <- H1.
intros p H0 H2; inversion H2.
intros; discriminate.
intros; discriminate.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros H0 H; injection H; intros H1; rewrite <- H1; auto.
intros p H2 H3; inversion H3.
case m; simpl in |- *; auto.
case (index 0 s1 s2'); intros; discriminate.
intros m'; generalize (Rec 0 m' s1); case (index 0 s1 s2'); auto.
intros x H H0 H1 p; try case p; simpl in |- *; auto.
intros H2 H3; red in |- *; intros H4; case H0.
intros H5 H6; absurd (false = true); auto with bool.
intros n0 H2 H3; apply H; auto.
injection H1; intros H4; injection H4; auto.
apply Le.le_O_n.
apply Lt.lt_S_n; auto.
intros; discriminate.
intros n'; case m; simpl in |- *; auto.
case (index n' s1 s2'); intros; discriminate.
intros m'; generalize (Rec n' m' s1); case (index n' s1 s2'); auto.
intros x H H0 p; case p; simpl in |- *; auto.
intros H1; inversion H1; auto.
intros n0 H1 H2; apply H; auto.
injection H0; intros H3; injection H3; auto.
apply Le.le_S_n; auto.
apply Lt.lt_S_n; auto.
intros; discriminate.
Qed.

(** If the result of [index] is [None], [s1] does not occur in [s2]
    after [n] *)

Theorem index_correct3 :
 forall (n m : nat) (s1 s2 : string),
 index n s1 s2 = None ->
 s1 <> EmptyString -> n <= m -> substring m (length s1) s2 <> s1.
Proof.
intros n m s1 s2; generalize n m s1; clear n m s1; elim s2; simpl in |- *;
 auto.
intros n; case n; simpl in |- *; auto.
intros m s1; case s1; simpl in |- *; auto.
case m; intros; red in |- *; intros; discriminate.
intros n' m; case m; auto.
intros s1; case s1; simpl in |- *; auto.
intros b s2' Rec n m s1.
case n; simpl in |- *; auto.
generalize (prefix_correct s1 (String b s2'));
 case (prefix s1 (String b s2')).
intros; discriminate.
case m; simpl in |- *; auto with bool.
case s1; simpl in |- *; auto.
intros a s H H0 H1 H2; red in |- *; intros H3; case H.
intros H4 H5; absurd (false = true); auto with bool.
case s1; simpl in |- *; auto.
intros a s n0 H H0 H1 H2;
 change (substring n0 (length (String a s)) s2' <> String a s) in |- *;
 apply (Rec 0); auto.
generalize H0; case (index 0 (String a s) s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_O_n.
intros n'; case m; simpl in |- *; auto.
intros H H0 H1; inversion H1.
intros n0 H H0 H1; apply (Rec n'); auto.
generalize H; case (index n' s1 s2'); simpl in |- *; auto; intros;
 discriminate.
apply Le.le_S_n; auto.
Qed.

(* Back to normal for prefix *)
Transparent prefix.

(** If we are searching for the [Empty] string and the answer is no
    this means that [n] is greater than the size of [s] *)

Theorem index_correct4 :
 forall (n : nat) (s : string),
 index n EmptyString s = None -> length s < n.
Proof.
intros n s; generalize n; clear n; elim s; simpl in |- *; auto.
intros n; case n; simpl in |- *; auto.
intros; discriminate.
intros; apply Lt.lt_O_Sn.
intros a s' H n; case n; simpl in |- *; auto.
intros; discriminate.
intros n'; generalize (H n'); case (index n' EmptyString s'); simpl in |- *;
 auto.
intros; discriminate.
intros H0 H1; apply Lt.lt_n_S; auto.
Qed.

(** Same as [index] but with no optional type, we return [0] when it
    does not occur *)

Definition findex n s1 s2 :=
  match index n s1 s2 with
  | Some n => n
  | None => 0
  end.

(** *** Concrete syntax *)

(**
  The concrete syntax for strings in scope string_scope follows the
  Coq convention for strings: all ascii characters of code less than
  128 are litteral to the exception of the character `double quote'
  which must be doubled.

  Strings that involve ascii characters of code >= 128 which are not
  part of a valid utf8 sequence of characters are not representable
  using the Coq string notation (use explicitly the String constructor
  with the ascii codes of the characters).
*)

Example HelloWorld := "	""Hello world!""
".


(* Test robustness of Groebner tactic in presence of disequalities *)

Require Export Reals.
Require Export Nsatz.

Open Scope R_scope.

Lemma essai :
 forall yb xb m1 m2 xa ya,
  xa <> xb ->
 yb - 2 * m2 * xb = ya - m2 * xa ->
 yb - m1 * xb = ya - m1 * xa ->
 yb - ya = (2 * xb - xa) * m2 ->
 yb - ya = (xb - xa) * m1.
Proof.
intros.
(* clear H. groebner used not to work when H was not cleared *)
nsatz.
Qed.


(**********************************************************************************

 Two-sided fibrations

 In this file, we study two-sided fibrations and we use two-sided displayed
 categories to define them. Note that the 'two-sided' in the name
 'two-sided displayed categories' is taken from two-sided fibrations, and defining
 two-sided fibrations is one of the main goal.

 Our definition is based on Definition 2.3.4 in
    https://arxiv.org/pdf/1806.06129.pdf
 Let's say we have the span `C₁ ⟵ D ⟶ C₂`. In the definition by Loregian and Riehl,
 the functor `D ⟶ C₂` has a cleaving and the functor `D ⟶ C₁` has an opcleaving.
 However, in our definition, it is the other way around. For us, the functor
 `D ⟶ C₁` has a cleaving and `D ⟶ C₂` has an opcleaving. This change has minor
 consequence. For example, if we consider the arrow category on a category `C`,
 then we have a two-sided fibration `C ⟵ Arr(C) ⟶ C` where the left functor is the
 domain and the right functor is the codomain. In the definition by Loregian and
 Riehl, this would be the other way around. If we would use their definition in our
 setting, then we would need to reveres the arrows when defining the arrow category.

 Contents
 1. Opcartesian morphisms
 2. Cartesian morphisms
 3. Cleavings
 4. Two-sided fibrations

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.

Local Open Scope cat.

Section TwoSidedFibration.
  Context {C₁ C₂ : category}
          (D : twosided_disp_cat C₁ C₂).

  (**
   1. Opcartesian morphisms
   *)
  Definition twosided_opcartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₃ : C₁)
         (y₃ : C₂)
         (xy₃ : D x₃ y₃)
         (f' : x₂ --> x₃)
         (g' : y₂ --> y₃)
         (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃),
       ∃! (ℓ : xy₂ -->[ f' ][ g' ] xy₃),
       fg ;;2 ℓ = fg'.

  Definition twosided_opcartesian_factorisation
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_opcartesian fg)
             {x₃ : C₁}
             {y₃ : C₂}
             {xy₃ : D x₃ y₃}
             {f' : x₂ --> x₃}
             {g' : y₂ --> y₃}
             (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃)
    : xy₂ -->[ f' ][ g' ] xy₃
    := pr11 (H _ _ _ _ _ fg').

  Definition twosided_opcartesian_factorisation_commutes
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_opcartesian fg)
             {x₃ : C₁}
             {y₃ : C₂}
             {xy₃ : D x₃ y₃}
             {f' : x₂ --> x₃}
             {g' : y₂ --> y₃}
             (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃)
    : fg ;;2 twosided_opcartesian_factorisation H fg' = fg'
    := pr21 (H _ _ _ _ _ fg').

  (**
   2. Cartesian morphisms
   *)
  Definition twosided_cartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₀ : C₁)
         (y₀ : C₂)
         (xy₀ : D x₀ y₀)
         (f' : x₀ --> x₁)
         (g' : y₀ --> y₁)
         (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂),
       ∃! (ℓ : xy₀ -->[ f' ][ g' ] xy₁),
       ℓ ;;2 fg = fg'.

  Definition twosided_cartesian_factorisation
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_cartesian fg)
             {x₀ : C₁}
             {y₀ : C₂}
             {xy₀ : D x₀ y₀}
             {f' : x₀ --> x₁}
             {g' : y₀ --> y₁}
             (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂)
    : xy₀ -->[ f' ][ g' ] xy₁
    := pr11 (H _ _ _ _ _ fg').

  Definition twosided_cartesian_factorisation_commutes
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (H : twosided_cartesian fg)
             {x₀ : C₁}
             {y₀ : C₂}
             {xy₀ : D x₀ y₀}
             {f' : x₀ --> x₁}
             {g' : y₀ --> y₁}
             (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂)
    : twosided_cartesian_factorisation H fg' ;;2 fg = fg'
    := pr21 (H _ _ _ _ _ fg').

  (**
   3. Cleavings
   *)
  Definition twosided_opcleaving
    : UU
    := ∏ (x : C₁)
         (y₁ y₂ : C₂)
         (xy₁ : D x y₁)
         (g : y₁ --> y₂),
       ∑ (xy₂ : D x y₂)
         (ℓ : xy₁ -->[ identity _ ][ g ] xy₂),
       twosided_opcartesian ℓ.

  Definition twosided_opcleaving_ob
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : D x y₂
    := pr1 (H x y₁ y₂ xy₁ g).

  Definition twosided_opcleaving_mor
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : xy₁ -->[ identity _ ][ g ] twosided_opcleaving_ob H xy₁ g
    := pr12 (H x y₁ y₂ xy₁ g).

  Definition twosided_opcleaving_opcartesian
             (H : twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : twosided_opcartesian (twosided_opcleaving_mor H xy₁ g)
    := pr22 (H x y₁ y₂ xy₁ g).

  Definition twosided_cleaving
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y : C₂)
         (xy₂ : D x₂ y)
         (f : x₁ --> x₂),
       ∑ (xy₁ : D x₁ y)
         (ℓ : xy₁ -->[ f ][ identity _ ] xy₂),
       twosided_cartesian ℓ.

  Definition twosided_cleaving_ob
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : D x₁ y
    := pr1 (H x₁ x₂ y xy₂ f).

  Definition twosided_cleaving_mor
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂
    := pr12 (H x₁ x₂ y xy₂ f).

  Definition twosided_cleaving_cartesian
             (H : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : twosided_cartesian (twosided_cleaving_mor H xy₂ f)
    := pr22 (H x₁ x₂ y xy₂ f).

  Definition twosided_commute
             (H₁ : twosided_opcleaving)
             (H₂ : twosided_cleaving)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             (xy : D x₂ y₁)
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : twosided_opcleaving_ob H₁ (twosided_cleaving_ob H₂ xy f) g
      -->[ identity _ ][ identity _ ]
      twosided_cleaving_ob H₂ (twosided_opcleaving_ob H₁ xy g) f.
  Proof.
    use (twosided_opcartesian_factorisation
           (twosided_opcleaving_opcartesian H₁ _ g)).
    use (twosided_cartesian_factorisation
           (twosided_cleaving_cartesian H₂ _ f)).
    refine (transportb
              (λ z, _ -->[ z ][ _ ] _)
              _
              (transportb
                 (λ z, _ -->[ _ ][ z ] _)
                 _
                 (twosided_cleaving_mor H₂ xy f ;;2 twosided_opcleaving_mor H₁ xy g))).
    - abstract
        (rewrite !id_left, !id_right ;
         apply idpath).
    - abstract
        (rewrite !id_left, !id_right ;
         apply idpath).
  Defined.

  Definition is_iso_twosided_commute
             (H₁ : twosided_opcleaving)
             (H₂ : twosided_cleaving)
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y₁ y₂ : C₂)
         (xy : D x₂ y₁)
         (f : x₁ --> x₂)
         (g : y₁ --> y₂),
       is_iso_twosided_disp
         (identity_is_z_iso _)
         (identity_is_z_iso _)
         (twosided_commute H₁ H₂ xy f g).

  (**
   4. Two-sided fibrations
   *)
  Definition twosided_fibration
    : UU
    := ∑ (H₁ : twosided_opcleaving)
         (H₂ : twosided_cleaving),
       is_iso_twosided_commute H₁ H₂.
End TwoSidedFibration.

(**
 5. Discrete two-sided fibrations
 *)
Section DiscreteTwoSidedFibration.
  Context {C₁ C₂ : category}
          (D : twosided_disp_cat C₁ C₂).

  Definition discrete_twosided_opcartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₃ : C₁)
         (y₃ : C₂)
         (xy₃ : D x₃ y₃)
         (f' : x₂ --> x₃)
         (g' : y₂ --> y₃)
         (fg' : xy₁ -->[ f · f' ][ g · g' ] xy₃),
       xy₂ -->[ f' ][ g' ] xy₃.

  Definition discrete_twosided_opcartesian_is_opcartesian
             (HD : discrete_twosided_disp_cat D)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (Hfg : discrete_twosided_opcartesian fg)
    : twosided_opcartesian D fg.
  Proof.
    intros x₃ y₃ xy₃ f' g' fg'.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intro ; intros ;
         use subtypePath ; [ intro ; apply isaset_disp_mor | ] ;
         apply HD).
    - simple refine (_ ,, _).
      + apply Hfg.
        exact fg'.
      + apply HD.
  Defined.

  Definition discrete_twosided_cartesian
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             (fg : xy₁ -->[ f ][ g ] xy₂)
    : UU
    := ∏ (x₀ : C₁)
         (y₀ : C₂)
         (xy₀ : D x₀ y₀)
         (f' : x₀ --> x₁)
         (g' : y₀ --> y₁)
         (fg' : xy₀ -->[ f' · f ][ g' · g ] xy₂),
       xy₀ -->[ f' ][ g' ] xy₁.

  Definition discrete_twosided_cartesian_is_cartesian
             (HD : discrete_twosided_disp_cat D)
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {xy₁ : D x₁ y₁}
             {xy₂ : D x₂ y₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {fg : xy₁ -->[ f ][ g ] xy₂}
             (Hfg : discrete_twosided_cartesian fg)
    : twosided_cartesian D fg.
  Proof.
    intros x₃ y₃ xy₃ f' g' fg'.
    use iscontraprop1.
    - abstract
        (use invproofirrelevance ;
         intro ; intros ;
         use subtypePath ; [ intro ; apply isaset_disp_mor | ] ;
         apply HD).
    - simple refine (_ ,, _).
      + apply Hfg.
        exact fg'.
      + apply HD.
  Defined.

  Definition discrete_twosided_opcleaving
    : UU
    := ∏ (x : C₁)
         (y₁ y₂ : C₂)
         (xy₁ : D x y₁)
         (g : y₁ --> y₂),
       ∑ (xy₂ : D x y₂)
         (ℓ : xy₁ -->[ identity _ ][ g ] xy₂),
       discrete_twosided_opcartesian ℓ.

  Definition discrete_twosided_opcleaving_ob
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : D x y₂
    := pr1 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_opcleaving_mor
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : xy₁ -->[ identity _ ][ g ] discrete_twosided_opcleaving_ob H xy₁ g
    := pr12 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_opcleaving_opcartesian
             (H : discrete_twosided_opcleaving)
             {x : C₁}
             {y₁ y₂ : C₂}
             (xy₁ : D x y₁)
             (g : y₁ --> y₂)
    : discrete_twosided_opcartesian (discrete_twosided_opcleaving_mor H xy₁ g)
    := pr22 (H x y₁ y₂ xy₁ g).

  Definition discrete_twosided_disp_cat_to_opcleaving
             (HD : discrete_twosided_disp_cat D)
             (HD' : discrete_twosided_opcleaving)
    : twosided_opcleaving D.
  Proof.
    intros x y₁ y₂ xy₁ g.
    simple refine (_ ,, _ ,, _).
    - exact (pr1 (HD' x y₁ y₂ xy₁ g)).
    - exact (pr12 (HD' x y₁ y₂ xy₁ g)).
    - apply (discrete_twosided_opcartesian_is_opcartesian HD).
      exact (pr22 (HD' x y₁ y₂ xy₁ g)).
  Defined.

  Definition discrete_twosided_cleaving
    : UU
    := ∏ (x₁ x₂ : C₁)
         (y : C₂)
         (xy₂ : D x₂ y)
         (f : x₁ --> x₂),
       ∑ (xy₁ : D x₁ y)
         (ℓ : xy₁ -->[ f ][ identity _ ] xy₂),
       discrete_twosided_cartesian ℓ.

  Definition discrete_twosided_cleaving_ob
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : D x₁ y
    := pr1 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_cleaving_mor
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : discrete_twosided_cleaving_ob H xy₂ f -->[ f ][ identity _ ] xy₂
    := pr12 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_cleaving_cartesian
             (H : discrete_twosided_cleaving)
             {x₁ x₂ : C₁}
             {y : C₂}
             (xy₂ : D x₂ y)
             (f : x₁ --> x₂)
    : discrete_twosided_cartesian (discrete_twosided_cleaving_mor H xy₂ f)
    := pr22 (H x₁ x₂ y xy₂ f).

  Definition discrete_twosided_disp_cat_to_cleaving
             (HD : discrete_twosided_disp_cat D)
             (HD' : discrete_twosided_cleaving)
    : twosided_cleaving D.
  Proof.
    intros x y₁ y₂ xy₁ g.
    simple refine (_ ,, _ ,, _).
    - exact (pr1 (HD' x y₁ y₂ xy₁ g)).
    - exact (pr12 (HD' x y₁ y₂ xy₁ g)).
    - apply (discrete_twosided_cartesian_is_cartesian HD).
      exact (pr22 (HD' x y₁ y₂ xy₁ g)).
  Defined.
End DiscreteTwoSidedFibration.

Definition is_discrete_twosided_fibration
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
  : UU
  := discrete_twosided_cleaving D × discrete_twosided_opcleaving D.

Definition discrete_twosided_fibration
           (C₁ C₂ : category)
  : UU
  := ∑ (D : twosided_disp_cat C₁ C₂)
       (HD : discrete_twosided_disp_cat D),
     is_discrete_twosided_fibration HD.

Coercion discrete_twosided_fibration_to_twosided_disp_cat
         {C₁ C₂ : category}
         (D : discrete_twosided_fibration C₁ C₂)
  : twosided_disp_cat C₁ C₂
  := pr1 D.

Definition discrete_twosided_disp_cat_is_fibration
           {C₁ C₂ : category}
           {D : twosided_disp_cat C₁ C₂}
           (HD : discrete_twosided_disp_cat D)
           (HD' : is_discrete_twosided_fibration HD)
  : twosided_fibration D.
Proof.
  simple refine (_ ,, _ ,, _).
  - apply discrete_twosided_disp_cat_to_opcleaving.
    + exact HD.
    + apply HD'.
  - apply discrete_twosided_disp_cat_to_cleaving.
    + exact HD.
    + apply HD'.
  - cbn.
    unfold is_iso_twosided_commute.
    intro ; intros.
    apply HD.
Defined.


From Coq Require Import Init.Nat Lia List.
From QuickChick Require Import QuickChick CheckerProofs EnumProofs.
From mathcomp Require Import ssreflect ssreflect.eqtype.

Import ListNotations.

Inductive Sorted : list nat -> Prop :=
  Sorted_nil : Sorted []
| Sorted_singl x : Sorted [x]
| Sorted_cons x y l :
    x <= y -> Sorted (y :: l) -> Sorted (x :: y :: l).

(* We need to derive a checker for the <= relation as well. *)
Derive DecOpt for (le x y).
Derive DecOpt for (Sorted l).

Instance DecOptsorted_sound  l : DecOptSoundPos (Sorted l).
Proof. derive_sound. Qed.

Lemma sorted_2000 : Sorted (repeat 1 2000).
Proof.
  time (repeat (first [ eapply Sorted_cons; [ apply le_n | ]
                      | eapply Sorted_singl ])).
Time Qed.

(* Tactic call ran for 7.39 secs (7.36u,0.03s) (success) *)
(* Finished transaction in 9.623 secs (9.623u,0.s) (successful) *)

(* Switch to 5000: *)
(* Tactic call ran for 79.948 secs (78.952u,0.851s) (success) *)
(* Finished transaction in 326.736 secs (240.418u,1.744s) (successful) *)

Lemma sorted_2000' : Sorted (repeat 1 2000).
Proof.
  time (eapply sound with (s := 2000); compute; reflexivity).
Time Qed.
(* Tactic call ran for 0.05 secs (0.05u,0.s) (success) *)
(* Finished transaction in 0.059 secs (0.058u,0.s) (successful) *)

Lemma sorted_5000' : Sorted (repeat 1 5000).
Proof.
  time (eapply sound with (s := 5000); compute; reflexivity).
Time Qed.


  Variable A : Prop .
  Variable R : A->A->Prop.

  Definition Rstar:A->A->Prop :=
     [x,y:A](P0:A->A->Prop)
             ((u:A)(P0 u u))
              ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y).

  Definition Rstar':A->A->Prop :=
      [x,y:A](P:A->A->Prop)
             (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y).

  Definition coherence: A->A->Prop :=
        [x:A][y:A](P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P.

(* Les 2 hypotheses du Lemme de Newman *)

  Axiom Hyp1:(x:A)(P:A->Prop)((y:A)((z:A)(R y z)->(P z))->(P y))->(P x).
  Axiom Hyp2:(x:A)(y:A)(z:A)(R x y)->(R x z)->(coherence y z).

(* Verification du lemme *)

  Lemma Rstar_reflexive: (x:A)(Rstar x x).
Proof [x:A][P0:A->A->Prop]
        [H:(u:A)(P0 u u)][_:(u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w)](H x).

  Lemma Rstar_R: (x:A)(y:A)(z:A)(R x y)->(Rstar y z)->(Rstar x z).
Proof [x,y,z:A][t1:(R x y)] [t2:(P0:A->A->Prop)
          ((u:A)(P0 u u))
           ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 y z)]
      [P:A->A->Prop][h1:(u:A)(P u u)]
        [h2:(u:A)(v:A)(w:A)(R u v)->(P v w)->(P u w)]
         (h2 x y z t1 (t2 [a,a0:A](P a a0) h1 h2)).

  Lemma Rstar_transitive: (x:A)(y:A)(z:A)(Rstar x y)->(Rstar y z)->(Rstar x z).
Proof [x,y,z:A][h:(P0:A->A->Prop)
        ((u:A)(P0 u u))
         ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)]
      (h [a,a0:A](Rstar a0 z)->(Rstar a z) [u:A][H:(Rstar u z)]H
        [u,v,w:A][t1:(R u v)][t2:(Rstar w z)->(Rstar v z)]
           [t3:(Rstar w z)](Rstar_R u v z t1 (t2 t3))).

  Lemma Rstar'_reflexive: (x:A)(Rstar' x x).
Proof [x:A][P:A->A->Prop][H:(P x x)][_:(u:A)(R x u)->(Rstar u x)->(P x x)]H.

  Lemma Rstar'_R: (x:A)(y:A)(z:A)(R x z)->(Rstar z y)->(Rstar' x y).
Proof [x,y,z:A][t1:(R x z)][t2:(Rstar z y)][P:A->A->Prop]
       [_:(P x x)][h2:(u:A)(R x u)->(Rstar u y)->(P x y)](h2 z t1 t2).

  Lemma Rstar'_Rstar:  (x:A)(y:A)(Rstar' x y)->(Rstar x y).
Proof [x,y:A][h:(P:A->A->Prop)
       (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)]
      (h [a,a0:A](Rstar a a0) (Rstar_reflexive x) [u:A](Rstar_R x u y)).

  Lemma Rstar_Rstar':  (x:A)(y:A)(Rstar x y)->(Rstar' x y).
Proof [x,y:A][h:(P0:A->A->Prop)
       ((u:A)(P0 u u))
        ->((u:A)(v:A)(w:A)(R u v)->(P0 v w)->(P0 u w))->(P0 x y)]
       (h Rstar' [u:A](Rstar'_reflexive u)
         [u,v,w:A][h1:(R u v)]
          [h2:(Rstar' v w)](Rstar'_R u w v h1 (Rstar'_Rstar v w h2))).

  Lemma coherence_intro : (x:A)(y:A)(z:A)(Rstar x z)->(Rstar y z)
                                ->(coherence x y).
Proof [x,y,z:A][H:(Rstar x z)][H0:(Rstar y z)][P:Prop]
          [H1:(z0:A)(Rstar x z0)->(Rstar y z0)->P](H1 z H H0).

  Lemma Rstar_coherence : (x:A)(y:A)(Rstar x y)->(coherence x y).
Proof [x,y:A][h:(Rstar x y)](coherence_intro x y y h (Rstar_reflexive y)).

  Lemma coherence_sym: (x:A)(y:A)(coherence x y)->(coherence y x).
Proof [x,y:A][H:(P:Prop)((z:A)(Rstar x z)->(Rstar y z)->P)->P][P:Prop]
      [H0:(z:A)(Rstar y z)->(Rstar x z)->P]
       (H P [z:A][H1:(Rstar x z)][H2:(Rstar y z)](H0 z H2 H1)).

  Lemma Diagram:
   (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
     ->(y,z,u:A)(R x u)->(Rstar u y)
           ->(v:A)(R x v)->(Rstar v z)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)
                      ->(coherence y z)]
     [y,z,u:A][t1:(R x u)][t2:(Rstar u y)][v:A][u1:(R x v)][u2:(Rstar v z)]
        ([Hyp0:(x0,y0,z0:A)(R x0 y0)->(R x0 z0)
                    ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P]
             [hyp_ind0:(u0:A)(R x u0)->(y0,z0:A)(Rstar u0 y0)->(Rstar u0 z0)
                        ->(P:Prop)((z1:A)(Rstar y0 z1)->(Rstar z0 z1)->P)->P]
              (Hyp0 x u v t1 u1 (coherence y z)
                [z0:A][H:(Rstar u z0)][H0:(Rstar v z0)]
                   (hyp_ind0 u t1 y z0 t2 H (coherence y z)
                     [z1:A][H1:(Rstar y z1)][H2:(Rstar z0 z1)]
                        (hyp_ind0 v u1 z z1 u2
                          (Rstar_transitive v z0 z1 H0 H2)
                          (coherence y z)
                          [z2:A][H3:(Rstar z z2)][H4:(Rstar z1 z2)]
                            [P:Prop][H5:(z3:A)(Rstar y z3)->(Rstar z z3)->P]
                                (H5 z2
                                  (Rstar_transitive y z1 z2 H1 H4) H3))))
            Hyp2 hyp_ind).

  Lemma caseRxy:
    (x:A)((u:A)(R x u)->(y,z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
        ->(y,z:A)(Rstar x y)->(Rstar x z)
                ->(u:A)(R x u)->(Rstar u y)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)
           (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)]
  [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)][u:A][t1:(R x u)][t2:(Rstar u y)]
        ([hyp_:(P:A->A->Prop)(P x x)
                  ->((u0:A)(R x u0)->(Rstar u0 z)->(P x z))->(P x z)]
           (hyp_ [_:A][a:A](coherence y a)
             (coherence_sym x y (Rstar_coherence x y h1))
             (Diagram x hyp_ind y z u t1 t2))
          (Rstar_Rstar' x z h2)).

  Lemma Ind_proof :
    (x:A)((u:A)(R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z))
            ->(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z).
Proof [x:A][hyp_ind:(u:A)
           (R x u)->(y:A)(z:A)(Rstar u y)->(Rstar u z)->(coherence y z)]
  [y,z:A][h1:(Rstar x y)][h2:(Rstar x z)]
     ([hyp_:(P:A->A->Prop)
              (P x x)->((u:A)(R x u)->(Rstar u y)->(P x y))->(P x y)]
        (hyp_ [_:A][a:A](coherence a z) (Rstar_coherence x z h2)
          (caseRxy x hyp_ind y z h1 h2))
       (Rstar_Rstar' x y h1)).

  Lemma Newman: (x:A)(y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z).
Proof [x:A](Hyp1 x
   [x:A](y:A)(z:A)(Rstar x y)->(Rstar x z)->(coherence y z) Ind_proof).

Quit.


Require Import CantorPairing Synthetic.
Require Import Lia.

Lemma Dec_sigT_transport {X} p q :
  Dec_sigT p -> (forall x : X, p x <-> q x) -> Dec_sigT q.
Proof.
  intros Dec_p Equiv. intros x.
  destruct (Dec_p x) as [H|H];
  [left | right]; firstorder.
Qed.

Lemma Dec_transport {X} p q :
  Dec p -> (forall x : X, p x <-> q x) -> Dec q.
Proof.
  intros [Dec_p] Equiv.
  constructor. intros x.
  destruct (Dec_p x) as [H|H];
  [left | right]; firstorder.
Qed.

Lemma dec_eq_nat (x y : nat) : dec (x = y).
Proof.
  unfold dec; decide equality.
Defined.

Lemma lt_dec x y : dec (x < y).
Proof.
  induction y in x |-*.
  - right. lia.
  - destruct x.
    left. lia.
    destruct (IHy x).
    left; lia. right; lia.
Qed.

Lemma dec_conj A B : dec A -> dec B -> dec (A /\ B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_disj A B : dec A -> dec B -> dec (A \/ B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_imp A B : dec A -> dec B -> dec (A -> B).
Proof.
  intros [][]; unfold dec; intuition.
Defined.

Lemma dec_neg A : dec A -> dec (~ A).
Proof.
  intros []; unfold dec; now (left + right).
Defined.

Lemma neg_and A B : dec A -> dec B -> ~(A /\ B) -> (~A \/ ~B).
Proof.
  intros [][] ?; tauto.
Defined.

Lemma neg_imp A B : dec A -> dec B -> ~(A -> B) -> A /\ ~B.
Proof.
  intros [][] ?; tauto.
Qed.

Hint Resolve neg_and neg_imp dec_eq_nat dec_conj dec_disj dec_imp dec_neg : decs.

(** * Decidability of bounded quantifiers. *)

Lemma dec_lt_bounded_sig N (p : nat -> Type) :
  (forall x, p x + (p x -> False)) -> { x & ((x < N) * p x)%type } + (forall x, x < N -> p x -> False).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. destruct Hx. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
      now apply IH.
Defined.

Lemma dec_lt_bounded_exist' N p :
  Dec_sigT p -> (exists x, x < N /\ p x) + (forall x, x < N -> ~ p x).
Proof.
  intros Dec_p. induction N.
  right. intros []; lia.
  destruct (IHN) as [IH | IH].
  - left. destruct IH as [x Hx].
    exists x. split. lia. apply Hx.
  - destruct (Dec_p N) as [HN | HN].
    + left. exists N. split. lia. apply HN.
    + right. intros x Hx.
      assert (x = N \/ x < N) as [->|] by lia; auto.
Defined.

Lemma dec_lt_bounded_exist N p :
  Dec_sigT p -> dec (exists x, x < N /\ p x).
Proof.
  intros Dec_p.
  destruct (dec_lt_bounded_exist' N p Dec_p).
  now left. right. firstorder.
Defined.

Lemma dec_lt_bounded_forall N p :
  Dec_sigT p -> dec (forall x, x < N -> p x).
Proof.
  intros Dec_p. induction N.
  left. lia.
  destruct (Dec_p N) as [HN | HN].
  - destruct (IHN) as [IH | IH].
    +  left. intros x Hx.
    assert (x = N \/ x < N) as [->|] by lia; auto.
    + right. intros H. apply IH.
      intros x Hx. apply H. lia.
  - right. intros H. apply HN.
    apply H. lia.
Defined.

Lemma neg_lt_bounded_forall N p :
  Dec_sigT p -> (~ forall x, x < N -> p x) -> exists x, x < N /\ ~ p x.
Proof.
  intros Hp H.
  induction N. exfalso. apply H; lia.
  destruct (Hp N).
  - destruct IHN as [n ].
    + intros H1. apply H. intros.
      assert (x = N \/ x < N) as [->|] by lia.
      auto. now apply H1.
    + exists n. intuition lia.
  - exists N. auto.
Qed.

(** * The product type for Nat is witnessing. *)

Theorem ProductWO (p : nat -> nat -> Prop) :
  ( forall x y, dec (p x y) ) -> (exists x y, p x y) -> { x & { y & p x y }}.
Proof.
  intros Dec_p H.
  pose (P n := let (x, y) := decode n in p x y).
  assert ({n & P n}) as [n Hn].
  apply Witnessing_nat.
  - intros n.
    destruct (decode n) as [x y] eqn:E.
    destruct (Dec_p x y); (left + right); unfold P; now rewrite E.
  - destruct H as (x & y & H).
    exists (code (x, y)). unfold P.
    now rewrite inv_dc.
  - destruct (decode n) as [x y] eqn:E.
    exists x, y. unfold P in Hn; now rewrite E in Hn.
Qed.


Require Import List String.

Set Implicit Arguments.

Set Asymmetric Patterns.

Set Universe Polymorphism.

(* Largely copied from CPDT *)
Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | inil : ilist 0
  | icons : forall n, A -> ilist n -> ilist (S n).

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

End ilist.

Arguments inil [A].
Arguments First [n].

Local Infix "::" := (@icons _ _).

Definition ihd' n (il : ilist Type n) : Type :=
  match il with
    | inil => Set
    | icons _ T _ => T
  end.

Definition ihd n (il : ilist Type (S n)) : Type := ihd' il.

Definition itl' n (il : ilist Type n) :=
  match il in ilist _ N return ilist Type (pred N) with
    | inil => inil
    | icons _ _ il' => il'
  end.

Definition itl n (il : ilist Type (S n)) : ilist Type n := itl' il.

Fixpoint iget n (i : fin n) : ilist Type n -> Type :=
  match i with
    | First _ => fun il => ihd il
    | Next _ i' => fun il => iget i' (itl il)
  end.

Section ilist_map.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (ls : ilist A n) : ilist B n :=
    match ls with
      | inil => inil
      | icons _ x ls' => icons (f x) (imap ls')
    end.
End ilist_map.

(* heterogeneous indexed lists *)
Section hilist.
  Inductive hilist : forall n, ilist Type n -> Type :=
  | hinil : hilist inil
  | hicons : forall n x (ls : ilist _ n), x -> hilist ls -> hilist (icons x ls).

  Definition hihd n (il : ilist Type (S n)) (hl : hilist il) : ihd il :=
    match hl in hilist il return ihd' il with
      | hinil => unit
      | hicons _ _ _ v _ => v
    end.

  Definition hitl n (il : ilist Type (S n)) (hl : hilist il) : hilist (itl il) :=
    match hl in hilist il return hilist (itl' il) with
      | hinil => hinil
      | hicons _ _ _ _ hl' => hl'
    end.

  Fixpoint higet n (i : fin n) : forall (ils : ilist Type n), hilist ils -> iget i ils :=
    match i in fin n return forall (ils : ilist Type n), hilist ils -> iget i ils with
      | First _ => fun _ hl => hihd hl
      | Next _ i' => fun _ hl => higet i' (hitl hl)
    end.
End hilist.


Require Import Lib.

Module HeytingTerms.

  (*************************************************)
  (* Identifiers *)

  (* Identifiers are indexed by natural numbers *)
  Definition X := nat.

  (* Decidability of identifier equality; this is identical to a similar theorem
   * for nats in Coq's standard library. *)
  Theorem eq_id_dec : forall x y : X, {x = y} + {x <> y}.
  Proof.
    intros x. induction x as [|x'].
    Case "x = 0". destruct y as [|y'].
    SCase "y = 0". left. reflexivity.
    SCase "y > 0". right. intros c. inversion c.
    Case "x > 0". intros y. destruct y as [|y'].
    SCase "y = 0". right. intros c. inversion c.
    SCase "y > 0". destruct IHx' with (y := y') as [eq|neq].
    SSCase "x' = y'". subst. left. reflexivity.
    SSCase "x' <> y'". right. unfold not in neq. intros c. inversion c.
      apply neq. apply H0.
  Defined.

  (*************************************************)
  (* Terms *)

  (* Terms may be nats, variables, +, *, and successor. Note that Kanckos
   * defines successor for both numerals and terms; this is important because
   * it's used to find inconsistencies (∀t, Suc t ⊃ 0 ⇒ ⊥).  *)
  Inductive T: Set :=
  | Nat: nat -> T
  | Var: X -> T
  | Plus: T -> T -> T
  | Mult: T -> T -> T
  | Suc : T -> T.  (* note that Kanckos defines succ for both nats and terms *)

  Notation "t1 + t2"  := (Plus t1 t2)
                           (at level 50, left associativity) : hterm_scope.
  Notation "t1 * t2"  := (Mult t1 t2)
                           (at level 40, left associativity) : hterm_scope.

  Bind Scope hterm_scope with T.  (* this doesn't help too much *)
  Delimit Scope hterm_scope with hterm. (* needed when a term isn't a fn arg *)

  (*************************************************)
  (* Decidability of term equality. Note that this is syntactic equality:
   * Nat O + Nat O is not the same as Nat O. *)

  Tactic Notation "hterm_cases" tactic(first) ident(c) :=
    first;
    [Case_aux c "Nat" | Case_aux c "Var" | Case_aux c "Plus"
     | Case_aux c "Mult" | Case_aux c "Suc"].

  Tactic Notation "wrong_shape" :=
    solve [right; intros contra; inversion contra].
  Tactic Notation "dest_ind" ident(hyp) ident(hypvar) ident(cvar) ident(c):=
    destruct hyp with (hypvar:=cvar) as [eq|neq];
    [Case_aux c "eq" | Case_aux c "neq"].
  Tactic Notation "eq_case" :=
    solve [left; inversion eq; subst; reflexivity].

  (* Proof that term equality is decidable. *)
  Open Scope hterm_scope.
  Theorem term_eq_dec : forall (t1 t2: T), {t1 = t2} + {t1 <> t2}.
  Proof.
    intros t1.
    hterm_cases (induction t1 as [n1|x1|r Hr r' Hr'|r Hr r' Hr'|t1])
                Case;
      intros t2;
      hterm_cases (destruct t2 as [n2|x2|s s'|s s'|t2]) SCase;
      try wrong_shape.
    Case "Nat".
    SCase "Nat". generalize dependent n2.
      induction n1 as [|n1']; destruct n2 as [|n2'];
        try wrong_shape; try (left; reflexivity).
      dest_ind IHn1' n2 n2' SSCase; try eq_case.
      SSCase "neq". right. unfold not in neq. intros c. inversion c.
        apply neq. apply f_equal. apply H0.
    Case "Var".
    SCase "Var". generalize dependent x2.
      induction x1 as [|x1']; destruct x2 as [|x2'];
      try wrong_shape; try (left; reflexivity).
      dest_ind IHx1' x2 x2' SSCase; try eq_case.
      SSCase "neq". right. unfold not in neq. intros c. inversion c. apply neq.
        subst. reflexivity.
    Case "Plus".
    destruct Hr with (t2:=s) as [eq|neq];
      destruct Hr' with (t2:=s') as [eq'|neq']; subst.
    SSCase "both equal". left. reflexivity.
    SSCase "r' <> s'". right. intros contra. unfold not in neq'. apply neq'.
    inversion contra. reflexivity.
    SSCase "r <> s". right. intros contra. unfold not in neq. apply neq.
    inversion contra. reflexivity.
    SSCase "r' <> s', r <> s".
    (* Note: this is syntactic equality, not equality of the evaluated term. *)
    right. intros contra. inversion contra. unfold not in neq.
    apply neq. apply H0.
    Case "Mult".
    destruct Hr with (t2:=s) as [eq|neq];
      destruct Hr' with (t2:=s') as [eq'|neq']; subst.
    SSCase "both equal". left. reflexivity.
    SSCase "r' <> s'". right. intros contra. unfold not in neq'. apply neq'.
    inversion contra. reflexivity.
    SSCase "r <> s". right. intros contra. unfold not in neq. apply neq.
    inversion contra. reflexivity.
    SSCase "r' <> s', r <> s".
    (* Note: this is syntactic equality, not equality of the evaluated term. *)
    right. intros contra. inversion contra. unfold not in neq.
    apply neq. apply H0.
    Case "Suc". destruct IHt1 with (t2 := t2).
    SSCase "eq". left. subst. reflexivity.
    SSCase "neq". right. intros c. inversion c. apply n. apply H0.
  Defined.

  (* Substitution: var <-> term *)
  Fixpoint subst_t (x : X) (value : T) (term : T) : T :=
    match term with
      | Nat _ => term
      | Var y => if eq_id_dec x y then value else term
      | Plus t1 t2 => Plus (subst_t x value t1) (subst_t x value t2)
      | Mult t1 t2 => Mult (subst_t x value t1) (subst_t x value t2)
      | Suc t => Suc (subst_t x value t)
    end.

  Fixpoint abstract_t (value : T) (x : X) (term : T) : T :=
    if (term_eq_dec value term) then (Var x) else
      match term with
        | Plus t1 t2 => Plus (abstract_t value x t1) (abstract_t value x t2)
        | Mult t1 t2 => Mult (abstract_t value x t1) (abstract_t value x t2)
        | Suc t => Suc (abstract_t value x t)
        | _ => term
      end.

  (*************************************************)

  (* Arithmetic Equality *)
  Open Scope hterm_scope.

  (* Equality rules from Kanckos page 3, except for Inf1, defined below. *)
  Inductive eqha : T -> T -> Set :=
  | t_refl    : forall t, eqha t t
  | t_symm    : forall t1 t2, eqha t1 t2 -> eqha t2 t1
  | t_trans   : forall t1 t2 t3, eqha t1 t2 -> eqha t2 t3 -> eqha t1 t3
  | t_plus_id : forall t, eqha (t + Nat O) t
  | t_plus_rec: forall t1 t2, eqha (t1 + Suc(t2)) (Suc(t1 + t2))
  | t_mult_0  : forall t, eqha (t * Nat O) (Nat O)
  | t_mult_rec: forall t1 t2, eqha (t1 * Suc(t2)) (t1 + (t1 * t2))
  | t_rep_s   : forall t1 t2, eqha t1 t2 -> eqha (Suc t1) (Suc t2)
  | t_rep_plus_l : forall t1 t2 t3, eqha t1 t2 -> eqha (t1 + t3) (t2 + t3)
  | t_rep_plus_r : forall t1 t2 t3, eqha t2 t3 -> eqha (t1 + t2) (t1 + t3)
  | t_rep_mult_l : forall t1 t2 t3, eqha t1 t2 -> eqha (t1 * t3) (t2 * t3)
  | t_rep_mult_r : forall t1 t2 t3, eqha t2 t3 -> eqha (t1 * t2) (t1 * t3)
  | t_inf2    : forall t1 t2, eqha (Suc t1) (Suc t2) -> eqha t1 t2
  | t_suc     : forall n, eqha (Nat (S n)) (Suc (Nat n)).

  (* Kanckos also includes a proof of falsity, if Suc t = 0. This will be
   * included in the later definition of formulas Φ. *)

  Definition n0 := Nat O.
  Definition n1 := Suc n0.
  Definition n2 := Suc n1.
  Definition v0 := Var 0.
  Definition v1 := Var 1.
  Definition v2 := Var 2.

  (* Some example arithmetic derivations. *)
  Fact haf1 : eqha (n0 + n0) (n1 * n0).
  Proof.
    apply t_trans with (t2 := n0).
    apply t_plus_id.
    apply t_symm. apply t_mult_0.
  Defined.
  Print haf1.

  Lemma plus_id_r : forall t : T, eqha t (t + n0).
  Proof.
    intros t. apply t_symm. apply t_plus_id.
  Qed.
  Print plus_id_r.

  Lemma mult1 : forall t:T, eqha (t*n1) t.
  Proof.
    intros t. unfold n1. apply t_trans with (t2:=t+(t*n0)).
    apply t_mult_rec. apply t_trans with (t2:=t+n0).
    apply t_rep_plus_r. apply t_mult_0.
    apply t_plus_id.
  Qed.
  Print mult1.

End HeytingTerms.

Module HeytingProps.

  Export HeytingTerms.
  Require Export List.

  (* Formulas and Atomic Propositions *)
  (* For the Kanckos paper, basic connectives are ∨, ∧, ⊃ (aka ⇒), ∃, ∀.
     Negation is derived as ¬A ≡ A ⊃ ⊥. *)
  Inductive Φ: Set :=
  | bot  : Φ
  | teq  : T -> T -> Φ
  | Disj : Φ -> Φ -> Φ
  | Conj : Φ -> Φ -> Φ
  | Imp  : Φ -> Φ -> Φ
  | Ex   : X -> Φ -> Φ
  | All  : X -> Φ -> Φ.

  Notation "⊥" := bot.

  Definition Neg (φ:Φ) := Imp φ bot.

  Tactic Notation "formula_cases" tactic(first) ident(c) :=
    first;
    [Case_aux c "bot" | Case_aux c "teq" | Case_aux c "disj" | Case_aux c "conj"
     | Case_aux c "imp" | Case_aux c "ex" | Case_aux c "all"].

  Fixpoint subst_φ (x : X) (t : T) (φ : Φ) : Φ :=
    match φ with
      | bot        => bot
      | teq t1 t2  => teq  (subst_t x t t1) (subst_t x t t2)
      | Disj φ1 φ2 => Disj (subst_φ x t φ1) (subst_φ x t φ2)
      | Conj φ1 φ2 => Conj (subst_φ x t φ1) (subst_φ x t φ2)
      | Imp φ1 φ2  => Imp  (subst_φ x t φ1) (subst_φ x t φ2)
      | Ex x' φ'   => if eq_id_dec x x' then φ else Ex  x' (subst_φ x t φ')
      | All x' φ'  => if eq_id_dec x x' then φ else All x' (subst_φ x t φ')
    end.

  Fixpoint abstract_φ (t : T) (x : X) (φ : Φ) : Φ :=
    match φ with
      | bot        => bot
      | teq t1 t2  => teq  (abstract_t t x t1) (abstract_t t x t2)
      | Disj φ1 φ2 => Disj (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Conj φ1 φ2 => Conj (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Imp φ1 φ2  => Imp  (abstract_φ t x φ1) (abstract_φ t x φ2)
      | Ex x' φ'   => if eq_id_dec x x' then φ else Ex  x' (abstract_φ t x φ')
      | All x' φ'  => if eq_id_dec x x' then φ else All x' (abstract_φ t x φ')
    end.

  Inductive unbound : Φ -> X -> Prop :=
  | ub_bot  : forall x', unbound bot x'
  | ub_teq  : forall t1 t2 x', unbound (teq t1 t2) x'
  | ub_disj : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Disj φ1 φ2) x'
  | ub_conj : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Conj φ1 φ2) x'
  | ub_imp  : forall φ1 φ2 x',
                unbound φ1 x' -> unbound φ2 x' -> unbound (Imp φ1 φ2) x'
  | ub_ex   : forall φ x x',
                x <> x' -> unbound φ x -> unbound (Ex x' φ) x
  | ub_all  : forall φ x x',
                x <> x' -> unbound φ x -> unbound (All x' φ) x.

  (* Logical Rules and Derivations *)
  (* structure for derivation trees *)
  Inductive proves: Φ -> Set :=
  | p_bot   : forall φ, proves bot -> proves φ
  | p_andi  : forall φ1 φ2, proves φ1 -> proves φ2 -> proves (Conj φ1 φ2)
  | p_ander : forall φ1 φ2, proves (Conj φ1 φ2) -> proves φ1
  | p_andel : forall φ1 φ2, proves (Conj φ1 φ2) -> proves φ2
  | p_oril  : forall φ1 φ2, proves φ1 -> proves (Disj φ1 φ2)
  | p_orir  : forall φ1 φ2, proves φ2 -> proves (Disj φ1 φ2)
  | p_ore   : forall φ1 φ2 φ3, proves (Disj φ1 φ2) -> proves_mstep φ1 φ3
                               -> proves_mstep φ2 φ3 -> proves φ3
  | p_impi  : forall φ1 φ2, proves_mstep φ1 φ2 -> proves (Imp φ1 φ2)
  | p_impe  : forall φ1 φ2, proves (Imp φ1 φ2) -> proves φ1 -> proves φ2
  | p_alli  : forall φ x, proves φ -> unbound φ x -> proves (All x φ)
  | p_alle  : forall φ x t, proves (All x φ) -> proves (subst_φ x t φ)
  | p_exi   : forall φ x t, proves φ -> proves (Ex x (abstract_φ t x φ))
  | p_exe   : forall φ1 x t φ2, proves (Ex x φ1)
                                -> proves_mstep (subst_φ x t φ1) φ2
                                -> proves φ2
  | p_arith : forall t1 t2, eqha t1 t2 -> proves (teq t1 t2)
  | p_ind   : forall φ x t, proves (subst_φ x (Nat O) φ)
                            -> proves_mstep φ (subst_φ x (Suc (Var x)) φ)
                            -> proves (subst_φ x t φ)
  | p_false : forall t, proves (teq (Suc t) (Nat O)) -> proves bot

  (* relation indicating that A proves B in multiple steps - problem! *)
  with proves_mstep : Φ -> Φ -> Set :=
  | ps_base : forall φ1 φ2, proves φ1 -> proves φ2 -> proves_mstep φ1 φ2
  | ps_step : forall φ1 φ2 φ3, proves φ1 -> proves φ2 ->
                               (proves_mstep φ2 φ3) -> (proves_mstep φ1 φ3).

  Definition atom1 := p_arith (n0+n0) (n1*n0) haf1.
  Print atom1.

  Definition ex_disj := p_oril (teq (n0+n0) (n1*n0)) bot atom1.
  Print ex_disj.

  Eval compute in ex_disj.

End HeytingProps.

Module TestHeytingProps.
  (* Unit tests for HeytingProps. *)

  Import HeytingProps.

  Theorem test_unbound_1 : unbound atom1 0.
  Proof. apply ub_teq. Qed.

  Theorem test_unbound_2 : unbound atom3 2.
  Proof. constructor. Qed.

  Theorem test_unbound_3 : unbound (Conj atom1 atom3) 0.
  Proof.
    apply ub_conj.
    Case "atom1". apply ub_teq.
    Case "atom3". apply ub_teq.
    (* automated: repeat constructor. Qed. *)
  Qed.

  Theorem test_unbound_4: unbound (All 1 (Ex 2 atom4)) 0.
  Proof.
    constructor.
    Case "1 <> 0". intros contra. inversion contra.
    Case "Ex 2". constructor.
    SCase "2 <> 1". intros contra. inversion contra.
    SCase "atom4". constructor.
  Qed.

  Theorem test_unbound_5: ~(unbound (All 1 (Ex 2 atom4)) 1).
  Proof.
    intros contra. inversion contra. subst. apply H1. reflexivity.
  Qed.

  Theorem test_unbound_6: ~(unbound (All 1 (Ex 2 atom4)) 2).
  Proof.
    intros contra. inversion contra. subst.
    inversion H3. subst. apply H2. reflexivity.
  Qed.
End TestHeytingProps.