Require Import List.

Check nth_error.
Check Exc.
Print Exc.
Print option.

Theorem nth_incl:forall {A} xs (x:A),
In x xs<->exists i,Some x=nth_error xs i.
intros.
split.
elim xs.
intros  H0;destruct H0.
intros.
destruct H0.
exists 0.
simpl.
rewrite H0.
reflexivity.

destruct H.
exact H0.
exists (S x0).
simpl.
exact H.
elim xs.
intro.
destruct H.
case_eq x0.
intros.
rewrite H0 in H.
simpl in *.
discriminate.
intros.
rewrite H0 in H.
simpl in H.
discriminate.
intros.
destruct H0.
simpl in *.
case x0 in *.
simpl in *.
injection H0.
intro H1;left;symmetry;exact H1.
simpl in *.
right;apply H.
exists x0;exact H0.
Qed.


(** * Type for real numbers with bounded absolute value. *)

Require Import Reals Flocq.Core.Raux.

Require Import misc.

Require Import Psatz.

Require Import mathcomp.ssreflect.ssreflect mathcomp.ssreflect.ssrbool mathcomp.ssreflect.ssrfun mathcomp.ssreflect.eqtype mathcomp.ssreflect.ssrnat mathcomp.ssreflect.seq.
Require Import mathcomp.ssreflect.fintype mathcomp.ssreflect.finfun mathcomp.algebra.ssralg mathcomp.ssreflect.bigop.

Require Import mathcomp.analysis.Rstruct.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import GRing.Theory.

Section Bounded.

(** The type of bounded value (coercible to R). *)
Record bounded (r : R) := { bounded_val :> R;
                            bounded_prop : Rabs bounded_val <= r }.

(** A bound. *)
Variable r : R.

(** Must be non negative. *)
Hypothesis Hr : (0 <= r)%Re.

(** [bounded_0] is the value 0. *)
Definition bounded_0 :=
  {| bounded_val := 0;
     bounded_prop := (Rle_trans (Rabs 0) 0 r (or_intror Rabs_R0) Hr) |}.

Definition cast_bounded (r' : R) (Hrr' : r = r') (b : bounded r) :
  bounded r' :=
  {| bounded_val := bounded_val b;
     bounded_prop := (Rle_trans _ _ _ (bounded_prop b) (or_intror _ Hrr')) |}.

Definition widen_bounded (r' : R) (Hrr' : (r <= r')%Re) (b : bounded r) :
  bounded r' :=
  {| bounded_val := bounded_val b;
     bounded_prop := (Rle_trans _ _ _ (bounded_prop b) Hrr') |}.

Lemma bounded_opp_proof b : (Rabs b <= r -> Rabs (- b) <= r)%Re.
Proof. by move=> H; rewrite Rabs_Ropp. Qed.

(** [bounded_opp b] is [-b] *)
Definition bounded_opp (b : bounded r) : bounded r :=
  {| bounded_val := (- (bounded_val b))%Re;
     bounded_prop := bounded_opp_proof (bounded_prop b) |}.

(** Put two bounded values into one. *)
Lemma bounded_distrl (b1 b2 : bounded r) (r1 r2 : R) :
  exists b' : bounded r,
  (b1 * r1 + b2 * r2 = b' * (Rabs r1 + Rabs r2) :> R)%Re.
Proof.
have Pr1 := Rabs_pos r1. have Pr2 := Rabs_pos r2.
case (Req_dec (Rabs r1 + Rabs r2) 0)%Re => Hr1.
{ have Zr1 : (r1 = 0)%Re by apply Rabs_eq_R0; lra.
  have Zr2 : (r2 = 0)%Re by apply Rabs_eq_R0; lra.
  by exists bounded_0; rewrite Zr1 Zr2 /=; ring. }
set (bv := ((b1 * r1 + b2 * r2) / (Rabs r1 + Rabs r2))%Re).
suff H : (Rabs bv <= r)%Re.
{ exists (Build_bounded H); rewrite /bv /=; field; lra. }
rewrite /bv {bv} /Rdiv Rabs_mult Rabs_Rinv //.
have Hnn := Rabs_pos (Rabs r1 + Rabs r2).
have Hp : (0 < Rabs (Rabs r1 + Rabs r2)) by apply Rabs_pos_lt.
apply (Rmult_le_reg_r (Rabs (Rabs r1 + Rabs r2))); [by []|].
field_simplify; [|lra]; try rewrite /Rdiv Rinv_1 !Rmult_1_r.
apply (Rle_trans _ _ _ (Rabs_triang _ _)).
rewrite !Rabs_mult (Rabs_right (_ + _)); [|lra].
rewrite (Rmult_comm _ r) Rmult_plus_distr_l.
by apply Rplus_le_compat; apply Rmult_le_compat_r; [|case b1| |case b2].
Qed.

(** Put an array of bounded values into one. *)
Lemma big_bounded_distrl n (ba : bounded r ^ n) (a : R ^ n) :
  exists b' : bounded r,
  (\sum_i (ba i * a i)%Re = b' * (\sum_i (Rabs (a i))) :> R)%Re.
Proof.
move: n ba a; elim=> [|n IHn] ba a.
{ by exists bounded_0; rewrite big_ord0 Rmult_0_l. }
have [b' Hb'] := IHn [ffun i => ba (lift ord0 i)] [ffun i => a (lift ord0 i)].
set (hb1 := \sum_i ([ffun i => ba (lift ord0 i)] i
                    * [ffun i => a (lift ord0 i)] i)%Re).
set (hb2 := \sum_i Rabs ([ffun i0 => a (lift ord0 i0)] i)).
move: Hb'; rewrite -/hb1 -/hb2; move=> Hb'.
have [b'' Hb''] := (bounded_distrl (ba ord0) b' (a ord0) hb2).
exists b''; rewrite big_ord_recl.
apply eq_trans with (ba ord0 * a ord0 + hb1)%Re; [apply Rplus_eq_compat_l|].
{ by rewrite /hb1; apply /eq_bigr => i _; rewrite !ffunE. }
rewrite Hb' Hb'' big_ord_recl.
apply Rmult_eq_compat_l, Rplus_eq_compat_l.
rewrite /hb2 Rabs_pos_eq; [|by apply big_sum_Rabs_pos].
by apply /eq_bigr => i _; rewrite ffunE.
Qed.

(** Useful for overapproximating a complex term (r1)
    with a simpler one (r2). *)
Lemma bounded_larger_factor (b : bounded r) (r1 r2 : R) :
  (Rabs r1 <= Rabs r2 -> exists b' : bounded r, b * r1 = b' * r2 :> R)%Re.
Proof.
move=> Hr12; case (Req_dec r2 0) => Hr2.
{ have Hr1 : r1 = 0.
  { rewrite Hr2 Rabs_R0 in Hr12.
    by apply Rabs_eq_R0, Rle_antisym; [|apply Rabs_pos]. }
  by exists bounded_0; rewrite Hr1 Hr2 !Rmult_0_r. }
suff H : (Rabs (b * r1 / r2) <= r).
{ by exists (Build_bounded H); simpl; field. }
rewrite /Rdiv !Rabs_mult Rabs_Rinv //.
have H0 := Rabs_no_R0 r2 Hr2; have H1 := Rabs_pos r1.
have H2 : (0 < Rabs r2) by lra.
apply (Rmult_le_reg_r (Rabs r2)); [by []|].
rewrite Rmult_assoc Rinv_l; [rewrite Rmult_1_r|lra].
by apply Rmult_le_compat; try apply Rabs_pos; try case b.
Qed.

End Bounded.

(** Translation from inequalities to bounded terms. *)
Lemma bounded_le_1 (r1 r2 : R) :
  Rabs r1 <= r2 -> exists b : bounded 1, (r1 = b * r2)%Re.
Proof.
move=> Hr12; case (Req_dec r2 0) => Hr2.
{ exists (bounded_0 Rle_0_1); rewrite Hr2 Rmult_0_r.
  by apply Rabs_eq_R0, Rle_antisym; [lra|apply Rabs_pos]. }
suff H : (Rabs (r1 / r2) <= 1).
{ by exists (Build_bounded H); rewrite Rmult_assoc Rinv_l // Rmult_1_r. }
rewrite Rabs_mult Rabs_Rinv //.
have HAr2 : (0 < Rabs r2) by move: (Rabs_pos r2) (Rabs_no_R0 r2 Hr2); lra.
apply (Rmult_le_reg_r (Rabs r2)); [by []|rewrite Rmult_1_l].
rewrite Rmult_assoc Rinv_l; [rewrite Rmult_1_r|lra].
apply (Rle_trans _ _ _ Hr12 (Rle_abs r2)).
Qed.

Lemma bounded_le_1_abs (r1 r2 : R) :
  Rabs r1 <= r2 -> exists b : bounded 1, (Rabs r1 = b * r2)%Re.
Proof.
move=> Hr12.
have [b Hb] := bounded_le_1 Hr12.
split_Rabs.
{ exists (bounded_opp b); rewrite Hb /=; ring. }
by exists b; rewrite Hb.
Qed.

Lemma bounded_scale (r1 r2 : R) (b1 : bounded r1) :
  (0 < r2 -> exists b2 : bounded r2, b1 = b2 * (r1 / r2) :> R)%Re.
Proof.
move=> Hr2; case (Rle_or_lt r1 0) => Hr1.
{ exists (bounded_0 (Rlt_le _ _ Hr2)); rewrite Rmult_0_l.
  by apply Rabs_eq_R0, Rle_antisym;
    [apply (Rle_trans _ _ _ (bounded_prop b1))|apply Rabs_pos]. }
suff H : (Rabs (b1 * (r2 / r1)) <= r2).
{ exists (Build_bounded H); simpl; field; lra. }
rewrite !Rabs_mult Rabs_Rinv; [|lra].
rewrite (Rabs_right r1); [|lra]; rewrite (Rabs_right r2); [|lra].
apply (Rmult_le_reg_r r1); [by []|].
replace (_ * _)%Re with (r2 * Rabs b1)%Re; [|by field; lra].
by apply Rmult_le_compat_l; [lra|case b1].
Qed.

Lemma bounded_plus_proof (r1 r2 : R) (b1 : bounded r1) (b2 : bounded r2) :
  (Rabs (b1 + b2) <= r1 + r2)%Re.
Proof.
apply (Rle_trans _ _ _ (Rabs_triang _ _)).
by apply Rplus_le_compat; [case b1|case b2].
Qed.

(** Sum of bounded values. *)
Definition bounded_plus (r1 r2 : R) (b1 : bounded r1) (b2 : bounded r2) :=
  {| bounded_val := (b1 + b2)%Re; bounded_prop := bounded_plus_proof b1 b2 |}.

Lemma bounded_mult_proof (r1 r2 : R) (b1 : bounded r1) (b2 : bounded r2) :
  (Rabs (b1 * b2) <= r1 * r2)%Re.
Proof.
case (Rlt_or_le r1 0) => Hr1.
{ casetype False; apply (Rlt_irrefl 0).
  have Hb1 := bounded_prop b1.
  apply (Rle_lt_trans 0 (Rabs b1)); [apply Rabs_pos|lra]. }
case (Rlt_or_le r2 0) => Hr2.
{ casetype False; apply (Rlt_irrefl 0).
  have Hb2 := bounded_prop b2.
  apply (Rle_lt_trans 0 (Rabs b2)); [apply Rabs_pos|lra]. }
by rewrite Rabs_mult; apply Rmult_le_compat; try apply Rabs_pos;
  [case b1|case b2].
Qed.

(** Product of bounded values. *)
Definition bounded_mult (r1 r2 : R)
           (b1 : bounded r1) (b2 : bounded r2) : bounded (r1 * r2) :=
  {| bounded_val := (b1 * b2)%Re; bounded_prop := bounded_mult_proof b1 b2 |}.

Definition bounded_mult_1_l (r : R)
           (b1 : bounded 1) (b : bounded r) : bounded r :=
  cast_bounded (Rmult_1_l r) (bounded_mult b1 b).

Definition bounded_mult_1_r (r : R)
           (b : bounded r) (b1 : bounded 1) : bounded r :=
  cast_bounded (Rmult_1_r r) (bounded_mult b b1).


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(* ---                        matrix.v                                  --- *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(*          2-2 matrices with natural coefficients                          *)

(* Ported to ZArith by P.Letouzey (nov 2001)                                *)

Require Import monoid.
Require Import Arith.
Require Import ZArith.
Require Import Compare_dec.
Require Import fmpc.

Record Mat2 : Set := mat2 {M11 : Z; M12 : Z; M21 : Z; M22 : Z}.

Definition Id2 := mat2 1 0 0 1.

Definition Mat_mult (M M' : Mat2) :=
  mat2 (M11 M * M11 M' + M12 M * M21 M') (M11 M * M12 M' + M12 M * M22 M')
    (M21 M * M11 M' + M22 M * M21 M') (M21 M * M12 M' + M22 M * M22 M').

Axiom
  Mat_assoc :
    forall M M' M'' : Mat2,
    Mat_mult M (Mat_mult M' M'') = Mat_mult (Mat_mult M M') M''.

Lemma matrix : monoid Mat2.
 refine (mkmonoid Mat2 Id2 Mat_mult _ _ _).
(*
 Realizer (mkmonoid Mat2 Id2 Mat_mult).
 Program_all.
*)
 exact Mat_assoc.
 simple induction a.
  intros M13 M14 M23 M24.
  unfold Id2, Mat_mult in |- *; simpl in |- *.
  repeat elim Zplus_0_r_reverse.
  case M13; case M14; case M23; case M24; auto.
  simple induction a.
  intros.
  unfold Id2, Mat_mult in |- *; simpl in |- *.
  repeat elim Zmult_0_r_reverse.
  repeat rewrite Zmult_1_r.
  simpl in |- *; repeat elim Zplus_0_r_reverse.
  auto with arith.
Defined.

(* Fibonacci numbers *)

(* definition *)

Fixpoint Fib (n : nat) : nat :=
  match n return nat with
  | O => (* O *)  1
      (* (S p ) *)
  | S p =>
      match p return nat with
      | O => (* O *)  1
          (* S q *)
      | S q => Fib q + Fib p
      end
  end.

Lemma Unfold_FibO : Fib 0 = 1.
Proof.
 unfold Fib in |- *; simpl in |- *; auto with arith.
Qed.

Lemma Unfold_Fib1 : Fib 1 = 1.
Proof.
 unfold Fib in |- *; simpl in |- *; auto with arith.
Qed.

Lemma Unfold_FibSSn : forall n : nat, Fib (S (S n)) = Fib (S n) + Fib n.
Proof.
 intro n; unfold Fib at 1 in |- *.
 simpl in |- *; auto with arith.
Qed.

(* A "Decaled" Fibonnacci function *)

Definition shift_Fib (n : nat) :=
  match n return nat with
  | O => 0
  | S p => Fib p
  end.

Lemma Unfold_shift_Fib : forall n : nat, shift_Fib (S n) = Fib n.
Proof.
 intro n; unfold shift_Fib in |- *; auto with arith.
Qed.

Lemma Simpl_shift_Fib :
 forall n : nat, shift_Fib (S (S n)) = shift_Fib (S n) + shift_Fib n.
Proof.
 simple induction n.
 unfold shift_Fib, Fib in |- *; simpl in |- *; auto with arith.
 intros.
 unfold shift_Fib in |- *.
 rewrite Unfold_FibSSn; auto with arith.
Qed.

Definition fib_mat := mat2 1 1 1 0.

Lemma fib_mat_n :
 forall (n : nat) (a b d : Z),
 power Mat2 matrix fib_mat n = mat2 a b b d ->
 power Mat2 matrix fib_mat (S n) = mat2 (a + b) (b + d) a b.
Proof.
 intros; simpl in |- *.
 rewrite H.
 unfold Mat_mult in |- *.
 simpl in |- *.
 repeat elim Zplus_0_r_reverse.
 case a; case b; case d; auto.
Qed.

Lemma fib_n :
 forall n : nat,
 power Mat2 matrix fib_mat (S n) =
 mat2 (Z_of_nat (shift_Fib (S (S n)))) (Z_of_nat (shift_Fib (S n)))
   (Z_of_nat (shift_Fib (S n))) (Z_of_nat (shift_Fib n)).
Proof.
 simple induction n.
 unfold power, shift_Fib, o, u in |- *; simpl in |- *.
 unfold fib_mat in |- *; simpl in |- *.
 unfold Mat_mult, Id2 in |- *; simpl in |- *; auto with arith.
 intros.
 rewrite (fib_mat_n (S n0) _ _ _ H).
 repeat rewrite <- Znat.inj_plus.
 rewrite (Simpl_shift_Fib (S n0)).
 pattern (shift_Fib (S (S n0))) at 4 in |- *.
 rewrite (Simpl_shift_Fib n0).
 auto with arith.
Qed.

Lemma fib_computation :
 forall n : nat,
 0 < n -> Z_of_nat (Fib n) = M11 (power Mat2 matrix fib_mat n).
Proof.
 simple induction n.
 intro; absurd (0 < 0); auto with arith.
 intros.
 rewrite fib_n; unfold M11 in |- *; auto with arith.
Qed.


From Hammer Require Import Hammer.

From hahn Require Import HahnBase HahnList.
Require Export Relations.

Set Implicit Arguments.

Arguments clos_trans [A] R x y.
Arguments clos_refl_trans [A] R x y.
Arguments union [A] R1 R2 x y.
Arguments reflexive [A] R.
Arguments symmetric [A] R.
Arguments transitive [A] R.
Arguments antisymmetric [A] R.
Arguments inclusion {A} R1 R2.
Arguments same_relation {A} R1 R2.
Arguments transp [A] R x y.

Section RelDefs.

Variables A B : Type.
Variable cond : A -> Prop.
Variable f : A -> B.
Variables r r' : relation A.

Definition singl_rel a b : relation A := fun x y => x = a /\ y = b.

Definition inter_rel : relation A := fun x y => r x y /\ r' x y.

Definition minus_rel : relation A := fun x y => r x y /\ ~ r' x y.

Definition eq_rel : relation A := fun x y => f x = f y.

Definition eqv_rel : relation A := fun x y => x = y /\ cond x.

Definition eqv_dom_rel dom : relation A :=
fun x y => x = y /\ In x dom.

Definition restr_rel : relation A :=
fun x y => r x y /\ cond x /\ cond y.

Definition restr_eq_rel : relation A :=
fun x y => r x y /\ f x = f y.

Definition seq : relation A :=
fun x y => exists z, r x z /\ r' z y.

Definition map_rel (r'' : relation B) : relation A := fun x y => r'' (f x) (f y).

Definition clos_refl : relation A := fun x y => x = y \/ r x y.

Definition dom_rel := fun x => exists y, r x y.
Definition codom_rel := fun y => exists x, r x y.

Definition collect_rel : relation B := fun x y =>
exists x' y', r x' y' /\ f x' = x /\ f y' = y.

Definition immediate : relation A := fun a b =>
r a b /\ (forall c (R1: r a c) (R2: r c b), False).

Definition irreflexive := forall x, r x x -> False.

Definition is_total :=
forall a (IWa: cond a)
b (IWb: cond b) (NEQ: a <> b),
r a b \/ r b a.

Definition restr_subset :=
forall a (IWa: cond a)
b (IWb: cond b) (REL: r a b),
r' a b.

Definition upward_closed (P: A -> Prop) :=
forall x y (REL: r x y) (POST: P y), P x.

Definition functional := forall x y z, r x y -> r x z -> y=z.

Definition strict_partial_order := irreflexive /\ transitive r.

Definition strict_total_order := strict_partial_order /\ is_total.
End RelDefs.

Fixpoint pow_rel A (r: relation A) n :=
match n with
| 0 => eqv_rel (fun _ => True)
| S n => seq (pow_rel r n) r
end.

Definition bunion A B (P : A -> Prop) (r: A -> relation B) x y :=
exists a, P a /\ r a x y.

Definition acyclic A (r: relation A) := irreflexive (clos_trans r).

Definition cross_rel A (r r' : A -> Prop) := (fun a b => r a /\ r' b).

Hint Unfold reflexive symmetric transitive inclusion same_relation : unfolderDb.
Hint Unfold union transp singl_rel inter_rel minus_rel bunion : unfolderDb.
Hint Unfold eq_rel eqv_rel eqv_dom_rel restr_rel restr_eq_rel seq map_rel : unfolderDb.
Hint Unfold clos_refl dom_rel codom_rel cross_rel collect_rel : unfolderDb.
Hint Unfold immediate irreflexive acyclic is_total functional : unfolderDb.
Hint Unfold antisymmetric strict_partial_order strict_total_order : unfolderDb.

Notation "P ∩ Q" := (inter_rel P Q) (at level 40, left associativity).
Notation "P ∪ Q" := (union P Q) (at level 50, left associativity).
Notation "P \ Q" := (minus_rel P Q) (at level 46).
Notation "P ⨾ Q" := (seq P Q) (at level 44, right associativity).
Notation "⦗ a ⦘" := (eqv_rel a) (format "⦗ a ⦘").
Notation "∅₂" := (fun _ _ => False).
Notation "P × Q" := (cross_rel P Q) (at level 29, left associativity).

Notation "a ^?" := (clos_refl a) (at level 1, format "a ^?").
Notation "a ^^ n" := (pow_rel a n) (at level 1).

Notation "a ⁺" := (clos_trans a) (at level 1, format "a ⁺").
Notation "a ＊" := (clos_refl_trans a) (at level 1, format "a ＊").
Notation "a ⁻¹" := (transp a) (at level 1, format "a ⁻¹").
Notation "a ⊆ b" := (inclusion a b)  (at level 60).
Notation "a ≡ b" := (same_relation a b)  (at level 60).

Notation "⋃ x ∈ s , a" := (bunion s (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x  ∈  s ,  '/ ' a ']'").
Notation "'⋃' x , a" := (bunion (fun _ => True) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x ,  '/ ' a ']'").
Notation "'⋃' x < n , a" := (bunion (fun t => t < n) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x  <  n ,  '/ ' a ']'").
Notation "'⋃' x <= n , a" := (bunion (fun t => t <= n) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x  <=  n ,  '/ ' a ']'").
Notation "'⋃' x > n , a" := (bunion (fun t => n < t) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x  >  n ,  '/ ' a ']'").
Notation "'⋃' x >= n , a" := (bunion (fun t => n <= t) (fun x => a))
(at level 200, x ident, right associativity,
format "'[' ⋃ '/ ' x  >=  n ,  '/ ' a ']'").

Notation "P +++ Q" := (union P Q) (at level 50, left associativity, only parsing).
Notation "P ;; Q" := (seq P Q) (at level 44, right associativity, only parsing).
Notation "<| a |>" := (eqv_rel a) (only parsing).
Notation "a ^+" := (clos_trans a) (at level 1, only parsing).
Notation "a ^*" := (clos_refl_trans a) (at level 1, only parsing).
Notation "a ^{-1}" := (transp a) (at level 1, only parsing).
Notation "a <<= b" := (inclusion a b)  (at level 60, only parsing).
Notation "a <--> b" := (same_relation a b)  (at level 60, only parsing).

Lemma r_refl A (r: relation A) x : r^? x x.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.r_refl". vauto. Qed.

Lemma r_step A (r: relation A) x y : r x y -> r^? x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.r_step". vauto. Qed.

Hint Immediate r_refl r_step.

Section BasicProperties.

Variables A B : Type.
Variable dom : A -> Prop.
Variable f: A -> B.
Variables r r' r'' : relation A.

Lemma immediateE : immediate r ≡ r \ (r ⨾ r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.immediateE".
unfold immediate, seq, minus_rel.
repeat split; try red; ins; desf; eauto.
Qed.

Lemma clos_trans_mon a b :
r⁺ a b ->
(forall a b, r a b -> r' a b) ->
r'⁺ a b.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_mon".
induction 1; ins; eauto using clos_trans.
Qed.

Lemma clos_refl_trans_mon a b :
r＊ a b ->
(forall a b, r a b -> r' a b) ->
r'＊ a b.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_refl_trans_mon".
induction 1; ins; eauto using clos_refl_trans.
Qed.

Lemma clos_refl_transE a b :  r＊ a b <-> a = b \/ r⁺ a b.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_refl_transE".
split; ins; desf; vauto; induction H; desf; vauto.
Qed.

Lemma clos_trans_in_rt a b : r⁺ a b -> r＊ a b.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_in_rt".
induction 1; vauto.
Qed.

Lemma rt_t_trans a b c : r＊ a b -> r⁺ b c -> r⁺ a c.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.rt_t_trans".
ins; induction H; eauto using clos_trans.
Qed.

Lemma t_rt_trans a b c : r⁺ a b -> r＊ b c -> r⁺ a c.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.t_rt_trans".
ins; induction H0; eauto using clos_trans.
Qed.

Lemma t_step_rt x y : r⁺ x y <-> (exists z, r x z /\ r＊ z y).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.t_step_rt".
split; ins; desf.
by apply clos_trans_tn1 in H; induction H; desf; eauto using clos_refl_trans.
by rewrite clos_refl_transE in *; desf; eauto using clos_trans.
Qed.

Lemma t_rt_step x y : r⁺ x y <-> (exists z, r＊ x z /\ r z y).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.t_rt_step".
split; ins; desf.
by apply clos_trans_t1n in H; induction H; desf; eauto using clos_refl_trans.
by rewrite clos_refl_transE in *; desf; eauto using clos_trans.
Qed.

Lemma clos_trans_of_transitiveD (T: transitive r) x y :
r⁺ x y -> r x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_of_transitiveD".
induction 1; eauto.
Qed.

Lemma clos_trans_of_transitive (T: transitive r) x y :
r⁺ x y <-> r x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_of_transitive".
by split; ins; eauto using t_step; eapply clos_trans_of_transitiveD.
Qed.

Lemma clos_refl_trans_of_transitive (T: transitive r) x y :
r＊ x y <-> r^? x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_refl_trans_of_transitive".
by ins; rewrite clos_refl_transE, clos_trans_of_transitive; ins.
Qed.

Lemma clos_trans_eq :
forall B (f : A -> B)
(H: forall a b (SB: r a b), f a = f b) a b
(C: r⁺ a b),
f a = f b.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_eq".
ins; induction C; eauto; congruence.
Qed.

Lemma trans_irr_acyclic :
irreflexive r -> transitive r -> acyclic r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.trans_irr_acyclic".
eby repeat red; ins; eapply H, clos_trans_of_transitiveD.
Qed.

Lemma is_total_restr :
is_total dom r ->
is_total dom (restr_rel dom r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.is_total_restr".
red; ins; eapply H in NEQ; eauto; desf; vauto.
Qed.

Lemma clos_trans_restrD x y :
clos_trans (restr_rel dom r) x y -> dom x /\ dom y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_restrD".
unfold restr_rel; induction 1; ins; desf.
Qed.

Lemma clos_trans_restr_eqD x y :
clos_trans (restr_eq_rel f r) x y -> f x = f y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_restr_eqD".
unfold restr_eq_rel; induction 1; ins; desf; congruence.
Qed.

Lemma acyclic_antisymmetric :
acyclic r -> antisymmetric r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.acyclic_antisymmetric".
clear; autounfold with unfolderDb; intuition.
exfalso; eauto using clos_trans.
Qed.

Lemma trans_irr_antisymmetric :
irreflexive r -> transitive r -> antisymmetric r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.trans_irr_antisymmetric".
auto using acyclic_antisymmetric, trans_irr_acyclic.
Qed.

Lemma strict_partial_order_antisymmetric :
strict_partial_order r -> antisymmetric r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.strict_partial_order_antisymmetric".
unfold strict_partial_order; ins; desc.
auto using trans_irr_antisymmetric.
Qed.

Lemma irreflexive_inclusion:
r ⊆ r' ->
irreflexive r' ->
irreflexive r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.irreflexive_inclusion".
unfold irreflexive, inclusion; eauto.
Qed.

Lemma irreflexive_union :
irreflexive (r ∪ r') <-> irreflexive r /\ irreflexive r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.irreflexive_union".
unfold irreflexive, union; repeat split;
try red; ins; desf; eauto.
Qed.

Lemma irreflexive_seqC :
irreflexive (r ⨾ r') <-> irreflexive (r' ⨾ r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.irreflexive_seqC".
unfold irreflexive, seq; repeat split;
try red; ins; desf; eauto.
Qed.

Lemma irreflexive_restr :
irreflexive r -> irreflexive (restr_rel dom r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.irreflexive_restr".
unfold irreflexive, restr_rel; ins; desf; eauto.
Qed.

Lemma inclusion_acyclic :
r ⊆ r' ->
acyclic r' ->
acyclic r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_acyclic".
repeat red; ins; eapply H0, clos_trans_mon; eauto.
Qed.

Lemma transitive_cr : transitive r -> transitive r^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.transitive_cr".
unfold clos_refl; red; ins; desf; eauto.
Qed.

Lemma transitive_restr : transitive r -> transitive (restr_rel dom r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.transitive_restr".
unfold restr_rel; red; ins; desf; eauto.
Qed.

Lemma transitive_ct : transitive r⁺.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.transitive_ct". vauto. Qed.

Lemma transitive_rt : transitive r＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.transitive_rt". vauto. Qed.

Lemma reflexive_rt : reflexive r＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_rt". vauto. Qed.

Lemma reflexive_cr : reflexive r^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_cr". vauto. Qed.

Lemma reflexive_seq : reflexive r -> reflexive r' -> reflexive (r ⨾ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_seq". vauto. Qed.

Lemma reflexive_union_l : reflexive r -> reflexive (r ∪ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_union_l". vauto. Qed.

Lemma reflexive_union_r : reflexive r' -> reflexive (r ∪ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_union_r". vauto. Qed.

Lemma reflexive_inter : reflexive r -> reflexive r' -> reflexive (r ∩ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.reflexive_inter". vauto. Qed.

Lemma restr_eq_trans :
transitive r -> transitive (restr_eq_rel f r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.restr_eq_trans".
unfold transitive, restr_eq_rel; ins; desf; split; eauto; congruence.
Qed.

Lemma irreflexive_restr_eq :
irreflexive (restr_eq_rel f r) <-> irreflexive r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.irreflexive_restr_eq".
unfold irreflexive, restr_eq_rel; split; ins; desf; eauto.
Qed.

Lemma upward_closed_seq P :
upward_closed r P ->
upward_closed r' P ->
upward_closed (r ⨾ r') P.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.upward_closed_seq".
unfold seq; red; ins; desf; eauto.
Qed.

Lemma upward_closed_ct P :
upward_closed r P -> upward_closed r⁺ P.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.upward_closed_ct".
induction 2; eauto.
Qed.

Lemma upward_closed_rt P :
upward_closed r P -> upward_closed r＊ P.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.upward_closed_rt".
induction 2; eauto.
Qed.

Lemma eq_in_l : r ≡ r' -> r ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.eq_in_l". by destruct 1. Qed.

Lemma eq_in_r : r ≡ r' -> r' ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.eq_in_r". by destruct 1. Qed.

Lemma inclusion_refl : reflexive (@inclusion A).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_refl". repeat red; ins. Qed.

Lemma inclusion_trans : transitive (@inclusion A).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_trans". repeat red; eauto. Qed.

Lemma inclusion_refl2 : r ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_refl2". done. Qed.

Lemma same_relation_refl2 : r ≡ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.same_relation_refl2". split; ins. Qed.

Lemma inclusion_inter_l1 : r ∩ r' ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_l1". clear; firstorder. Qed.

Lemma inclusion_inter_l2 : r ∩ r' ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_l2". clear; firstorder. Qed.

Lemma inclusion_inter_l1_search : r ⊆ r'' -> r ∩ r' ⊆ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_l1_search". clear; firstorder. Qed.

Lemma inclusion_inter_l2_search : r' ⊆ r'' -> r ∩ r' ⊆ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_l2_search". clear; firstorder. Qed.

Lemma inclusion_inter_r : r ⊆ r' -> r ⊆ r'' -> r ⊆ r' ∩ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_r". clear; firstorder. Qed.

Lemma inclusion_inter_mon s s' : r ⊆ r' -> s ⊆ s' -> r ∩ s ⊆ r' ∩ s'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_inter_mon". clear; firstorder. Qed.

Lemma inclusion_union_r1 : r ⊆ r ∪ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_r1". vauto. Qed.

Lemma inclusion_union_r2 : r' ⊆ r ∪ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_r2". vauto. Qed.

Lemma inclusion_union_l : r ⊆ r'' -> r' ⊆ r'' -> r ∪ r' ⊆ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_l".
unfold union; red; intros; desf; auto.
Qed.

Lemma inclusion_union_r1_search : r ⊆ r' -> r ⊆ r' ∪ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_r1_search".
unfold union; red; intros; desf; auto.
Qed.

Lemma inclusion_union_r2_search : r ⊆ r'' -> r ⊆ r' ∪ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_r2_search".
unfold union; red; intros; desf; auto.
Qed.

Lemma inclusion_union_r :
r ⊆ r' \/ r ⊆ r'' -> r ⊆ r' ∪ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_r".
unfold union; red; intros; desf; auto.
Qed.

Lemma inclusion_union_mon s s' :
r ⊆ r' -> s ⊆ s' -> r ∪ s ⊆ r' ∪ s'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_mon".
unfold inclusion, union; ins; desf; eauto.
Qed.

Lemma inclusion_bunion_l (P : B -> Prop) (rr : B -> relation A) :
(forall x, P x -> rr x ⊆ r') -> bunion P rr ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_bunion_l".
clear; firstorder.
Qed.

Lemma inclusion_bunion_r (x: B) (P : B -> Prop) (rr : B -> relation A) :
P x -> r ⊆ rr x -> r ⊆ bunion P rr.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_bunion_r".
clear; firstorder.
Qed.

Lemma inclusion_seq_mon s s' : r ⊆ r' -> s ⊆ s' -> r ⨾ s ⊆ r' ⨾ s'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_mon".
unfold inclusion, seq; ins; desf; eauto.
Qed.

Lemma inclusion_seq_refl :
r ⊆ r'' -> r' ⊆ r'' -> transitive r'' -> r ⨾ r'^? ⊆ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_refl".
unfold inclusion, seq, clos_refl; ins; desf; eauto.
Qed.

Lemma inclusion_restr : restr_rel dom r ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_restr".
unfold inclusion, restr_rel; ins; desf.
Qed.

Lemma inclusion_restr_rel_l : r ⊆ r' -> restr_rel dom r ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_restr_rel_l".
unfold inclusion, seq, restr_rel; ins; desf; eauto.
Qed.

Lemma inclusion_restr_eq : restr_eq_rel f r ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_restr_eq".
unfold restr_eq_rel, inclusion; ins; desf.
Qed.

Lemma inclusion_restr_eq_l : r ⊆ r' -> restr_eq_rel f r ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_restr_eq_l".
unfold inclusion, seq, restr_eq_rel; ins; desf; eauto.
Qed.

Lemma inclusion_minus_rel : r \ r' ⊆ r.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_minus_rel".
unfold minus_rel, inclusion; ins; desf; auto.
Qed.

Lemma inclusion_minus_mon s s' : r ⊆ r' -> s' ⊆ s -> r \ s ⊆ r' \ s'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_minus_mon".
unfold minus_rel, inclusion, not; ins; desf; eauto.
Qed.

Lemma inclusion_minus_l s : r \ r' ⊆ s <-> r ⊆ r' ∪ s.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_minus_l".
unfold minus_rel, union, inclusion; split; ins; desf.
2: by eapply H in H0; desf; eauto.
by destruct (classic (r' x y)); eauto.
Qed.

Lemma inclusion_union_minus : r ⊆ (r \ r') ∪ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_union_minus".
by unfold minus_rel, union, inclusion; clear; intros; tauto.
Qed.

Lemma inclusion_eqv_rel_true : ⦗dom⦘  ⊆ ⦗fun _ => True⦘.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_eqv_rel_true".
unfold eqv_rel, inclusion; ins; desf; auto.
Qed.

Lemma inclusion_id_cr : ⦗fun _ => True⦘ ⊆ r^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_id_cr".
by unfold eqv_rel, inclusion; ins; desf; vauto.
Qed.

Lemma inclusion_eqv_cr : ⦗dom⦘ ⊆ r^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_eqv_cr".
by unfold eqv_rel, inclusion; ins; desf; vauto.
Qed.

Lemma inclusion_step_cr : r ⊆ r' -> r ⊆ r'^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_step_cr".
unfold seq, clos_refl; red; ins; desf; eauto.
Qed.

Lemma inclusion_r_cr : r ⊆ r' -> r^? ⊆ r'^?.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_r_cr".
unfold seq, clos_refl; red; ins; desf; eauto.
Qed.

Lemma inclusion_cr_ind :
reflexive r' -> r ⊆ r' -> r^? ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_cr_ind".
unfold clos_refl; ins; red; ins; desf; eauto.
Qed.

Lemma inclusion_step_t : r ⊆ r' -> r ⊆ r'⁺.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_step_t".
unfold seq; red; ins; desf; eauto using t_step.
Qed.

Lemma inclusion_t_rt : r⁺ ⊆  r＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_rt".
by red; ins; apply clos_trans_in_rt.
Qed.

Lemma inclusion_t_t : r ⊆ r' -> r⁺ ⊆ r'⁺.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_t".
by red; ins; eapply clos_trans_mon.
Qed.

Lemma inclusion_t_t2 : r ⊆ r'⁺ -> r⁺ ⊆ r'⁺.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_t2".
induction 2; eauto using clos_trans.
Qed.

Lemma inclusion_t_ind : r ⊆ r' -> transitive r' -> r⁺ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_ind". unfold seq; induction 3; eauto. Qed.

Lemma inclusion_t_ind_left : r ⊆ r' -> r⨾ r' ⊆ r' -> r⁺ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_ind_left".
unfold seq, inclusion; ins.
apply clos_trans_t1n in H1; induction H1; eauto.
Qed.

Lemma inclusion_t_ind_right : r ⊆ r' -> r'⨾ r ⊆ r' -> r⁺ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_t_ind_right".
unfold seq, inclusion; ins.
apply clos_trans_tn1 in H1; induction H1; eauto.
Qed.

Lemma inclusion_id_rt : ⦗fun _ => True⦘ ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_id_rt".
by unfold eqv_rel, inclusion; ins; desf; vauto.
Qed.

Lemma inclusion_eqv_rt : ⦗dom⦘ ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_eqv_rt".
by unfold eqv_rel, inclusion; ins; desf; vauto.
Qed.

Lemma inclusion_step_rt : r ⊆ r' -> r ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_step_rt".
unfold seq; red; ins; desf; eauto using rt_step.
Qed.

Lemma inclusion_r_rt : r ⊆ r' -> r^? ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_r_rt".
unfold seq, clos_refl; red; ins; desf; eauto using rt_step, rt_refl.
Qed.

Lemma inclusion_rt_rt : r ⊆ r' -> r＊ ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_rt_rt".
red; ins; eapply clos_refl_trans_mon; eauto.
Qed.

Lemma inclusion_rt_rt2 : r ⊆ r'＊ -> r＊ ⊆ r'＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_rt_rt2".
induction 2; eauto using clos_refl_trans.
Qed.

Lemma inclusion_rt_ind :
reflexive r' -> r ⊆ r' -> transitive r' -> r＊ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_rt_ind". unfold seq, eqv_rel; induction 4; eauto. Qed.

Lemma inclusion_rt_ind_left :
reflexive r' -> r⨾ r' ⊆ r' -> r＊ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_rt_ind_left".
unfold seq, eqv_rel, inclusion; ins.
apply clos_rt_rt1n in H1; induction H1; eauto.
Qed.

Lemma inclusion_rt_ind_right :
reflexive r' -> r'⨾ r ⊆ r' -> r＊ ⊆ r'.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_rt_ind_right".
unfold seq, eqv_rel, inclusion; ins.
apply clos_rt_rtn1 in H1; induction H1; eauto.
Qed.

Lemma inclusion_seq_trans t :
transitive t -> r ⊆ t -> r' ⊆ t -> r⨾ r' ⊆ t.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_trans".
unfold seq; red; ins; desf; eauto.
Qed.

Lemma inclusion_seq_rt :
r ⊆ r''＊ -> r' ⊆ r''＊ -> r⨾ r' ⊆ r''＊.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_rt".
apply inclusion_seq_trans; vauto.
Qed.

Lemma inclusion_seq_l :
r ⊆ r' -> reflexive r'' -> r ⊆ r' ⨾ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_l".
unfold seq, eqv_rel, inclusion; ins; eauto 8.
Qed.

Lemma inclusion_seq_r :
reflexive r' -> r ⊆ r'' -> r ⊆ r' ⨾ r''.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.inclusion_seq_r".
unfold seq, eqv_rel, inclusion; ins; eauto 8.
Qed.

Lemma functional_alt :
functional r <-> r⁻¹ ⨾ r ⊆ ⦗fun _ => True⦘.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_alt".
unfold functional, seq, transp, eqv_rel, inclusion.
split; ins; desf; [|apply H]; eauto.
Qed.

Lemma functional_eqv_rel : functional ⦗dom⦘.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_eqv_rel".
unfold functional, eqv_rel; ins; desf.
Qed.

Lemma functional_seq  :
functional r -> functional r' -> functional (r ⨾ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_seq".
unfold functional, seq; ins; desf.
assert (z0 = z1); subst; eauto.
Qed.

Lemma functional_union  :
functional r -> functional r' ->
(forall x, dom_rel r x -> dom_rel r' x -> False) ->
functional (r ∪ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_union".
unfold functional, union, dom_rel; ins; desf; eauto;
try solve [exfalso; eauto].
Qed.

Lemma functional_inter_l : functional r -> functional (r ∩ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_inter_l". clear; firstorder. Qed.

Lemma functional_inter_r : functional r' -> functional (r ∩ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_inter_r". clear; firstorder. Qed.

Lemma functional_minus : functional r -> functional (r \ r').
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_minus". clear; firstorder. Qed.

Lemma functional_restr : functional r -> functional (restr_rel dom r).
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functional_restr". clear; firstorder. Qed.

Lemma functionalE : functional r -> exists f, forall x y, r x y <-> f x = Some y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.functionalE".
clear; unfold functional; ins.
forward apply unique_choice
with (R := fun x y => y = None /\ ~ (exists m, r x m) \/
exists m, y = Some m /\ r x m) as X; ins; desf.
by tertium_non_datur (exists m, r x m); desc; [exists (Some m)| exists None];
split; ins; desf; try f_equal; eauto; try solve [exfalso; eauto].
exists f; ins; specialize (X x); split; ins; desf; try solve [exfalso; eauto].
rewrite X; f_equal; eauto.
Qed.

End BasicProperties.

Hint Resolve same_relation_refl2.

Hint Resolve
reflexive_seq reflexive_rt reflexive_cr
reflexive_union_l reflexive_union_r reflexive_inter
transitive_rt transitive_ct
: hahn.

Hint Resolve
inclusion_refl2 same_relation_refl2
inclusion_inter_l1_search inclusion_inter_l2_search inclusion_inter_r
inclusion_union_r1 inclusion_union_r2
inclusion_union_r1_search inclusion_union_r2_search inclusion_union_l
inclusion_seq_mon inclusion_minus_mon
inclusion_restr_eq_l inclusion_restr_rel_l
: hahn.

Hint Resolve trans_irr_antisymmetric strict_partial_order_antisymmetric : hahn.

Hint Resolve
inclusion_step_t inclusion_t_t inclusion_t_ind inclusion_rt_rt
inclusion_r_rt inclusion_step_rt inclusion_step_cr inclusion_r_cr : hahn.

Hint Immediate inclusion_acyclic : hahn.

Hint Immediate inclusion_t_rt : hahn.
Hint Immediate inclusion_eqv_rt inclusion_eqv_cr : hahn.

Lemma clos_trans_of_clos_trans A (r : relation A) x y :
r⁺⁺ x y <-> r⁺ x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_of_clos_trans".
apply clos_trans_of_transitive; vauto.
Qed.

Lemma clos_trans_of_clos_trans1 A (r r' : relation A) x y :
(fun a b => r⁺ a b \/ r' a b)⁺ x y <->
(fun a b => r a b \/ r' a b)⁺ x y.
Proof. hammer_hook "HahnRelationsBasic" "HahnRelationsBasic.clos_trans_of_clos_trans1".
split; induction 1; desf;
eauto using clos_trans, clos_trans_mon.
Qed.


Require Export P04.

(** **** Exercise: 4 stars (balance_relate)  *)
(** You will need proof automation for this one.  Study the methods used
  in [ins_not_E] and [balance_SearchTree], and try them here.
  Add one clause at a time to your [match goal]. *)
Lemma Abs_helper:
  forall m' t m, Abs t m' ->    m' = m ->     Abs t m.
Proof.
   intros. subst. auto.
Qed.

Ltac contents_equivalent_prover :=
 extensionality x; unfold t_update, combine, t_empty;
 repeat match goal with
  | |- context [if ?A then _ else _] => bdestruct A
 end;
 auto;
 omega.

Theorem balance_relate:
  forall c l k vk r m,
    SearchTree (T c l k vk r) ->
    Abs (T c l k vk r) m ->
    Abs (balance c l k vk r) m.
Proof.
intros.
inv H.
unfold balance.
repeat match goal with
       | H: Abs E _ |- _ => inv H
       | H: Abs (T _ _ _ _ _) _ |- _ => inv H
       | H: SearchTree' _ E _ |- _ => inv H
       | H: SearchTree' _ (T _ _ _ _ _) _ |- _ => inv H
       | |- Abs match c with Red => _ | Black => _ end _ => destruct c
       | |- Abs match ?s with E => _ | T _ _ _ _ _ => _ end _ => destruct s
       | |- Abs (T _ _ _ _ _) _ => apply Abs_T
       | |- Abs E _ => apply Abs_E
       | |- _ => assumption
       | |- _ => eapply Abs_helper; [repeat econstructor; eassumption | ]
       | H: SearchTree' ?lo _ ?hi |- _ = _ => apply SearchTree'_le in H
       | |- _ => contents_equivalent_prover
       end.
Qed.


Require Import msl.base.
Require Import msl.sepalg.

Require Import Coq.funind.Recdef.
Require Coq.Wellfounded.Wellfounded. (* Can't Import this, because that brings the identifier B into
           scope, which breaks things like `{ageable B}  in this file.
          Stupid feature of Coq, that the B in `{ageable B} is not unambiguously a
        binding occurrence of B.  *)
Delimit Scope pred with pred.
Local Open Scope pred.

Definition pred (A:Type) := A -> Prop.
Bind Scope pred with pred.

Definition derives (A:Type) (P Q:pred A) := forall a:A, P a -> Q a.
Arguments derives [A] _ _.

Lemma pred_ext : forall A (P Q:pred A),
  derives P Q -> derives Q P -> P = Q.
Proof.
  intros.
  extensionality a.
  apply prop_ext; intuition.
Qed.

Lemma derives_cut {A}  : forall Q P R : pred A,
  derives P Q ->
  derives Q R ->
  derives P R.
Proof.
  repeat intro; intuition.
Qed.

Definition prop {A: Type}  (P: Prop) : pred A := (fun _  => P).
Hint Unfold prop.

Definition TT {A}: pred A := prop True.
Definition FF  {A}: pred A := prop False.

Set Implicit Arguments.

Definition imp {A}  (P Q:pred A) :=
   fun a:A => P a -> Q a.
Definition orp {A} (P Q:pred A) :=
   fun a:A => P a \/ Q a.
Definition andp {A} (P Q:pred A) :=
   fun a:A => P a /\ Q a.

Definition allp {A B: Type} (f: B -> pred A) : pred A
  := fun a => forall b, f b a.
Definition exp {A B: Type} (f: B -> pred A) : pred A
  := fun a => exists b, f b a.

Notation "'emp'" := identity.

Definition sepcon {A} {JA: Join A}(p q:pred A) := fun z:A =>
  exists x:A, exists y:A, join x y z /\ p x /\ q y.
Definition wand {A}  {JA: Join A}  (p q:pred A) := fun y =>
  forall x z, join x y z -> p x -> q z.

Notation "P '|--' Q" := (derives P Q) (at level 80, no associativity).
Notation "'EX'  x ':' T ',' P " := (exp (fun x:T => P%pred)) (at level 65, x at level 99) : pred.
Notation "'ALL'  x ':' T  ',' P " := (allp (fun x:T => P%pred)) (at level 65, x at level 99) : pred.
Infix "||" := orp (at level 50, left associativity) : pred.
Infix "&&" := andp (at level 40, left associativity) : pred.
Notation "P '-->' Q" := (imp P Q) (at level 55, right associativity) : pred.
Notation "P '<-->' Q" := (andp (imp P Q) (imp Q P)) (at level 57, no associativity) : pred.
Notation "P '*' Q" := (sepcon P Q) : pred.
Notation "P '-*' Q" := (wand P Q) (at level 60, right associativity) : pred.
Notation "'!!' e" := (prop e) (at level 25) : pred.

Definition precise {A}  {JA: Join A}{PA: Perm_alg A}  (P: pred A) : Prop :=
     forall w w1 w2, P w1 -> P w2 -> join_sub w1 w -> join_sub w2 w -> w1=w2.

Definition precise2  {A} {JA: Join A}{PA: Perm_alg A}  (P: pred A) : Prop :=
     forall Q R, P * (Q && R) = (P * Q) && (P * R).

Lemma precise_eq {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
     precise =
                 fun P : pred A => forall Q R, P * (Q && R) = (P * Q) && (P * R).
Proof.
extensionality P.
unfold precise.
apply prop_ext; split; intros.
extensionality w.
apply prop_ext; split; intros.
destruct H0 as [phi1 [phi2 [? [? [? ?]]]]].
split; exists phi1; exists phi2; auto.
destruct H0 as [[phi1a [phi2a [? [? ?]]]] [phi1b [phi2b [? [? ?]]]]].
specialize (H w _ _ H1 H4).
spec H.
econstructor; eauto.
spec H.
econstructor; eauto.
subst phi1b.
generalize (join_canc (join_comm H0) (join_comm H3)).
intro; subst phi2b.
exists phi1a; exists phi2a; split; auto.
split; auto.
split; auto.
rename w1 into w1a.
rename w2 into w1b.
destruct H2 as [w2a ?].
destruct H3 as [w2b ?].
pose (fa x := x=w2a).
pose (fb x := x=w2b).
assert (((P * fa) && (P * fb)) w).
split; do 2 econstructor; repeat split; eauto.
rewrite <- H in H4.
destruct H4 as [w1 [w2 [? [? [? ?]]]]].
unfold fa,fb in *.
subst.
generalize (join_canc H2 H4); intro.
subst.
eapply join_canc; eauto.
Qed.

Lemma derives_precise {A} {JA: Join A}{PA: Perm_alg A}:
  forall P Q, (P |-- Q) -> precise Q -> precise P.
Proof.
intros; intro; intros; eauto.
Qed.

Lemma prop_true_and:
  forall (P: Prop) A (Q: pred A), P -> (!! P && Q = Q).
Proof.
intros. unfold prop, andp;
extensionality w; apply prop_ext; split; intuition.
Qed.

Lemma prop_andp_e {A}:  forall P Q (w:A), (!! P && Q) w -> P /\ Q w.
Proof.
intuition; destruct H; auto.
Qed.

Lemma prop_andp_i {A}:  forall P Q (w:A), P /\ Q w -> (!! P && Q) w.
Proof.
intuition.
split; auto.
Qed.

Lemma derives_trans {A}:  forall (P Q R: pred A), P |-- Q -> Q |-- R -> P |-- R.
Proof.
firstorder.
Qed.

Lemma and_i {A}: forall (P Q R: pred A),
    P |-- Q -> P |-- R -> P |-- Q && R.
Proof. intuition.
intros w ?.
split; eauto.
Qed.

Lemma andp_derives {A}  :
  forall P Q P' Q': pred A, P |-- P' -> Q |-- Q' -> P && Q |-- P' && Q'.
Proof.
intros.
intros w [? ?]; split; auto.
Qed.

Lemma sepcon_assoc {A} {JA: Join A}{PA: Perm_alg A}:
  forall p q r, (((p * q) * r) = (p * (q * r))).
Proof.
pose proof I.
intros.
extensionality w; apply prop_ext; split; intros.
destruct H0 as [w12 [w3 [? [[w1 [w2 [? [? ?]]]] ?]]]].
destruct (join_assoc H1 H0) as [w23 [? ?]].
exists w1; exists w23; repeat split; auto.
exists w2; exists w3; split; auto.
destruct H0 as [w1 [w23 [? [? [w2 [w3 [? [? ?]]]]]]]].
 destruct (join_assoc (join_comm H2) (join_comm H0)) as [w12 [? ?]].
exists w12; exists w3; repeat split; auto.
exists w1; exists w2; repeat split; auto.
Qed.

Lemma sepcon_comm {A} {JA: Join A}{PA: Perm_alg A}:  forall (P Q: pred A) , P * Q = Q * P.
Proof.
intros.
extensionality w; apply prop_ext; split; intros;
(destruct H as [w1 [w2 [? [? ?]]]]; exists w2; exists w1; split ; [apply join_comm; auto | split; auto]).
Qed.

Lemma sepcon_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}: forall P, (P * emp) = P.
Proof.
intros.
extensionality w; apply prop_ext; split; intros.
destruct H as [w1 [w2 [? [? ?]]]].
generalize (identity_unit (a:=w1) H1); intro.
spec H2.
econstructor; eauto.
unfold unit_for in H2.
generalize (join_eq H (join_comm H2)).
intros; subst; auto.
destruct (join_ex_identities w) as [e [? ?]].
exists w; exists e; repeat split; auto.
apply join_comm.
apply identity_unit; auto.
Qed.

Lemma emp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
    forall P, (emp*P) = P.
Proof. intros. rewrite sepcon_comm; rewrite sepcon_emp; auto. Qed.

Lemma precise_emp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
     precise emp.
Proof.
intros.
rewrite precise_eq.
intros.
repeat rewrite emp_sepcon.
auto.
Qed.

Definition exactly {A} (x: A) : pred A := fun w => w=x.

Lemma join_exactly {A} {JA: Join A}{PA: Perm_alg A}:
  forall w1 w2 w3, join w1 w2 w3 -> exactly w1 * exactly w2 = exactly w3.
Proof.
intros.
unfold exactly.
extensionality w.
apply prop_ext; split; intros.
destruct H0 as [? [? [? [? ?]]]].
subst. eapply join_eq; eauto.
subst w3.
exists w1; exists w2; split; auto.
Qed.

Lemma exists_and1 {A: Type} : forall {T: Type} (P: T -> pred A) (Q: pred A),
                   exp P && Q = EX x:T, P x && Q.
Proof.
intros.
extensionality w.
apply prop_ext; split; intros.
destruct H as [[x ?] ?].
exists x; split; auto.
destruct H as [x [? ?]].
split; auto.
exists x; auto.
Qed.

Lemma andp_comm {A: Type}: forall (P Q: pred A), P && Q = Q && P.
Proof.
intros.
extensionality w.
unfold andp;
apply prop_ext; split; intuition.
Qed.

Lemma andp_assoc {A}: forall (P Q R: pred A),
                 ((P && Q) && R = P && (Q && R)).
Proof.
intros.
extensionality w.
unfold andp.
apply prop_ext; intuition.
Qed.

Lemma True_andp_eq {A}:
  forall (P: Prop) (Q: pred A), P -> (!!P && Q)%pred = Q.
intros.
extensionality w; apply prop_ext; split; unfold prop, andp; simpl; intros; intuition.
Qed.

Lemma TT_i  {A} : forall w: A,  TT w.
Proof.
unfold TT, prop; simpl; auto.
Qed.

Hint Resolve @TT_i.

Lemma TT_and {A}: forall (Q: pred A), TT && Q = Q.
intros; unfold andp,  TT, prop; extensionality w.
apply prop_ext; intuition.
Qed.

Lemma andp_TT {A}: forall (P: pred A), P && TT = P.
Proof.
intros.
extensionality w; apply prop_ext; split; intros.
destruct H; auto.
split; auto.
Qed.

Lemma emp_wand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:
    forall P, emp -* P = P.
Proof.
intros.
extensionality w; apply prop_ext; split; intros.
destruct (join_ex_units w) as [e ?].
eapply H; eauto.
eapply unit_identity; eauto.
intro; intros.
replace z with w; auto.
Qed.

Lemma wand_derives {A} {JA: Join A}{PA: Perm_alg A}:
  forall P P' Q Q',  P' |-- P -> Q |-- Q' -> P -* Q |-- P' -* Q'.
Proof.
intros.
intros w ?.
intro; intros.
eauto.
Qed.

Lemma TT_sepcon_TT {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: TT * TT = TT.
Proof.
intros.
extensionality w; apply prop_ext; split; intros; auto.
destruct (join_ex_units w).
exists x; exists w; split; auto.
Qed.

Definition ewand {A} {JA: Join A} (P Q: pred A) : pred A :=
  fun w => exists w1, exists w2, join w1 w w2 /\ P w1 /\ Q w2.

(* Notation "P '-o' Q" := (ewand P Q) (at level 60, right associativity). *)

Lemma emp_ewand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{CA: Canc_alg A}:  forall P, ewand emp P = P.
Proof.
intros.
extensionality w; apply prop_ext; split; intros.
destruct H as [w1 [w2 [? [? ?]]]].
replace w with w2; auto.
eapply join_eq; eauto.
eapply identity_unit; eauto.
destruct (join_ex_units w) as [e ?].
exists e; exists w.
split; auto. split; auto.
eapply unit_identity; eauto.
Qed.

Lemma exists_sepcon1 {A} {JA: Join A}{PA: Perm_alg A}:
  forall T (P: T ->  pred A) Q,  exp P * Q = exp (fun x => P x * Q).
Proof.
intros.
extensionality w.
apply prop_ext; split; intros.
destruct H as [w1 [w2 [? [[x ?] ?]]]].
exists x; exists w1; exists w2; split; auto.
destruct H as [x [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; auto.
split; auto.
exists x; auto.
Qed.

Lemma derives_refl {A: Type}:
  forall (P: pred A), (P |-- P).
Proof. firstorder.
Qed.

Hint Resolve @derives_refl.

Lemma derives_TT {A}: forall (P: pred A), P |-- TT.
Proof.
intros.
intros ? ?; auto.
Qed.
Hint Resolve @derives_TT.

Lemma sepcon_derives {A} {JA: Join A}{PA: Perm_alg A}:
  forall p q p' q', (p |-- p') -> (q |-- q') -> (p * q |-- p' * q').
Proof.
intros.
do 2 intro.
destruct H1 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; repeat split ;auto.
Qed.

Lemma derives_e {A: Type}: forall p q (st: A),
      (p |-- q) -> p st -> q st.
Proof.
auto.
Qed.

Lemma exp_derives {A} :
       forall B (P: B -> pred A) Q , (forall x:B, P x |-- Q x) -> (exp P |-- exp Q).
Proof.
intros.
intros w [b ?].
exists b; eapply H; eauto.
Qed.

Lemma unmodus_wand {A}  {JA: Join A}{PA: Perm_alg A}:
 forall P Q R, Q = P * R ->  Q |-- P * (P -* Q).
Proof.
intros.
subst.
apply sepcon_derives; auto.
intros ?w ?; intro; intros.
exists x; exists w; split; auto.
Qed.

Definition superprecise {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} (P: pred A) :=
   forall w1 w2, P w1 -> P w2 -> comparable w1 w2 -> w1=w2.

Lemma modus_ewand {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} :  forall P Q, superprecise P -> P * (ewand P Q) |-- Q.
Proof.
pose proof I.
intros.
intros w ?.
destruct H1 as [w1 [w2 [? [? ?]]]].
unfold ewand in H3.
destruct H3 as [w1' [w3 [? [? ?]]]].
assert (w1'=w1).
  apply H0; auto.
  apply comparable_trans with w2. eapply join_comparable2; eauto.
  apply comparable_sym.  eapply join_comparable2; eauto.
  subst.
replace w with w3; auto.
eapply join_eq; eauto.
Qed.

Lemma exists_expand_sepcon {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall B (p: B -> pred A) q, (exp p * q)%pred = (exp (fun x => p x * q))%pred.
Proof.
intros; extensionality w; apply prop_ext; split; intros.
destruct H as [? [? [? [? ?]]]].
destruct H0.
exists x1; exists x; exists x0; split; auto.
destruct H as [? [? [? [? [? ?]]]]].
exists x0; exists x1; split; auto.
split; auto.
exists x; auto.
Qed.

Lemma exists_expand_sepcon' {A}  {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall B p (q: B -> pred A), (p * exp q)%pred = (exp (fun x => p * q x))%pred.
Proof.
intros; extensionality w; apply prop_ext; split; intros.
destruct H as [? [? [? [? ?]]]].
destruct H1.
exists x1; exists x; exists x0; split; auto.
destruct H as [? [? [? [? [? ?]]]]].
exists x0; exists x1; split; auto.
split; auto.
exists x; auto.
Qed.

Lemma exists_expand_and {A}  {JA: Join A}:
 forall B (p: B -> pred A) q, (exp p && q)%pred = (exp (fun x => p x && q))%pred.
Proof.
intros; extensionality w; apply prop_ext; split; intros.
destruct H.
destruct H.
exists x; split; auto.
destruct H. destruct H.
split; auto.
exists x; auto.
Qed.

Lemma exists_expand_and' {A} {JA: Join A}:
 forall B p (q: B -> pred A), (p && exp q)%pred = (exp (fun x => p && q x))%pred.
Proof.
intros; extensionality w; apply prop_ext; split; intros.
destruct H.
destruct H0.
exists x; split; auto.
destruct H. destruct H.
split; auto.
exists x; auto.
Qed.

Lemma allp_derives_right {A} : forall B p (q: B -> pred A),
  ((p |-- allp q) <-> (forall x, p |-- q x)).
Proof.
intros.
split; intros.
eapply derives_trans; eauto.
intros ? ?. apply H0.
intros ? ? ?.
eapply (H b).
auto.
Qed.

Lemma wand_exists {A} {JA: Join A}{PA: Perm_alg A}:
   forall B P Q,  (EX x: B, P -* Q x) |-- (P -* EX x : B, Q x).
Proof.
pose proof I.
intros.
intros w ?.
destruct H0 as [x ?].
intros ?w ?w ? ?.
spec H0 w0 w1 H1 H2.
exists x; auto.
Qed.

Lemma modus_wand {A} {JA: Join A}{PA: Perm_alg A}:
  forall P Q,  P * (P -* Q) |-- Q.
Proof.
intros.
intros w  [?w [?w [? [? ?]]]].
eapply H1; eauto.
Qed.

Lemma distrib_sepcon_andp {A} {JA: Join A}{PA: Perm_alg A}:
  forall P Q R, P * (Q && R) |-- (P * Q) && (P * R).
Proof.
intros. intros w [w1 [w2 [? [? ?]]]].
destruct H1.
split; exists w1; exists w2; split; auto.
Qed.

Lemma andp_r {A: Type} : forall (P Q R: pred A), P |-- Q -> P |-- R -> P |-- Q && R.
Proof.
intros.
intros w ?; split; auto.
Qed.

Definition list_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A} : list (pred A) -> pred A := fold_right sepcon emp.

Lemma sepcon_andp_prop {A} {JA: Join A}{PA: Perm_alg A}: forall P Q R, P * (!!Q && R) = !!Q && (P * R).
Proof.
intros.
extensionality w; apply prop_ext; split; intros.
destruct H as [w1 [w2 [? [? [? ?]]]]].
split. apply H1.
exists w1; exists w2; split; [|split]; auto.
destruct H.
destruct H0 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
Qed.

Require Import msl.cross_split.

Lemma exactly_i {A} : forall x: A, exactly x x.
Proof. intros. reflexivity.
Qed.
Hint Resolve @exactly_i.

Lemma superprecise_exactly {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}: forall x, superprecise (exactly x).
Proof.
unfold exactly, superprecise; intros.
subst; auto.
Qed.
Hint Resolve @superprecise_exactly.

Lemma find_overlap {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
     Cross_alg A ->
     forall S P Q R, (S * P) && (Q * R) |--
                          EX SQ:_, EX SR:_, EX PQ:_, EX PR:_,
                            (((SQ* SR) && S)*((PQ* PR) && P)) &&
                            (((SQ* PQ) && Q)*((SR* PR) && R)) &&
                            !! (superprecise SQ /\ superprecise SR /\ superprecise PQ /\ superprecise PR).
Proof.
pose proof I.
intros.
intros w [[w1 [w2 [? [? ?]]]] [w3 [w4 [? [? ?]]]]].
destruct (X _ _ _ _ _ H0 H3) as [[[[wa wb] wc] wd] [? [? [? ?]]]].
exists (exactly wa); exists (exactly wb); exists (exactly wc); exists (exactly wd).
repeat split; auto.
exists w1; exists w2; split; [|split]; auto; split; auto.
exists wa; exists wb; split; [|split]; auto.
exists wc; exists wd; split; [|split]; auto.
exists w3; exists w4; split; [|split]; auto; split; auto.
exists wa; exists wc; split; [|split]; auto.
exists wb; exists wd; split; [|split]; auto.
Qed.

Lemma modus_ponens {A} : forall (X P Q:pred A),
  X |-- P ->
  X |-- (P --> Q) ->
  X |-- Q.
Proof.
  unfold derives, imp; simpl; intuition eauto.
Qed.

Lemma and_intro {A}  : forall (X P Q:pred A),
  X |-- P ->
  X |-- Q ->
  X |-- P && Q.
Proof.
  unfold derives, imp, andp; simpl; intuition.
Qed.

Lemma and1 {A}  : forall (X P Q:pred A),
  X |-- P && Q --> P.
Proof.
  unfold derives, imp, andp; simpl; intuition eauto.
Qed.

Lemma and2 {A}  : forall (X P Q:pred A),
  X |-- P && Q --> Q.
Proof.
  unfold derives, imp, andp; simpl; intuition eauto.
Qed.

Lemma and3 {A}  : forall (X P Q R:pred A),
  X |-- (P --> Q) --> (P --> R) --> (P --> Q && R).
Proof.
  unfold derives, imp, andp; simpl; intuition eauto.
Qed.

Lemma or1 {A}  : forall (X P Q:pred A),
  X |-- P --> P || Q.
Proof.
  unfold derives, imp, orp; simpl; intuition.
Qed.

Lemma or2 {A}  : forall (X P Q:pred A),
  X |-- Q --> P || Q.
Proof.
  unfold derives, imp, orp; simpl; intuition.
Qed.

Lemma or3 {A}  : forall (X P Q R:pred A),
  X |-- (P --> R) --> (Q --> R) --> (P || Q --> R).
Proof.
  unfold derives, imp, orp; simpl; intuition eauto.
Qed.

Lemma TTrule {A}  : forall X (P: pred A),
  X |-- P --> TT.
Proof.
  unfold derives, imp, TT; simpl; intuition.
Qed.

Lemma FFrule {A}  : forall X (P: pred A),
  X |-- FF --> P.
Proof.
  unfold derives, imp, FF; simpl; intuition.
hnf in H0; contradiction.
Qed.

Lemma distribution {A}  : forall (X P Q R:pred A),
  X |-- P && (Q || R) --> (P && Q) || (P && R).
Proof.
  unfold derives, imp, orp, andp; simpl; intuition.
Qed.

Lemma wand_sepcon_adjoint {A} {JA: Join A}{PA: Perm_alg A} : forall (P Q R:pred A),
  ((P * Q) |-- R) = (P |-- (Q -* R)).
Proof.
  intros. apply prop_ext.
  split; intros.
  hnf; intros; simpl; intros.
  hnf; intros.
  apply H.
  exists a; exists x; split; auto.
  hnf; intros.
  destruct H0 as [w [v [? [? ?]]]].
  eapply H; eauto.
Qed.

Lemma ewand_sepcon {A} {JA: Join A}{PA: Perm_alg A}: forall P Q R,
      (ewand (P * Q) R = ewand P (ewand Q R))%pred.
Proof.
intros; apply pred_ext; intros w ?.
destruct H as [w1 [w2 [? [? ?]]]].
destruct H0 as [w3 [w4 [? [? ?]]]].
exists w3.
destruct (join_assoc (join_comm H0) H) as [wf [? ?]].
exists wf.
split; [|split]; auto.
exists w4. exists w2. split; auto.
destruct H as [w1 [w2 [? [? ?]]]].
destruct H1 as [w3 [w4 [? [? ?]]]].
destruct (join_assoc (join_comm H) (join_comm H1)) as [wf [? ?]].
exists wf. exists w4. split; [|split]; auto.
exists w1; exists w3; split; auto.
Qed.

Lemma andp_right {A}  : forall (X P Q:pred A),
  X |-- P ->
  X |-- Q ->
  X |-- P && Q.
Proof.
  unfold derives, imp, andp; simpl; intuition.
Qed.

Lemma andp_left1{A}: forall P Q R: pred A,  P |-- R -> P && Q |-- R.
Proof. repeat intro. destruct H0; auto.
Qed.

Lemma andp_left2{A}: forall P Q R: pred A,  Q |-- R -> P && Q |-- R.
Proof. repeat intro. destruct H0; auto.
Qed.

Lemma orp_left{A}: forall P Q R: pred A,  P |-- R -> Q |-- R -> P || Q |-- R.
Proof. repeat intro. destruct H1; auto.
Qed.

Lemma orp_right1{A}: forall P Q R: pred A,  P |-- Q -> P |-- Q || R.
Proof. repeat intro. left; auto.
Qed.

Lemma orp_right2{A}: forall P Q R: pred A,  P |-- R -> P |-- Q || R.
Proof. repeat intro. right; auto.
Qed.

Lemma exp_right:
  forall {B A: Type}(x:B) p (q: B -> pred A),
    p |-- q x ->
    p |-- exp q.
Proof.
intros.
eapply derives_trans; try apply H.
intros w ?; exists x; auto.
Qed.

Lemma exp_left:
  forall {B A: Type}(p: B -> pred A) q,
  (forall x, p x |-- q) ->
   exp p |-- q.
Proof.
intros.
intros w [x' ?].
eapply H; eauto.
Qed.

Lemma allp_right {B A: Type}:
  forall (P: pred A) (Q: B -> pred A),
  (forall v, P |-- Q v) ->
   P |-- allp Q.
Proof.
 intros. intros w ? v; apply (H v); auto.
Qed.

Lemma allp_left {B}{A}:
   forall (P: B -> pred A) x Q, P x |-- Q -> allp P |-- Q.
 Proof.
   intros. intros ? ?. apply H. apply H0.
Qed.

Lemma imp_andp_adjoint {A}  : forall (P Q R:pred A),
  (P && Q) |-- R <-> P |-- (Q --> R).
Proof.
  split; intros.
  hnf; intros; simpl; intros.
  intro; intros. apply H. split; auto.
  intro; intros. destruct H0. apply H; auto.
Qed.

Lemma exp_andp1 {A} :
 forall B (p: B -> pred A) q, (exp p && q)%pred = (exp (fun x => p x && q))%pred.
Proof.
intros; apply pred_ext; intros w ?.
destruct H as [[x ?] ?].
exists x; split; auto.
destruct H as [x [? ?]]; split; auto. exists x; auto.
Qed.

Lemma exp_sepcon1 {A}  {JA: Join A}{PA: Perm_alg A}:
  forall T (P: T ->  pred A) Q,  (exp P * Q = exp (fun x => P x * Q))%pred.
Proof.
intros.
apply pred_ext; intros ? ?.
destruct H as [w1 [w2 [? [[x ?] ?]]]].
exists x; exists w1; exists w2; split; auto.
destruct H as [x [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; split; auto.
split; auto.
exists x; auto.
Qed.

Definition pure {A}{JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}
     (P: pred A) : Prop :=
   P |-- emp.

Lemma sepcon_pure_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
 forall P Q, pure P -> pure Q -> ((P * Q) = (P && Q)).
Proof.
intros.
apply pred_ext; intros w ?.
destruct H1 as [w1 [w2 [? [? ?]]]].
unfold pure in *.
assert (unit_for w1 w2). apply H in H2; simpl in H2;
apply identity_unit; auto. exists w; auto.
unfold unit_for in H4.
assert (w2=w) by (apply (join_eq H4 H1)).
subst w2.
assert (join w w1 w1).
apply identity_unit; apply H0 in H3; simpl in H3; auto. exists w; auto.
assert (w1=w) by (apply (join_eq H5 (join_comm H1))).
subst w1.
split; auto.
destruct H1.
exists w; exists w; split; [|split]; auto.
apply H in H1.
clear dependent P. clear dependent Q.
pose proof (core_unit w); unfold unit_for in *.
pose proof (H1 _ _ (join_comm H)).
rewrite H0 in H; auto.
Qed.

Lemma pure_sepcon_TT_andp {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}:
  forall P Q, pure P -> (P * TT) && Q = (P*Q).
Proof.
 pose proof I.
intros.
apply pred_ext.
intros w [? ?].
destruct H1 as [w1 [w2 [? [? ?]]]].
exists w1; exists w2; split; [|split]; auto.
apply join_unit1_e in H1; auto.
subst; auto.
apply andp_right.
apply sepcon_derives; auto.
intros w [w1 [w2 [? [? ?]]]].
apply join_unit1_e in H1; auto.
subst; auto.
Qed.

Lemma ewand_conflict {T}{JT: Join T}{PT: Perm_alg T}{ST: Sep_alg T}:
       forall P Q R, sepcon P Q |-- FF -> andp P (ewand Q R) |-- FF.
Proof.
 intros. intros w [? [w1 [w2 [? [? ?]]]]].
 specialize (H w2). apply H. exists w; exists w1; repeat split; auto.
Qed.

Lemma ewand_TT_sepcon {T}{JT: Join T}{PT: Perm_alg T}{ST: Sep_alg T}:
      forall P Q R,
(P * Q && ewand R (!!True))%pred |-- (P && ewand R (!!True) * (Q && ewand R (!!True)))%pred.
Proof.
intros.
intros w [[w1 [w2 [? [? ?]]]] [w3 [w4 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
destruct (join_assoc (join_comm H) (join_comm H2)) as [f [? ?]].
exists w3; exists f; repeat split; auto.
destruct (join_assoc H (join_comm H2)) as [g [? ?]].
exists w3; exists g; repeat split; auto.
Qed.


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

(************************************************************************)
(*   This file has been modified for the purposes of the HoTT library.  *)
(************************************************************************)

Set Implicit Arguments.

Require Import Logic.

Global Set Universe Polymorphism.
Global Set Asymmetric Patterns.
Global Set Primitive Projections.
Global Set Nonrecursive Elimination Schemes.
Local Unset Elimination Schemes.

(** [option A] is the extension of [A] with an extra element [None] *)

Inductive option (A : Type) : Type :=
  | Some : A -> option A
  | None : option A.

Scheme option_rect := Induction for option Sort Type.

Arguments Some {A} a.
Arguments None {A}.

Register option as core.option.type.

(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)

Inductive sum (A B : Type) : Type :=
  | inl : A -> sum A B
  | inr : B -> sum A B.

Scheme sum_rect := Induction for sum Sort Type.

Notation "x + y" := (sum x y) : type_scope.

Arguments inl {A B} _ , [A] B _.
Arguments inr {A B} _ , A [B] _.

(* A notation for coproduct that's less overloaded than [+] *)
Notation "x |_| y" := (sum x y) (only parsing) : type_scope.

(** [prod A B], written [A * B], is the product of [A] and [B];
    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)

Record prod (A B : Type) := pair { fst : A ; snd : B }.

Scheme prod_rect := Induction for prod Sort Type.

Arguments pair {A B} _ _.
Arguments fst {A B} _ / .
Arguments snd {A B} _ / .

Add Printing Let prod.

Notation "x * y" := (prod x y) : type_scope.
Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
Notation "A /\ B" := (prod A B) (only parsing) : type_scope.
Notation and := prod (only parsing).
Notation conj := pair (only parsing).

Hint Resolve pair inl inr : core.

Definition prod_curry (A B C : Type) (f : A -> B -> C)
  (p : prod A B) : C := f (fst p) (snd p).

(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)

Definition iff (A B : Type) := prod (A -> B) (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

(* Natural numbers. *)

Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

Scheme nat_rect := Induction for nat Sort Type.

(* It would be nice not to need this, but the tactic [induction] requires it when the target is in [Set], and the above definition of [nat] puts it in [Set]. *)
Scheme nat_rec := Induction for nat Sort Set.

Declare Scope nat_scope.
Delimit Scope nat_scope with nat.
Bind Scope nat_scope with nat.
Arguments S _%nat.

Open Scope nat_scope. (* Originally in Peano.v *)

(** [identity A a] is the family of datatypes on [A] whose sole non-empty
    member is the singleton datatype [identity A a a] whose
    sole inhabitant is denoted [refl_identity A a] *)

Inductive identity (A : Type) (a : A) : A -> Type :=
  identity_refl : identity a a.

Scheme identity_rect := Induction for identity Sort Type.

Hint Resolve identity_refl: core.

Arguments identity {A} _ _.
Arguments identity_refl {A a} , [A] a.

Arguments identity_rect [A] a P f y i.

(** Identity type *)

(*
Definition ID := forall A : Type, A -> A.
Definition id : ID := fun A x => x.
*)

Declare Scope identity_scope.
Delimit Scope identity_scope with identity.

Notation "x = y :> A" := (@identity A x y)%identity : identity_scope.

Notation "x = y" := (x = y :>_)%identity : identity_scope.
Notation "x <> y  :> T" := (not (x = y :> T))%identity : identity_scope.
Notation "x <> y" := (x <> y :>_)%identity : identity_scope.

Local Open Scope identity_scope.

(** Another way of interpreting booleans as propositions *)

(* Definition is_true b := b = true. *)

(** Polymorphic lists and some operations *)

Inductive list (A : Type) : Type :=
 | nil : list A
 | cons : A -> list A -> list A.

Scheme list_rect := Induction for list Sort Type.

Arguments nil {A}.
Declare Scope list_scope.
Infix "::" := cons (at level 60, right associativity) : list_scope.
Delimit Scope list_scope with list.
Bind Scope list_scope with list.

Local Open Scope list_scope.
(** Concatenation of two lists *)

Definition app (A : Type) : list A -> list A -> list A :=
  fix app l m :=
  match l with
   | nil => m
   | a :: l1 => a :: app l1 m
  end.

Infix "++" := app (right associativity, at level 60) : list_scope.


Require Import FormalSystem.

(*---------------------------------*)
(*The double negation translation*)

(*Definition and notation for negation*)
Definition nt : form -> form :=
  fun f => (Impl f Fa).
Notation "! f" := (nt f) (at level 99).

(*Question 2.1.1*)
(*The translation function*)
Fixpoint nnt (f : form) : form :=
  match f with
  | Tr => Tr
  | Fa => Fa
  | And f g => And (nnt f) (nnt g)
  | Or f g => !!(Or (nnt f) (nnt g))
  | Impl f g => Impl (nnt f) (nnt g)
  | All P => All (fun x => nnt (P x))
  | Ex P => !! (Ex (fun x => nnt (P x)))
  | Atom P => !! (Atom P) end.

(*Translating contexts*)
Definition nnt_ctx L : form ->  Prop :=
  fun f => exists f', L f' /\ f=nnt f'.

(*Translation commutes with context extension*)
Lemma nnt_ctx_ext L f g :
  nnt_ctx (L⋯f) ⊢ g ->
  nnt_ctx L ⋯ nnt f ⊢ g.
Proof.
  intro H. apply (deriv_substitution (nnt_ctx (L⋯f))).
  - exact H.
  - intros f0 H0. destruct H0 as [f' [p q]].
    case p.
    + intro. apply ax. left. exists f'.
      split; assumption.
    + intro H0. apply ax. right. rewrite H0  in q.
      exact q.
Qed.

(*Translating the empty context*)
Lemma nnt_ctx_Ø f :
    (nnt_ctx Ø ⊢ f) -> Ø ⊢ f.
Proof.
  intro.
  apply (deriv_substitution (nnt_ctx Ø)).
  - assumption.
  - intros f0 H0. destruct H0 as [g [H0 H0']].
    apply ax. assumption.
Qed.

(*----------------------------------*)
(*Some simple helper lemmas*)

(* ¬¬(A × B) → ¬¬A × ¬¬B*)
Lemma nn_and {L} f g (H:L ⊢ (!!(And (nnt f) (nnt g)))) :
  (L ⊢ !! (nnt f)) * (L ⊢ !!(nnt g)).
Proof.
  split; apply imp_i;
    [ apply (imp_e _ (nnt f) _) | apply (imp_e _ (nnt g) _)].
  - apply ax. right. reflexivity.
  - apply Fa_e, (imp_e _ (! And (nnt f) (nnt g))).
    * apply wkn, H.
    * apply imp_i, (imp_e _ (nnt f)).
        apply ax. left. right. reflexivity.
        apply (and_e1 _ _ (nnt g)), ax. right. reflexivity.
  - apply ax. right. reflexivity.
  - apply Fa_e, (imp_e _ (! And (nnt f) (nnt g))).
    * apply wkn, H.
    * apply imp_i, (imp_e _ (nnt g)).
        apply ax. left. right. reflexivity.
        apply (and_e2 _ (nnt f) _), ax. right. reflexivity.
Qed.

(* ¬¬A → A*)
Lemma f_nn {L} f (H:L ⊢ f) :
  L ⊢ !!f.
Proof.
  apply imp_i, (imp_e _ f Fa).
  - apply ax. right. reflexivity.
  - apply wkn. assumption.
Defined.

(* ¬¬¬A → ¬A*)
Lemma nnn_n {L} f (H:L ⊢ !!! f) :
  L ⊢ !f.
Proof.
  apply imp_i, (imp_e _ (!!f) Fa).
  - apply wkn, H.
  - apply f_nn, ax. right. reflexivity.
Defined.

Lemma nnt_helper L f :
  L⋯(!f) ⊢ f ->
  L ⊢ !!f.
Proof.
  intro. apply imp_i, (imp_e _ f).
  - apply ax. right. reflexivity.
  - assumption.
Defined.

(*---------------------------------*)
(*Soundness of the translation*)

(*Question 2.2.1*)
(*Double negation elim for translated formulae*)
Lemma nnt_dne (f : form) :
  forall L, L ⊢ (!! (nnt f)) ->
            L ⊢ nnt f.
Proof.
  induction f; intros; cbn; simpl in *;
    try (apply nnn_n; assumption).
  - apply Tr_i.
  - apply (imp_e _ (! Fa) (Fa)).
    + apply H.
    + apply imp_i, ax. right. reflexivity.
  - apply and_i.
    + apply IHf1, (fst (nn_and f1 f2 H)).
    + apply IHf2, (snd (nn_and f1 f2 H)).
  - apply imp_i, IHf2, imp_i, (imp_e _ (! Impl (nnt f1) (nnt f2))).
    + apply wkn, wkn, H.
    + apply imp_i, (imp_e _ (nnt f2)).
      * apply ax. left. right. reflexivity.
      * apply (imp_e _ (nnt f1)). apply ax. right. reflexivity.
        apply ax. left. left. right. reflexivity.
  - apply all_i. intro t. apply H, imp_i, (imp_e _ (!nnt(All f))).
    apply wkn, H0. cbn. apply imp_i, (imp_e _ (nnt(f t))).
    + apply ax. left. right. reflexivity.
    + apply (all_e _ (fun x:A => nnt (f x))).
      apply ax. right. reflexivity.
Qed.

(*Question 2.2.2*)
(*Soundness*)
Lemma nnt_soundness f L :
  L ⊢ f -> nnt_ctx L ⊢ nnt f.
Proof.
  intro H. induction H; intros; simpl in *;
            try apply f_nn; try (econstructor; assumption).
  - apply ax. exists f. split. apply H. reflexivity.
  - apply imp_i. apply nnt_ctx_ext. assumption.
  - apply (imp_e _ (nnt f)); assumption.
  - apply (and_e1 _ _ (nnt g)); assumption.
  - apply (and_e2 _ (nnt f)); assumption.
  - apply nnt_dne, imp_i.
    apply (imp_e _ (! Or (nnt f) (nnt g))).
    apply wkn; assumption. apply imp_i.
    apply (or_e _ (nnt f) (nnt g)).
    + apply ax. right. reflexivity.
    + apply (imp_e _ (nnt h)).
      * apply ax. left. left. right. reflexivity.
      * apply (deriv_weakening (nnt_ctx L⋯(nnt f))).
        apply nnt_ctx_ext. assumption.
        intros f0 H'. case H'.
        intros. left. left. left. assumption.
        intros. right. assumption.
    + apply (imp_e _ (nnt h)).
      * apply ax. left. left. right. reflexivity.
      * apply (deriv_weakening (nnt_ctx L⋯(nnt g))).
        apply nnt_ctx_ext. assumption.
        intros f0 H'. case H'.
        intros. left. left. left. assumption.
        intros. right. assumption.
  - apply (ex_i _ _ t). assumption.
  - apply nnt_dne, imp_i.
    apply (imp_e _ (!(Ex (fun x : A => nnt (P x))))).
    apply wkn; assumption.
    apply imp_i.
    apply (ex_e _ (fun x => nnt (P x))).
    + intro t. apply (imp_e _ (nnt f)).
      * apply ax; left; left; right; reflexivity.
      * apply (deriv_weakening (nnt_ctx L⋯(nnt (P t)))).
        apply nnt_ctx_ext. apply H0.
        intros f0 H'. case H'.
        intros. left. left. left. assumption.
        intros. right. assumption.
    + apply ax; right; reflexivity.
  - apply (all_e _ (fun t => nnt (P t))).
    assumption.
Qed.

(*Fin*)


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

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

Print Assumptions nonzero.


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

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

Print Assumptions nonzero.


Require Import Coq.ZArith.ZArith Coq.Lists.List.
Import ListNotations.
Open Scope Z_scope.

(*
  hand-translated from:
  void make_crc_table(void)
  {
    unsigned long c;
    int n, k;

    for (n = 0; n < 256; n++) {
      c = (unsigned long) n;
      for (k = 0; k < 8; k++) {
        if (c & 1)
          c = 0xedb88320L ^ (c >> 1);
        else
          c = c >> 1;
      }
      crc_table[n] = c;
    }
    crc_table_computed = 1;
  }
 *)

(*The inner loop, executed 8 times*)
Fixpoint gen_crc_table' (c : Z) (k : nat) : Z :=
  match k with
  | O => c
  | S k =>
    let c := gen_crc_table' c k in
    if negb (Z.land c 1 =? 0)
    then Z.lxor 0xedb88320 (Z.shiftr c 1)
    else Z.shiftr c 1
  end.

Definition gen_crc_table_entry (n : nat) : Z :=
  let c := Z.of_nat n in
  gen_crc_table' c 8.

Definition crc_table_Z' : list Z :=
  Eval compute in
    List.map gen_crc_table_entry (List.seq 0 256).

Definition crc_table_Z : list Z :=
  [0x00000000; 0x77073096; 0xee0e612c; 0x990951ba;
   0x076dc419; 0x706af48f; 0xe963a535; 0x9e6495a3;
   0x0edb8832; 0x79dcb8a4; 0xe0d5e91e; 0x97d2d988;
   0x09b64c2b; 0x7eb17cbd; 0xe7b82d07; 0x90bf1d91;
   0x1db71064; 0x6ab020f2; 0xf3b97148; 0x84be41de;
   0x1adad47d; 0x6ddde4eb; 0xf4d4b551; 0x83d385c7;
   0x136c9856; 0x646ba8c0; 0xfd62f97a; 0x8a65c9ec;
   0x14015c4f; 0x63066cd9; 0xfa0f3d63; 0x8d080df5;
   0x3b6e20c8; 0x4c69105e; 0xd56041e4; 0xa2677172;
   0x3c03e4d1; 0x4b04d447; 0xd20d85fd; 0xa50ab56b;
   0x35b5a8fa; 0x42b2986c; 0xdbbbc9d6; 0xacbcf940;
   0x32d86ce3; 0x45df5c75; 0xdcd60dcf; 0xabd13d59;
   0x26d930ac; 0x51de003a; 0xc8d75180; 0xbfd06116;
   0x21b4f4b5; 0x56b3c423; 0xcfba9599; 0xb8bda50f;
   0x2802b89e; 0x5f058808; 0xc60cd9b2; 0xb10be924;
   0x2f6f7c87; 0x58684c11; 0xc1611dab; 0xb6662d3d;
   0x76dc4190; 0x01db7106; 0x98d220bc; 0xefd5102a;
   0x71b18589; 0x06b6b51f; 0x9fbfe4a5; 0xe8b8d433;
   0x7807c9a2; 0x0f00f934; 0x9609a88e; 0xe10e9818;
   0x7f6a0dbb; 0x086d3d2d; 0x91646c97; 0xe6635c01;
   0x6b6b51f4; 0x1c6c6162; 0x856530d8; 0xf262004e;
   0x6c0695ed; 0x1b01a57b; 0x8208f4c1; 0xf50fc457;
   0x65b0d9c6; 0x12b7e950; 0x8bbeb8ea; 0xfcb9887c;
   0x62dd1ddf; 0x15da2d49; 0x8cd37cf3; 0xfbd44c65;
   0x4db26158; 0x3ab551ce; 0xa3bc0074; 0xd4bb30e2;
   0x4adfa541; 0x3dd895d7; 0xa4d1c46d; 0xd3d6f4fb;
   0x4369e96a; 0x346ed9fc; 0xad678846; 0xda60b8d0;
   0x44042d73; 0x33031de5; 0xaa0a4c5f; 0xdd0d7cc9;
   0x5005713c; 0x270241aa; 0xbe0b1010; 0xc90c2086;
   0x5768b525; 0x206f85b3; 0xb966d409; 0xce61e49f;
   0x5edef90e; 0x29d9c998; 0xb0d09822; 0xc7d7a8b4;
   0x59b33d17; 0x2eb40d81; 0xb7bd5c3b; 0xc0ba6cad;
   0xedb88320; 0x9abfb3b6; 0x03b6e20c; 0x74b1d29a;
   0xead54739; 0x9dd277af; 0x04db2615; 0x73dc1683;
   0xe3630b12; 0x94643b84; 0x0d6d6a3e; 0x7a6a5aa8;
   0xe40ecf0b; 0x9309ff9d; 0x0a00ae27; 0x7d079eb1;
   0xf00f9344; 0x8708a3d2; 0x1e01f268; 0x6906c2fe;
   0xf762575d; 0x806567cb; 0x196c3671; 0x6e6b06e7;
   0xfed41b76; 0x89d32be0; 0x10da7a5a; 0x67dd4acc;
   0xf9b9df6f; 0x8ebeeff9; 0x17b7be43; 0x60b08ed5;
   0xd6d6a3e8; 0xa1d1937e; 0x38d8c2c4; 0x4fdff252;
   0xd1bb67f1; 0xa6bc5767; 0x3fb506dd; 0x48b2364b;
   0xd80d2bda; 0xaf0a1b4c; 0x36034af6; 0x41047a60;
   0xdf60efc3; 0xa867df55; 0x316e8eef; 0x4669be79;
   0xcb61b38c; 0xbc66831a; 0x256fd2a0; 0x5268e236;
   0xcc0c7795; 0xbb0b4703; 0x220216b9; 0x5505262f;
   0xc5ba3bbe; 0xb2bd0b28; 0x2bb45a92; 0x5cb36a04;
   0xc2d7ffa7; 0xb5d0cf31; 0x2cd99e8b; 0x5bdeae1d;
   0x9b64c2b0; 0xec63f226; 0x756aa39c; 0x026d930a;
   0x9c0906a9; 0xeb0e363f; 0x72076785; 0x05005713;
   0x95bf4a82; 0xe2b87a14; 0x7bb12bae; 0x0cb61b38;
   0x92d28e9b; 0xe5d5be0d; 0x7cdcefb7; 0x0bdbdf21;
   0x86d3d2d4; 0xf1d4e242; 0x68ddb3f8; 0x1fda836e;
   0x81be16cd; 0xf6b9265b; 0x6fb077e1; 0x18b74777;
   0x88085ae6; 0xff0f6a70; 0x66063bca; 0x11010b5c;
   0x8f659eff; 0xf862ae69; 0x616bffd3; 0x166ccf45;
   0xa00ae278; 0xd70dd2ee; 0x4e048354; 0x3903b3c2;
   0xa7672661; 0xd06016f7; 0x4969474d; 0x3e6e77db;
   0xaed16a4a; 0xd9d65adc; 0x40df0b66; 0x37d83bf0;
   0xa9bcae53; 0xdebb9ec5; 0x47b2cf7f; 0x30b5ffe9;
   0xbdbdf21c; 0xcabac28a; 0x53b39330; 0x24b4a3a6;
   0xbad03605; 0xcdd70693; 0x54de5729; 0x23d967bf;
   0xb3667a2e; 0xc4614ab8; 0x5d681b02; 0x2a6f2b94;
   0xb40bbe37; 0xc30c8ea1; 0x5a05df1b; 0x2d02ef8d].

Goal crc_table_Z = crc_table_Z'.
Proof. reflexivity. Qed.


Set Implicit Arguments.
Require Import List Lia.
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU.calculus Require Import prelim terms syntax semantics.

(* * Simple Typing *)

Section Typing.

  Context {X: Const}.

  Definition ctx := list type.

  Implicit Types (s t: exp X) (n m: nat) (Gamma Delta Sigma: ctx)
           (x y: fin) (c d: X) (A B: type)
           (sigma tau: fin -> exp X) (delta xi: fin -> fin).

  Reserved Notation "Gamma ⊢ s : A" (at level 80, s at level 99).

  Inductive typing  Gamma : exp X -> type -> Prop :=
  | typingVar i A: nth Gamma i = Some A -> Gamma ⊢ var i : A
  | typingConst c: Gamma ⊢ const c : ctype X c
  | typingLam s A B: A :: Gamma ⊢ s : B -> Gamma ⊢ lambda s : A → B
  | typingApp s t A B: Gamma ⊢ s : A → B -> Gamma ⊢ t : A -> Gamma ⊢ s t : B
  where "Gamma ⊢ s : A" := (typing Gamma s A).

  Hint Constructors typing : core.

  Definition typingRen Delta delta Gamma :=
    forall x A, nth Gamma x = Some A -> nth Delta (delta x) = Some A.

  Notation "Delta ⊫ delta : Gamma" := (typingRen Delta delta Gamma) (at level 80, delta at level 99).

  Definition typingSubst Delta sigma Gamma :=
    forall x A, nth Gamma x = Some A -> Delta ⊢ sigma x : A.

  Notation "Delta ⊩ sigma : Gamma" := (typingSubst Delta sigma Gamma) (at level 80, sigma at level 99).

  Lemma typingSubst_cons Delta sigma s Gamma A:
    Delta ⊩ sigma : Gamma -> Delta ⊢ s : A -> Delta ⊩ s .: sigma : A :: Gamma.
  Proof.
    intros ??[|]; cbn; eauto; now intros ? [= ->].
  Qed.

  (* ** Preservation *)
  Section Preservation.
    Lemma preservation_under_renaming delta Gamma Delta s A:
      Gamma ⊢ s : A -> Delta ⊫ delta : Gamma -> Delta ⊢ ren_exp delta s : A.
    Proof.
      induction 1 in  delta, Delta |-*; intros H'; cbn [ren_exp]; eauto.
      econstructor; apply IHtyping.
      intros []; cbn; eauto.
    Qed.

    Lemma preservation_under_substitution sigma Gamma Delta s A:
      Gamma ⊢ s : A -> Delta ⊩ sigma: Gamma -> Delta ⊢ sigma • s : A.
    Proof.
      induction 1 in sigma, Delta |-*; intros H'; cbn [subst_exp]; subst; eauto.
      econstructor; apply IHtyping; intros []; cbn; eauto.
      intros; eapply preservation_under_renaming; eauto.
      intros ?; eauto.
    Qed.

    Lemma preservation_under_reduction s s' Gamma A:
      s > s' -> Gamma ⊢ s : A -> Gamma ⊢ s' : A.
    Proof.
      induction 1 in Gamma, A |-*; intros H1; invp @typing; eauto.
      inv H3. eapply preservation_under_substitution; eauto.
      intros []; cbn; eauto.
      intros ? H; now injection H as ->.
    Qed.

    Lemma preservation_under_steps s s' Gamma A:
      s >* s' -> Gamma ⊢ s : A -> Gamma ⊢ s' : A.
    Proof.
      induction 1 in Gamma, A |-*; eauto using preservation_under_reduction.
    Qed.

  End Preservation.

  Lemma weakening_app Gamma Delta s A:
    Gamma ⊢ s : A -> Gamma ++ Delta ⊢ s : A.
  Proof.
    intros H; replace s with (ren id s) by now asimpl.
    eapply preservation_under_renaming; eauto.
    intros i B H'; unfold id.
    rewrite nth_error_app1; eauto.
    eapply nth_error_Some_lt; eauto.
  Qed.

  Lemma typing_variables Gamma s A:
    Gamma ⊢ s : A -> forall x, x ∈ vars s -> x ∈ dom Gamma.
  Proof.
    intros ? x H1 % vars_varof.
    induction H in x, H1 |-*; inv H1; eauto.
    - now domin H.
    - specialize (IHtyping _ H2).
      eapply dom_lt_iff in IHtyping.
      cbn in *. assert (x < length Gamma) by lia. auto.
  Qed.

End Typing.

Notation "Gamma ⊢ s : A" := (typing Gamma s A) (at level 80, s at level 99).
Notation "Delta ⊫ delta : Gamma" := (typingRen Delta delta Gamma) (at level 80, delta at level 99).
Notation "Delta ⊩ sigma : Gamma" := (typingSubst Delta sigma Gamma) (at level 80, sigma at level 99).

#[export] Hint Constructors typing : core.
#[export] Hint Resolve typing_variables : core.

#[export] Hint Resolve
     preservation_under_renaming
     preservation_under_substitution : core.


From mathcomp Require Import ssreflect.

Require Import relation.
Require Import axiom_of_pair.
Require Import axiom_of_empty.

Axiom AxiomOfUnion: forall U:Type, forall A:Collection (Collection U), exists B:Collection U, forall x:U, (x ∈ B <-> exists (C:Collection U), (x ∈ C /\ C ∈ A)).

Definition UnionFromAxiom U (A:Collection (Collection U)) : Collection U :=
  fun x =>
    exists B:Collection U, forall x:U, (x ∈ B <-> exists (C:Collection U), (x ∈ C /\ C ∈ A)) -> x ∈ B.

Inductive UnionOfCollection (U:Type) (A B:Collection U): Collection U :=
| union_of_collection_l: forall x:U, x ∈ A -> x ∈ UnionOfCollection U A B
| union_of_collection_r: forall x:U, x ∈ B -> x ∈ UnionOfCollection U A B
where "A ∪ B" := (UnionOfCollection _ A B).

Inductive BigCupOfCollection (U:Type) (X:Collection (Collection U)): Collection U :=
| intro_bigcup_of_collection: forall x:U, (exists A: Collection U, x ∈ A /\ A ∈ X) -> x ∈ BigCupOfCollection U X
where "⋃ X" := (BigCupOfCollection _ X).

Notation "{| x , y , .. , z |}" :=
  (UnionOfCollection _ .. (UnionOfCollection _ (Singleton _ x) (Singleton _ y)) .. (Singleton _ z)).

Theorem two_element_union_eq_unordered_pair:
  forall U:Type, forall {a b:U}, (| a , b |) = {| a , b |}.
Proof.
  move => U a b.
  apply mutally_included_iff_eq.
  split => x.
  case.
  left. apply singleton_iff_eq. reflexivity.
  right. apply singleton_iff_eq. reflexivity.
  case => x0 H; apply singleton_iff_eq in H; rewrite H.
  left.
  right.
Qed.

Theorem triple_ext_notation_to_or_eq:
  forall U:Type, forall {x a b c:U}, x ∈ {| a , b , c |} -> x = a \/ x = b \/ x = c.
Proof.
  move => U x a b c.
  case => x0.
  case => x1 H; apply singleton_iff_eq in H.
  left. by [].
  right. left. by [].
  move => H.
  apply singleton_iff_eq in H.
  right. right. by [].
Qed.

Theorem triple_or_eq_to_ext_notation:
  forall U:Type, forall {x a b c:U}, x = a \/ x = b \/ x = c -> x ∈ {| a , b , c |}.
Proof.
  move => U x a b c.
  case => H.
  left. left. apply singleton_iff_eq. by [].
  case: H => H0.
  left. right. apply singleton_iff_eq. by [].
  right. apply singleton_iff_eq. by [].
Qed.

Theorem triple_ext_notation_iff_or_eq:
  forall U:Type, forall {x a b c:U}, x ∈ {| a , b , c |} <-> x = a \/ x = b \/ x = c.
Proof.
  move => U x a b c.
  rewrite /iff. split.
  apply triple_ext_notation_to_or_eq.
  apply triple_or_eq_to_ext_notation.
Qed.

Section UnionFromAxiomTest.
  Variable U:Type.
  Variable a b c : U.
  Variable A B C:Collection U.

  Goal forall x:U, x ∈ UnionFromAxiom U (| A , B |) -> exists z':Collection U, z' = A ∪ B -> x ∈ z'.
  Proof.
    move => x.
    case => x' H.
    exists x'.
    move => H0.
    apply H.
    rewrite /iff. split; rewrite H0; case => x0 H1.
    exists A.
    split. by [].
    apply unordered_pair_l.
    exists B.
    split. by [].
    apply unordered_pair_r.
    case: H1 => H1 H2.
    apply in_unorder_pair_to_in_or in H2.
    case: H2 => H3; apply singleton_iff_eq in H3; rewrite H3 in H1.
    left. by [].
    right. by [].
  Qed.

  Goal ⋃ (| A , B |) = A ∪ B.
  Proof.
    apply AxiomOfExtentionality => x.
    rewrite /iff. split; case => x0 H.
    +inversion H as [A0 [Hx0A0 HA0]].
     inversion HA0.
     left.
     assumption.
     right.
     assumption.
    +split.
     exists A.
     split.
     trivial.
     left.
     split.
     exists B.
     split.
     trivial.
     right.
  Qed.

  Goal ⋃ {| A , B , C |} = A ∪ B ∪ C.
  Proof.
    apply mutally_included_to_eq.
    rewrite /iff. split => x H.
    inversion H.
    inversion H0 as [X0 [HxX0 HU]].
    inversion HU as [X1|X1].
    inversion H2 as [X2|X2].
    apply singleton_to_eq in H4.
    rewrite H4 in HxX0.
    left.
    trivial.
    apply singleton_to_eq in H4.
    rewrite H4 in HxX0.
    right.
    left.
    trivial.
    apply singleton_to_eq in H2.
    right.
    right.
    rewrite H2 in HxX0.
    trivial.
    inversion H.
    split.
    exists A.
    split.
    trivial.
    left.
    left.
    apply eq_to_singleton.
    reflexivity.
    inversion H0.
    split.
    exists B.
    split.
    trivial.
    left.
    right.
    apply eq_to_singleton.
    reflexivity.
    split.
    exists C.
    split.
    trivial.
    right.
    apply eq_to_singleton.
    reflexivity.
  Qed.

  Goal (| a , b |) ∪ {| c |} = {| a , b , c |}.
  Proof.
    apply mutally_included_iff_eq.
    split => x.
    case => x0.
    case. left.
    left.
    apply singleton_iff_eq. reflexivity.
    left. right.
    apply singleton_iff_eq. reflexivity.
    move => H.
    right. by [].
    case => x0 H.
    left.
    case H => x1 H0; apply singleton_iff_eq in H0; rewrite H0.
    left.
    right.
    right.
    apply H.
  Qed.

End UnionFromAxiomTest.

Theorem union_include_left: forall U:Type, forall {X Y:Collection U}, X ⊂ X ∪ Y.
Proof.
  move => U X Y x H.
  left. by [].
Qed.

Theorem union_include_right: forall U:Type, forall {X Y:Collection U}, Y ⊂ X ∪ Y.
Proof.
  move => U X Y x H.
  right. by [].
Qed.

Theorem in_union_to_in_or:
  forall U:Type, forall t:U, forall {X Y:Collection U}, t ∈ X ∪ Y -> t ∈ X \/ t ∈ Y.
Proof.
  move => U t X Y.
  case => x H.
  left. by [].
  right. by [].
Qed.

Theorem in_or_to_in_union:
  forall U:Type, forall t:U, forall {X Y:Collection U}, t ∈ X \/ t ∈ Y -> t ∈ X ∪ Y.
Proof.
  move => U t X Y.
  case => H.
  left. by [].
  right. by [].
Qed.

Theorem in_union_iff_in_or:
  forall U:Type, forall t:U, forall {X Y:Collection U}, t ∈ X ∪ Y <-> t ∈ X \/ t ∈ Y.
Proof.
  move => U t X Y.
  rewrite /iff. split.
  apply in_union_to_in_or.
  apply in_or_to_in_union.
Qed.

Theorem in_union_to_in_or_three:
  forall U:Type, forall t:U, forall {X Y Z:Collection U}, t ∈ X ∪ Y ∪ Z -> t ∈ X \/ t ∈ Y \/ t ∈ Z.
Proof.
  move => U t X Y Z H.
  apply in_union_iff_in_or in H.
  case: H => H0.
  left. by [].
  apply in_union_iff_in_or in H0.
  right. by [].
Qed.

Theorem in_or_to_in_union_three:
  forall U:Type, forall t:U, forall {X Y Z:Collection U}, t ∈ X \/ t ∈ Y \/ t ∈ Z -> t ∈ X ∪ Y ∪ Z.
Proof.
  move => U t X Y Z H.
  apply in_union_iff_in_or.
  case: H => H1.
  left. by [].
  right. apply in_union_iff_in_or. by [].
Qed.

Theorem LawOfIdempotenceAtUnion:
  forall U:Type, forall {X:Collection U}, X = X ∪ X.
Proof.
  move => U X.
  apply AxiomOfExtentionality => x.
  rewrite /iff. split => H.
  left. by [].
  case: H => x0. exact. exact.
Qed.

Theorem LawOfCommutativeAtUnion:
  forall U:Type, forall {X Y:Collection U}, X ∪ Y = Y ∪ X.
Proof.
  move => U X Y.
  apply AxiomOfExtentionality => x.
  rewrite /iff. split; case => x0 H.
  right. by[].
  left. by[].
  right. by[].
  left. by[].
Qed.

Theorem LawOfAssociateAtUnion:
  forall U:Type, forall {A B C:Collection U}, (A ∪ B) ∪ C = A ∪ (B ∪ C).
Proof.
  move => U A B C.
  apply AxiomOfExtentionality => x.
  rewrite /iff. split; case => x0.
  case => x1 H.
  left. by[].
  right. left. by [].
  move => H.
  right. right. by[].
  move => H.
  left. left. by [].
  case => x1 H.
  left. right. by [].
  right. by [].
Qed.

Theorem union_to_subcollect:
  forall U:Type, forall A B:Collection U, A ∪ B = B -> A ⊂ B.
Proof.
  move => U A B H.
  rewrite -H => x.
  move => H0.
  left. by [].
Qed.

Theorem subcollect_to_union:
  forall U:Type, forall A B:Collection U, A ⊂ B -> A ∪ B = B.
Proof.
  move => U A B H.
  apply mutally_included_to_eq.
  split => x.
  case. apply H. exact.
  move => H0.
  right. by [].
Qed.

Theorem union_iff_subcollect:
  forall U:Type, forall A B:Collection U, A ∪ B = B <-> A ⊂ B.
Proof.
  move => U A B.
  rewrite /iff. split.
  apply: union_to_subcollect.
  apply: subcollect_to_union.
Qed.

Theorem union_a_set_and_empty_eq_a_set:
  forall U:Type, forall A:Collection U, A ∪ `Ø` = A.
Proof.
  move => U A.
  rewrite LawOfCommutativeAtUnion.
  apply subcollect_to_union.
  apply all_collection_included_empty.
Qed.


Require Export P08.

Theorem invalid_triple : ~ forall (a : aexp) (n : nat),
    {{ a = n }}
      X := 3; Y := a
    {{ Y = n }}.
Proof.
  exact FILL_IN_HERE.
Qed.