Require Export paconotation pacotac pacodef pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 4
*)

(** 1 Mutual Coinduction *)

Section Arg4_1.

Definition monotone4 T0 T1 T2 T3 (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :=
  forall x0 x1 x2 x3 r r' (IN: gf r x0 x1 x2 x3) (LE: r <4= r'), gf r' x0 x1 x2 x3.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3.
Implicit Arguments gf [].

Theorem paco4_acc: forall
  l r (OBG: forall rr (INC: r <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4 gf rr),
  l <4= paco4 gf r.
Proof.
  intros; assert (SIM: paco4 gf (r \4/ l) x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_mon: monotone4 (paco4 gf).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_mult_strong: forall r,
  paco4 gf (paco4 gf r \4/ r) <4= paco4 gf r.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Corollary paco4_mult: forall r,
  paco4 gf (paco4 gf r) <4= paco4 gf r.
Proof. intros; eapply paco4_mult_strong, paco4_mon; eauto. Qed.

Theorem paco4_fold: forall r,
  gf (paco4 gf r \4/ r) <4= paco4 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco4_unfold: forall (MON: monotone4 gf) r,
  paco4 gf r <4= gf (paco4 gf r \4/ r).
Proof. unfold monotone4; intros; destruct PR; eauto. Qed.

End Arg4_1.

Hint Unfold monotone4.
Hint Resolve paco4_fold.

Implicit Arguments paco4_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_unfold         [ T0 T1 T2 T3 ].

Instance paco4_inst  T0 T1 T2 T3 (gf : rel4 T0 T1 T2 T3->_) r x0 x1 x2 x3 : paco_class (paco4 gf r x0 x1 x2 x3) :=
{ pacoacc    := paco4_acc gf;
  pacomult   := paco4_mult gf;
  pacofold   := paco4_fold gf;
  pacounfold := paco4_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg4_2.

Definition monotone4_2 T0 T1 T2 T3 (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :=
  forall x0 x1 x2 x3 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0 x1 x2 x3) (LE_0: r_0 <4= r'_0)(LE_1: r_1 <4= r'_1), gf r'_0 r'_1 x0 x1 x2 x3.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable gf_0 gf_1 : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco4_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4_2_0 gf_0 gf_1 rr r_1),
  l <4= paco4_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco4_2_0 gf_0 gf_1 (r_0 \4/ l) r_1 x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4_2_1 gf_0 gf_1 r_0 rr),
  l <4= paco4_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco4_2_1 gf_0 gf_1 r_0 (r_1 \4/ l) x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_2_0_mon: monotone4_2 (paco4_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_2_1_mon: monotone4_2 (paco4_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_2_0_mult_strong: forall r_0 r_1,
  paco4_2_0 gf_0 gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1) <4= paco4_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_2_1_mult_strong: forall r_0 r_1,
  paco4_2_1 gf_0 gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1) <4= paco4_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Corollary paco4_2_0_mult: forall r_0 r_1,
  paco4_2_0 gf_0 gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1) (paco4_2_1 gf_0 gf_1 r_0 r_1) <4= paco4_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco4_2_0_mult_strong, paco4_2_0_mon; eauto. Qed.

Corollary paco4_2_1_mult: forall r_0 r_1,
  paco4_2_1 gf_0 gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1) (paco4_2_1 gf_0 gf_1 r_0 r_1) <4= paco4_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco4_2_1_mult_strong, paco4_2_1_mon; eauto. Qed.

Theorem paco4_2_0_fold: forall r_0 r_1,
  gf_0 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1) <4= paco4_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco4_2_1_fold: forall r_0 r_1,
  gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1) <4= paco4_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco4_2_0_unfold: forall (MON: monotone4_2 gf_0) (MON: monotone4_2 gf_1) r_0 r_1,
  paco4_2_0 gf_0 gf_1 r_0 r_1 <4= gf_0 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1).
Proof. unfold monotone4_2; intros; destruct PR; eauto. Qed.

Theorem paco4_2_1_unfold: forall (MON: monotone4_2 gf_0) (MON: monotone4_2 gf_1) r_0 r_1,
  paco4_2_1 gf_0 gf_1 r_0 r_1 <4= gf_1 (paco4_2_0 gf_0 gf_1 r_0 r_1 \4/ r_0) (paco4_2_1 gf_0 gf_1 r_0 r_1 \4/ r_1).
Proof. unfold monotone4_2; intros; destruct PR; eauto. Qed.

End Arg4_2.

Hint Unfold monotone4_2.
Hint Resolve paco4_2_0_fold.
Hint Resolve paco4_2_1_fold.

Implicit Arguments paco4_2_0_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_0_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_0_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_0_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_0_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_0_unfold         [ T0 T1 T2 T3 ].
Implicit Arguments paco4_2_1_unfold         [ T0 T1 T2 T3 ].

Instance paco4_2_0_inst  T0 T1 T2 T3 (gf_0 gf_1 : rel4 T0 T1 T2 T3->_) r_0 r_1 x0 x1 x2 x3 : paco_class (paco4_2_0 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3) :=
{ pacoacc    := paco4_2_0_acc gf_0 gf_1;
  pacomult   := paco4_2_0_mult gf_0 gf_1;
  pacofold   := paco4_2_0_fold gf_0 gf_1;
  pacounfold := paco4_2_0_unfold gf_0 gf_1 }.

Instance paco4_2_1_inst  T0 T1 T2 T3 (gf_0 gf_1 : rel4 T0 T1 T2 T3->_) r_0 r_1 x0 x1 x2 x3 : paco_class (paco4_2_1 gf_0 gf_1 r_0 r_1 x0 x1 x2 x3) :=
{ pacoacc    := paco4_2_1_acc gf_0 gf_1;
  pacomult   := paco4_2_1_mult gf_0 gf_1;
  pacofold   := paco4_2_1_fold gf_0 gf_1;
  pacounfold := paco4_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg4_3.

Definition monotone4_3 T0 T1 T2 T3 (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :=
  forall x0 x1 x2 x3 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0 x1 x2 x3) (LE_0: r_0 <4= r'_0)(LE_1: r_1 <4= r'_1)(LE_2: r_2 <4= r'_2), gf r'_0 r'_1 r'_2 x0 x1 x2 x3.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable gf_0 gf_1 gf_2 : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco4_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <4= paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco4_3_0 gf_0 gf_1 gf_2 (r_0 \4/ l) r_1 r_2 x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <4= paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco4_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \4/ l) r_2 x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <4= rr) (CIH: l <_paco_4= rr), l <_paco_4= paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <4= paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \4/ l) x0 x1 x2 x3) by eauto.
  clear PR; repeat (try left; do 5 paco_revert; paco_cofix_auto).
Qed.

Theorem paco4_3_0_mon: monotone4_3 (paco4_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_3_1_mon: monotone4_3 (paco4_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_3_2_mon: monotone4_3 (paco4_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_3_0_mult_strong: forall r_0 r_1 r_2,
  paco4_3_0 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_3_1_mult_strong: forall r_0 r_1 r_2,
  paco4_3_1 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Theorem paco4_3_2_mult_strong: forall r_0 r_1 r_2,
  paco4_3_2 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 5 paco_revert; paco_cofix_auto). Qed.

Corollary paco4_3_0_mult: forall r_0 r_1 r_2,
  paco4_3_0 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <4= paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco4_3_0_mult_strong, paco4_3_0_mon; eauto. Qed.

Corollary paco4_3_1_mult: forall r_0 r_1 r_2,
  paco4_3_1 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <4= paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco4_3_1_mult_strong, paco4_3_1_mon; eauto. Qed.

Corollary paco4_3_2_mult: forall r_0 r_1 r_2,
  paco4_3_2 gf_0 gf_1 gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <4= paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco4_3_2_mult_strong, paco4_3_2_mon; eauto. Qed.

Theorem paco4_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco4_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco4_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2) <4= paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco4_3_0_unfold: forall (MON: monotone4_3 gf_0) (MON: monotone4_3 gf_1) (MON: monotone4_3 gf_2) r_0 r_1 r_2,
  paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <4= gf_0 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2).
Proof. unfold monotone4_3; intros; destruct PR; eauto. Qed.

Theorem paco4_3_1_unfold: forall (MON: monotone4_3 gf_0) (MON: monotone4_3 gf_1) (MON: monotone4_3 gf_2) r_0 r_1 r_2,
  paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <4= gf_1 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2).
Proof. unfold monotone4_3; intros; destruct PR; eauto. Qed.

Theorem paco4_3_2_unfold: forall (MON: monotone4_3 gf_0) (MON: monotone4_3 gf_1) (MON: monotone4_3 gf_2) r_0 r_1 r_2,
  paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <4= gf_2 (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_0) (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_1) (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \4/ r_2).
Proof. unfold monotone4_3; intros; destruct PR; eauto. Qed.

End Arg4_3.

Hint Unfold monotone4_3.
Hint Resolve paco4_3_0_fold.
Hint Resolve paco4_3_1_fold.
Hint Resolve paco4_3_2_fold.

Implicit Arguments paco4_3_0_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_acc            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_0_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_mon            [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_0_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_mult_strong    [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_0_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_mult           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_0_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_fold           [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_0_unfold         [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_1_unfold         [ T0 T1 T2 T3 ].
Implicit Arguments paco4_3_2_unfold         [ T0 T1 T2 T3 ].

Instance paco4_3_0_inst  T0 T1 T2 T3 (gf_0 gf_1 gf_2 : rel4 T0 T1 T2 T3->_) r_0 r_1 r_2 x0 x1 x2 x3 : paco_class (paco4_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3) :=
{ pacoacc    := paco4_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco4_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco4_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco4_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco4_3_1_inst  T0 T1 T2 T3 (gf_0 gf_1 gf_2 : rel4 T0 T1 T2 T3->_) r_0 r_1 r_2 x0 x1 x2 x3 : paco_class (paco4_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3) :=
{ pacoacc    := paco4_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco4_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco4_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco4_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco4_3_2_inst  T0 T1 T2 T3 (gf_0 gf_1 gf_2 : rel4 T0 T1 T2 T3->_) r_0 r_1 r_2 x0 x1 x2 x3 : paco_class (paco4_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0 x1 x2 x3) :=
{ pacoacc    := paco4_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco4_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco4_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco4_3_2_unfold gf_0 gf_1 gf_2 }.


From stdpp Require Import base tactics.
From stdpp Require Import options.

Local Set Universe Polymorphism.

(** Telescopes *)
Inductive tele : Type :=
  | TeleO : tele
  | TeleS {X} (binder : X → tele) : tele.

Arguments TeleS {_} _.

(** The telescope version of Coq's function type *)
Fixpoint tele_fun (TT : tele) (T : Type) : Type :=
  match TT with
  | TeleO => T
  | TeleS b => ∀ x, tele_fun (b x) T
  end.

Notation "TT -t> A" :=
  (tele_fun TT A) (at level 99, A at level 200, right associativity).

(** An eliminator for elements of [tele_fun].
    We use a [fix] because, for some reason, that makes stuff print nicer
    in the proofs in iris:bi/lib/telescopes.v *)
Definition tele_fold {X Y} {TT : tele} (step : ∀ {A : Type}, (A → Y) → Y) (base : X → Y)
  : (TT -t> X) → Y :=
  (fix rec {TT} : (TT -t> X) → Y :=
     match TT as TT return (TT -t> X) → Y with
     | TeleO => λ x : X, base x
     | TeleS b => λ f, step (λ x, rec (f x))
     end) TT.
Arguments tele_fold {_ _ !_} _ _ _ /.

(** A sigma-like type for an "element" of a telescope, i.e. the data it
  takes to get a [T] from a [TT -t> T]. *)
Inductive tele_arg : tele → Type :=
| TargO : tele_arg TeleO
(* the [x] is the only relevant data here *)
| TargS {X} {binder} (x : X) : tele_arg (binder x) → tele_arg (TeleS binder).

Definition tele_app {TT : tele} {T} (f : TT -t> T) : tele_arg TT → T :=
  λ a, (fix rec {TT} (a : tele_arg TT) : (TT -t> T) → T :=
     match a in tele_arg TT return (TT -t> T) → T with
     | TargO => λ t : T, t
     | TargS x a => λ f, rec a (f x)
     end) TT a f.
Arguments tele_app {!_ _} _ !_ /.

Coercion tele_arg : tele >-> Sortclass.
(* This is a local coercion because otherwise, the "λ.." notation stops working. *)
Local Coercion tele_app : tele_fun >-> Funclass.

(** Inversion lemma for [tele_arg] *)
Lemma tele_arg_inv {TT : tele} (a : TT) :
  match TT as TT return TT → Prop with
  | TeleO => λ a, a = TargO
  | TeleS f => λ a, ∃ x a', a = TargS x a'
  end a.
Proof. induction a; eauto. Qed.
Lemma tele_arg_O_inv (a : TeleO) : a = TargO.
Proof. exact (tele_arg_inv a). Qed.
Lemma tele_arg_S_inv {X} {f : X → tele} (a : TeleS f) :
  ∃ x a', a = TargS x a'.
Proof. exact (tele_arg_inv a). Qed.

(** Map below a tele_fun *)
Fixpoint tele_map {T U} {TT : tele} : (T → U) → (TT -t> T) → TT -t> U :=
  match TT as TT return (T → U) → (TT -t> T) → TT -t> U with
  | TeleO => λ F : T → U, F
  | @TeleS X b => λ (F : T → U) (f : TeleS b -t> T) (x : X),
                  tele_map F (f x)
  end.
Arguments tele_map {_ _ !_} _ _ /.

Lemma tele_map_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) :
  (tele_map F t) x = F (t x).
Proof.
  induction TT as [|X f IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). done.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite <-IH. done.
Qed.

Global Instance tele_fmap {TT : tele} : FMap (tele_fun TT) := λ T U, tele_map.

Lemma tele_fmap_app {T U} {TT : tele} (F : T → U) (t : TT -t> T) (x : TT) :
  (F <$> t) x = F (t x).
Proof. apply tele_map_app. Qed.

(** Operate below [tele_fun]s with argument telescope [TT]. *)
Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U :=
  match TT as TT return (TT → U) → TT -t> U with
  | TeleO => λ F, F TargO
  | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *)
                  tele_bind (λ a, F (TargS x a))
  end.
Arguments tele_bind {_ !_} _ /.

(* Show that tele_app ∘ tele_bind is the identity. *)
Lemma tele_app_bind {U} {TT : tele} (f : TT → U) x :
  (tele_app $ tele_bind f) x = f x.
Proof.
  induction TT as [|X b IH]; simpl in *.
  - rewrite (tele_arg_O_inv x). done.
  - destruct (tele_arg_S_inv x) as [x' [a' ->]]. simpl.
    rewrite IH. done.
Qed.

(** We can define the identity function and composition of the [-t>] function
space. *)
Definition tele_fun_id {TT : tele} : TT -t> TT := tele_bind id.

Lemma tele_fun_id_eq {TT : tele} (x : TT) :
  tele_fun_id x = x.
Proof. unfold tele_fun_id. rewrite tele_app_bind. done. Qed.

Definition tele_fun_compose {TT1 TT2 TT3 : tele} :
  (TT2 -t> TT3) → (TT1 -t> TT2) → (TT1 -t> TT3) :=
  λ t1 t2, tele_bind (compose (tele_app t1) (tele_app t2)).

Lemma tele_fun_compose_eq {TT1 TT2 TT3 : tele} (f : TT2 -t> TT3) (g : TT1 -t> TT2) x :
  tele_fun_compose f g $ x = (f ∘ g) x.
Proof. unfold tele_fun_compose. rewrite tele_app_bind. done. Qed.

(** Notation *)
Notation "'[tele' x .. z ]" :=
  (TeleS (fun x => .. (TeleS (fun z => TeleO)) ..))
  (x binder, z binder, format "[tele  '[hv' x  ..  z ']' ]").
Notation "'[tele' ]" := (TeleO)
  (format "[tele ]").

Notation "'[tele_arg' x ; .. ; z ]" :=
  (TargS x ( .. (TargS z TargO) ..))
  (format "[tele_arg  '[hv' x ;  .. ;  z ']' ]").
Notation "'[tele_arg' ]" := (TargO)
  (format "[tele_arg ]").

(** Notation-compatible telescope mapping *)
(* This adds (tele_app ∘ tele_bind), which is an identity function, around every
   binder so that, after simplifying, this matches the way we typically write
   notations involving telescopes. *)
Notation "'λ..' x .. y , e" :=
  (tele_app (tele_bind (λ x, .. (tele_app (tele_bind (λ y, e))) .. )))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' 'λ..'  x  ..  y ']' ,  e") : stdpp_scope.

(** Telescopic quantifiers *)
Definition tforall {TT : tele} (Ψ : TT → Prop) : Prop :=
  tele_fold (λ (T : Type) (b : T → Prop), ∀ x : T, b x) (λ x, x) (tele_bind Ψ).
Arguments tforall {!_} _ /.
Definition texist {TT : tele} (Ψ : TT → Prop) : Prop :=
  tele_fold ex (λ x, x) (tele_bind Ψ).
Arguments texist {!_} _ /.

Notation "'∀..' x .. y , P" := (tforall (λ x, .. (tforall (λ y, P)) .. ))
  (at level 200, x binder, y binder, right associativity,
  format "∀..  x  ..  y ,  P") : stdpp_scope.
Notation "'∃..' x .. y , P" := (texist (λ x, .. (texist (λ y, P)) .. ))
  (at level 200, x binder, y binder, right associativity,
  format "∃..  x  ..  y ,  P") : stdpp_scope.

Lemma tforall_forall {TT : tele} (Ψ : TT → Prop) :
  tforall Ψ ↔ (∀ x, Ψ x).
Proof.
  symmetry. unfold tforall. induction TT as [|X ft IH].
  - simpl. split.
    + done.
    + intros ? p. rewrite (tele_arg_O_inv p). done.
  - simpl. split; intros Hx a.
    + rewrite <-IH. done.
    + destruct (tele_arg_S_inv a) as [x [pf ->]].
      revert pf. setoid_rewrite IH. done.
Qed.

Lemma texist_exist {TT : tele} (Ψ : TT → Prop) :
  texist Ψ ↔ ex Ψ.
Proof.
  symmetry. induction TT as [|X ft IH].
  - simpl. split.
    + intros [p Hp]. rewrite (tele_arg_O_inv p) in Hp. done.
    + intros. by exists TargO.
  - simpl. split; intros [p Hp]; revert Hp.
    + destruct (tele_arg_S_inv p) as [x [pf ->]]. intros ?.
      exists x. rewrite <-(IH x (λ a, Ψ (TargS x a))). eauto.
    + rewrite <-(IH p (λ a, Ψ (TargS p a))).
      intros [??]. eauto.
Qed.

(* Teach typeclass resolution how to make progress on these binders *)
Typeclasses Opaque tforall texist.
Hint Extern 1 (tforall _) =>
  progress cbn [tforall tele_fold tele_bind tele_app] : typeclass_instances.
Hint Extern 1 (texist _) =>
  progress cbn [texist tele_fold tele_bind tele_app] : typeclass_instances.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q R S Pprime Qprime Rprime Sprime A B X Y Qprimeprime Sprimeprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ P Q /\ (wd_ R S /\ (wd_ Pprime Qprime /\ (wd_ Rprime Sprime /\ (wd_ Qprime Qprimeprime /\ (wd_ Sprime Sprimeprime /\ (wd_ B Qprimeprime /\ (wd_ A Qprimeprime /\ (col_ A B Pprime /\ (col_ A B Qprime /\ (col_ A B Rprime /\ (col_ A B Sprime /\ col_ Pprime Qprimeprime Qprime)))))))))))))) -> col_ Pprime Qprime A)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Sandrine Blazy, ENSIIE and INRIA Paris-Rocquencourt        *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** In-memory representation of values. *)

Require Import Coqlib.
Require Import Zbits.
Require Archi.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.

(** * Properties of memory chunks *)

(** Memory reads and writes are performed by quantities called memory chunks,
  encoding the type, size and signedness of the chunk being addressed.
  The following functions extract the size information from a chunk. *)

Definition size_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mint64 => 8
  | Mfloat32 => 4
  | Mfloat64 => 8
  | Many32 => 4
  | Many64 => 8
  end.

Lemma size_chunk_pos:
  forall chunk, size_chunk chunk > 0.
Proof.
  intros. destruct chunk; simpl; omega.
Qed.

Definition size_chunk_nat (chunk: memory_chunk) : nat :=
  Z.to_nat(size_chunk chunk).

Lemma size_chunk_conv:
  forall chunk, size_chunk chunk = Z.of_nat (size_chunk_nat chunk).
Proof.
  intros. destruct chunk; reflexivity.
Qed.

Lemma size_chunk_nat_pos:
  forall chunk, exists n, size_chunk_nat chunk = S n.
Proof.
  intros.
  generalize (size_chunk_pos chunk). rewrite size_chunk_conv.
  destruct (size_chunk_nat chunk).
  simpl; intros; omegaContradiction.
  intros; exists n; auto.
Qed.

Lemma size_chunk_Mptr: size_chunk Mptr = if Archi.ptr64 then 8 else 4.
Proof.
  unfold Mptr; destruct Archi.ptr64; auto.
Qed.

(** Memory reads and writes must respect alignment constraints:
  the byte offset of the location being addressed should be an exact
  multiple of the natural alignment for the chunk being addressed.
  This natural alignment is defined by the following
  [align_chunk] function.  Some target architectures
  (e.g. PowerPC and x86) have no alignment constraints, which we could
  reflect by taking [align_chunk chunk = 1].  However, other architectures
  have stronger alignment requirements.  The following definition is
  appropriate for PowerPC, ARM and x86. *)

Definition align_chunk (chunk: memory_chunk) : Z :=
  match chunk with
  | Mint8signed => 1
  | Mint8unsigned => 1
  | Mint16signed => 2
  | Mint16unsigned => 2
  | Mint32 => 4
  | Mint64 => 8
  | Mfloat32 => 4
  | Mfloat64 => 4
  | Many32 => 4
  | Many64 => 4
  end.

Lemma align_chunk_pos:
  forall chunk, align_chunk chunk > 0.
Proof.
  intro. destruct chunk; simpl; omega.
Qed.

Lemma align_chunk_Mptr: align_chunk Mptr = if Archi.ptr64 then 8 else 4.
Proof.
  unfold Mptr; destruct Archi.ptr64; auto.
Qed.

Lemma align_size_chunk_divides:
  forall chunk, (align_chunk chunk | size_chunk chunk).
Proof.
  intros. destruct chunk; simpl; try apply Z.divide_refl; exists 2; auto.
Qed.

Lemma align_le_divides:
  forall chunk1 chunk2,
  align_chunk chunk1 <= align_chunk chunk2 -> (align_chunk chunk1 | align_chunk chunk2).
Proof.
  intros. destruct chunk1; destruct chunk2; simpl in *;
  solve [ omegaContradiction
        | apply Z.divide_refl
        | exists 2; reflexivity
        | exists 4; reflexivity
        | exists 8; reflexivity ].
Qed.

Inductive quantity : Type := Q32 | Q64.

Definition quantity_eq (q1 q2: quantity) : {q1 = q2} + {q1 <> q2}.
Proof. decide equality. Defined.
Global Opaque quantity_eq.

Definition size_quantity_nat (q: quantity) :=
  match q with Q32 => 4%nat | Q64 => 8%nat end.

Lemma size_quantity_nat_pos:
  forall q, exists n, size_quantity_nat q = S n.
Proof.
  intros. destruct q; [exists 3%nat | exists 7%nat]; auto.
Qed.

(** * Memory values *)

(** A ``memory value'' is a byte-sized quantity that describes the current
  content of a memory cell.  It can be either:
- a concrete 8-bit integer;
- a byte-sized fragment of an opaque value;
- the special constant [Undef] that represents uninitialized memory.
*)

(** Values stored in memory cells. *)

Inductive memval: Type :=
  | Undef: memval
  | Byte: byte -> memval
  | Fragment: val -> quantity -> nat -> memval.

(** * Encoding and decoding integers *)

(** We define functions to convert between integers and lists of bytes
  of a given length *)

Fixpoint bytes_of_int (n: nat) (x: Z) {struct n}: list byte :=
  match n with
  | O => nil
  | S m => Byte.repr x :: bytes_of_int m (x / 256)
  end.

Fixpoint int_of_bytes (l: list byte): Z :=
  match l with
  | nil => 0
  | b :: l' => Byte.unsigned b + int_of_bytes l' * 256
  end.

Definition rev_if_be (l: list byte) : list byte :=
  if Archi.big_endian then List.rev l else l.

Definition encode_int (sz: nat) (x: Z) : list byte :=
  rev_if_be (bytes_of_int sz x).

Definition decode_int (b: list byte) : Z :=
  int_of_bytes (rev_if_be b).

(** Length properties *)

Lemma length_bytes_of_int:
  forall n x, length (bytes_of_int n x) = n.
Proof.
  induction n; simpl; intros. auto. decEq. auto.
Qed.

Lemma rev_if_be_length:
  forall l, length (rev_if_be l) = length l.
Proof.
  intros; unfold rev_if_be; destruct Archi.big_endian.
  apply List.rev_length.
  auto.
Qed.

Lemma encode_int_length:
  forall sz x, length(encode_int sz x) = sz.
Proof.
  intros. unfold encode_int. rewrite rev_if_be_length. apply length_bytes_of_int.
Qed.

(** Decoding after encoding *)

Lemma int_of_bytes_of_int:
  forall n x,
  int_of_bytes (bytes_of_int n x) = x mod (two_p (Z.of_nat n * 8)).
Proof.
  induction n; intros.
  simpl. rewrite Zmod_1_r. auto.
Opaque Byte.wordsize.
  rewrite Nat2Z.inj_succ. simpl.
  replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega.
  rewrite two_p_is_exp; try omega.
  rewrite Zmod_recombine. rewrite IHn. rewrite Z.add_comm.
  change (Byte.unsigned (Byte.repr x)) with (Byte.Z_mod_modulus x).
  rewrite Byte.Z_mod_modulus_eq. reflexivity.
  apply two_p_gt_ZERO. omega. apply two_p_gt_ZERO. omega.
Qed.

Lemma rev_if_be_involutive:
  forall l, rev_if_be (rev_if_be l) = l.
Proof.
  intros; unfold rev_if_be; destruct Archi.big_endian.
  apply List.rev_involutive.
  auto.
Qed.

Lemma decode_encode_int:
  forall n x, decode_int (encode_int n x) = x mod (two_p (Z.of_nat n * 8)).
Proof.
  unfold decode_int, encode_int; intros. rewrite rev_if_be_involutive.
  apply int_of_bytes_of_int.
Qed.

Lemma decode_encode_int_1:
  forall x, Int.repr (decode_int (encode_int 1 (Int.unsigned x))) = Int.zero_ext 8 x.
Proof.
  intros. rewrite decode_encode_int.
  rewrite <- (Int.repr_unsigned (Int.zero_ext 8 x)).
  decEq. symmetry. apply Int.zero_ext_mod. compute. intuition congruence.
Qed.

Lemma decode_encode_int_2:
  forall x, Int.repr (decode_int (encode_int 2 (Int.unsigned x))) = Int.zero_ext 16 x.
Proof.
  intros. rewrite decode_encode_int.
  rewrite <- (Int.repr_unsigned (Int.zero_ext 16 x)).
  decEq. symmetry. apply Int.zero_ext_mod. compute; intuition congruence.
Qed.

Lemma decode_encode_int_4:
  forall x, Int.repr (decode_int (encode_int 4 (Int.unsigned x))) = x.
Proof.
  intros. rewrite decode_encode_int. transitivity (Int.repr (Int.unsigned x)).
  decEq. apply Z.mod_small. apply Int.unsigned_range. apply Int.repr_unsigned.
Qed.

Lemma decode_encode_int_8:
  forall x, Int64.repr (decode_int (encode_int 8 (Int64.unsigned x))) = x.
Proof.
  intros. rewrite decode_encode_int. transitivity (Int64.repr (Int64.unsigned x)).
  decEq. apply Z.mod_small. apply Int64.unsigned_range. apply Int64.repr_unsigned.
Qed.

(** A length-[n] encoding depends only on the low [8*n] bits of the integer. *)

Lemma bytes_of_int_mod:
  forall n x y,
  eqmod (two_p (Z.of_nat n * 8)) x y ->
  bytes_of_int n x = bytes_of_int n y.
Proof.
  induction n.
  intros; simpl; auto.
  intros until y.
  rewrite Nat2Z.inj_succ.
  replace (Z.succ (Z.of_nat n) * 8) with (Z.of_nat n * 8 + 8) by omega.
  rewrite two_p_is_exp; try omega.
  intro EQM.
  simpl; decEq.
  apply Byte.eqm_samerepr. red.
  eapply eqmod_divides; eauto. apply Z.divide_factor_r.
  apply IHn.
  destruct EQM as [k EQ]. exists k. rewrite EQ.
  rewrite <- Z_div_plus_full_l. decEq. change (two_p 8) with 256. ring. omega.
Qed.

Lemma encode_int_8_mod:
  forall x y,
  eqmod (two_p 8) x y ->
  encode_int 1%nat x = encode_int 1%nat y.
Proof.
  intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

Lemma encode_int_16_mod:
  forall x y,
  eqmod (two_p 16) x y ->
  encode_int 2%nat x = encode_int 2%nat y.
Proof.
  intros. unfold encode_int. decEq. apply bytes_of_int_mod. auto.
Qed.

(** * Encoding and decoding values *)

Definition inj_bytes (bl: list byte) : list memval :=
  List.map Byte bl.

Fixpoint proj_bytes (vl: list memval) : option (list byte) :=
  match vl with
  | nil => Some nil
  | Byte b :: vl' =>
      match proj_bytes vl' with None => None | Some bl => Some(b :: bl) end
  | _ => None
  end.

Remark length_inj_bytes:
  forall bl, length (inj_bytes bl) = length bl.
Proof.
  intros. apply List.map_length.
Qed.

Remark proj_inj_bytes:
  forall bl, proj_bytes (inj_bytes bl) = Some bl.
Proof.
  induction bl; simpl. auto. rewrite IHbl. auto.
Qed.

Lemma inj_proj_bytes:
  forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl.
Proof.
  induction cl; simpl; intros.
  inv H; auto.
  destruct a; try congruence. destruct (proj_bytes cl); inv H.
  simpl. decEq. auto.
Qed.

Fixpoint inj_value_rec (n: nat) (v: val) (q: quantity) {struct n}: list memval :=
  match n with
  | O => nil
  | S m => Fragment v q m :: inj_value_rec m v q
  end.

Definition inj_value (q: quantity) (v: val): list memval :=
  inj_value_rec (size_quantity_nat q) v q.

Fixpoint check_value (n: nat) (v: val) (q: quantity) (vl: list memval)
                       {struct n} : bool :=
  match n, vl with
  | O, nil => true
  | S m, Fragment v' q' m' :: vl' =>
      Val.eq v v' && quantity_eq q q' && Nat.eqb m m' && check_value m v q vl'
  | _, _ => false
  end.

Definition proj_value (q: quantity) (vl: list memval) : val :=
  match vl with
  | Fragment v q' n :: vl' =>
      if check_value (size_quantity_nat q) v q vl then v else Vundef
  | _ => Vundef
  end.

Definition encode_val (chunk: memory_chunk) (v: val) : list memval :=
  match v, chunk with
  | Vint n, (Mint8signed | Mint8unsigned) => inj_bytes (encode_int 1%nat (Int.unsigned n))
  | Vint n, (Mint16signed | Mint16unsigned) => inj_bytes (encode_int 2%nat (Int.unsigned n))
  | Vint n, Mint32 => inj_bytes (encode_int 4%nat (Int.unsigned n))
  | Vptr b ofs, Mint32 => if Archi.ptr64 then list_repeat 4%nat Undef else inj_value Q32 v
  | Vlong n, Mint64 => inj_bytes (encode_int 8%nat (Int64.unsigned n))
  | Vptr b ofs, Mint64 => if Archi.ptr64 then inj_value Q64 v else list_repeat 8%nat Undef
  | Vsingle n, Mfloat32 => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n)))
  | Vfloat n, Mfloat64 => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n)))
  | _, Many32 => inj_value Q32 v
  | _, Many64 => inj_value Q64 v
  | _, _ => list_repeat (size_chunk_nat chunk) Undef
  end.

Definition decode_val (chunk: memory_chunk) (vl: list memval) : val :=
  match proj_bytes vl with
  | Some bl =>
      match chunk with
      | Mint8signed => Vint(Int.sign_ext 8 (Int.repr (decode_int bl)))
      | Mint8unsigned => Vint(Int.zero_ext 8 (Int.repr (decode_int bl)))
      | Mint16signed => Vint(Int.sign_ext 16 (Int.repr (decode_int bl)))
      | Mint16unsigned => Vint(Int.zero_ext 16 (Int.repr (decode_int bl)))
      | Mint32 => Vint(Int.repr(decode_int bl))
      | Mint64 => Vlong(Int64.repr(decode_int bl))
      | Mfloat32 => Vsingle(Float32.of_bits (Int.repr (decode_int bl)))
      | Mfloat64 => Vfloat(Float.of_bits (Int64.repr (decode_int bl)))
      | Many32 => Vundef
      | Many64 => Vundef
      end
  | None =>
      match chunk with
      | Mint32 => if Archi.ptr64 then Vundef else Val.load_result chunk (proj_value Q32 vl)
      | Many32 => Val.load_result chunk (proj_value Q32 vl)
      | Mint64 => if Archi.ptr64 then Val.load_result chunk (proj_value Q64 vl) else Vundef
      | Many64 => Val.load_result chunk (proj_value Q64 vl)
      | _ => Vundef
      end
  end.

Ltac solve_encode_val_length :=
  match goal with
  | [ |- length (inj_bytes _) = _ ] => rewrite length_inj_bytes; solve_encode_val_length
  | [ |- length (encode_int _ _) = _ ] => apply encode_int_length
  | [ |- length (if ?x then _ else _) = _ ] => destruct x eqn:?; solve_encode_val_length
  | _ => reflexivity
  end.

Lemma encode_val_length:
  forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk.
Proof.
  intros. destruct v; simpl; destruct chunk; solve_encode_val_length.
Qed.

Lemma check_inj_value:
  forall v q n, check_value n v q (inj_value_rec n v q) = true.
Proof.
  induction n; simpl. auto.
  unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true.
  rewrite <- beq_nat_refl. simpl; auto.
Qed.

Lemma proj_inj_value:
  forall q v, proj_value q (inj_value q v) = v.
Proof.
  intros. unfold proj_value, inj_value. destruct (size_quantity_nat_pos q) as [n EQ].
  rewrite EQ at 1. simpl. rewrite check_inj_value. auto.
Qed.

Remark in_inj_value:
  forall mv v q, In mv (inj_value q v) -> exists n, mv = Fragment v q n.
Proof.
Local Transparent inj_value.
  unfold inj_value; intros until q. generalize (size_quantity_nat q). induction n; simpl; intros.
  contradiction.
  destruct H. exists n; auto. eauto.
Qed.

Lemma proj_inj_value_mismatch:
  forall q1 q2 v, q1 <> q2 -> proj_value q1 (inj_value q2 v) = Vundef.
Proof.
  intros. unfold proj_value. destruct (inj_value q2 v) eqn:V. auto. destruct m; auto.
  destruct (in_inj_value (Fragment v0 q n) v q2) as [n' EQ].
  rewrite V; auto with coqlib. inv EQ.
  destruct (size_quantity_nat_pos q1) as [p EQ1]; rewrite EQ1; simpl.
  unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_false by congruence. auto.
Qed.

Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Prop :=
  match v1, chunk1, chunk2 with
  | Vundef, _, _ => v2 = Vundef
  | Vint n, Mint8signed, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
  | Vint n, Mint8unsigned, Mint8signed => v2 = Vint(Int.sign_ext 8 n)
  | Vint n, Mint8signed, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
  | Vint n, Mint8unsigned, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n)
  | Vint n, Mint16signed, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
  | Vint n, Mint16unsigned, Mint16signed => v2 = Vint(Int.sign_ext 16 n)
  | Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
  | Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n)
  | Vint n, Mint32, Mint32 => v2 = Vint n
  | Vint n, Many32, Many32 => v2 = Vint n
  | Vint n, Mint32, Mfloat32 => v2 = Vsingle(Float32.of_bits n)
  | Vint n, Many64, Many64 => v2 = Vint n
  | Vint n, (Mint64 | Mfloat32 | Mfloat64 | Many64), _ => v2 = Vundef
  | Vint n, _, _ => True (**r nothing meaningful to say about v2 *)
  | Vptr b ofs, (Mint32 | Many32), (Mint32 | Many32) => v2 = if Archi.ptr64 then Vundef else Vptr b ofs
  | Vptr b ofs, Mint64, (Mint64 | Many64) => v2 = if Archi.ptr64 then Vptr b ofs else Vundef
  | Vptr b ofs, Many64, Many64 => v2 = Vptr b ofs
  | Vptr b ofs, Many64, Mint64 => v2 = if Archi.ptr64 then Vptr b ofs else Vundef
  | Vptr b ofs, _, _ => v2 = Vundef
  | Vlong n, Mint64, Mint64 => v2 = Vlong n
  | Vlong n, Mint64, Mfloat64 => v2 = Vfloat(Float.of_bits n)
  | Vlong n, Many64, Many64 => v2 = Vlong n
  | Vlong n, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mfloat32|Mfloat64|Many32), _ => v2 = Vundef
  | Vlong n, _, _ => True (**r nothing meaningful to say about v2 *)
  | Vfloat f, Mfloat64, Mfloat64 => v2 = Vfloat f
  | Vfloat f, Mfloat64, Mint64 => v2 = Vlong(Float.to_bits f)
  | Vfloat f, Many64, Many64 => v2 = Vfloat f
  | Vfloat f, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mfloat32|Mint64|Many32), _ => v2 = Vundef
  | Vfloat f, _, _ => True   (* nothing interesting to say about v2 *)
  | Vsingle f, Mfloat32, Mfloat32 => v2 = Vsingle f
  | Vsingle f, Mfloat32, Mint32 => v2 = Vint(Float32.to_bits f)
  | Vsingle f, Many32, Many32 => v2 = Vsingle f
  | Vsingle f, Many64, Many64 => v2 = Vsingle f
  | Vsingle f, (Mint8signed|Mint8unsigned|Mint16signed|Mint16unsigned|Mint32|Mint64|Mfloat64|Many64), _ => v2 = Vundef
  | Vsingle f, _, _ => True (* nothing interesting to say about v2 *)
  end.

Remark decode_val_undef:
  forall bl chunk, decode_val chunk (Undef :: bl) = Vundef.
Proof.
  intros. unfold decode_val. simpl. destruct chunk, Archi.ptr64; auto.
Qed.

Remark proj_bytes_inj_value:
  forall q v, proj_bytes (inj_value q v) = None.
Proof.
  intros. destruct q; reflexivity.
Qed.

Ltac solve_decode_encode_val_general :=
  exact I || reflexivity ||
  match goal with
  | |- context [ if Archi.ptr64 then _ else _ ] => destruct Archi.ptr64 eqn:?
  | |- context [ proj_bytes (inj_bytes _) ] => rewrite proj_inj_bytes
  | |- context [ proj_bytes (inj_value _ _) ] => rewrite proj_bytes_inj_value
  | |- context [ proj_value _ (inj_value _ _) ] => rewrite ?proj_inj_value, ?proj_inj_value_mismatch by congruence
  | |- context [ Int.repr(decode_int (encode_int 1 (Int.unsigned _))) ] => rewrite decode_encode_int_1
  | |- context [ Int.repr(decode_int (encode_int 2 (Int.unsigned _))) ] => rewrite decode_encode_int_2
  | |- context [ Int.repr(decode_int (encode_int 4 (Int.unsigned _))) ] => rewrite decode_encode_int_4
  | |- context [ Int64.repr(decode_int (encode_int 8 (Int64.unsigned _))) ] => rewrite decode_encode_int_8
  | |- Vint (Int.sign_ext _ (Int.sign_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_idem; omega
  | |- Vint (Int.zero_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.zero_ext_idem; omega
  | |- Vint (Int.sign_ext _ (Int.zero_ext _ _)) = Vint _ => f_equal; apply Int.sign_ext_zero_ext; omega
  end.

Lemma decode_encode_val_general:
  forall v chunk1 chunk2,
  decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)).
Proof.
Opaque inj_value.
  intros.
  destruct v; destruct chunk1 eqn:C1; try (apply decode_val_undef);
  destruct chunk2 eqn:C2; unfold decode_encode_val, decode_val, encode_val, Val.load_result;
  repeat solve_decode_encode_val_general.
- rewrite Float.of_to_bits; auto.
- rewrite Float32.of_to_bits; auto.
Qed.

Lemma decode_encode_val_similar:
  forall v1 chunk1 chunk2 v2,
  type_of_chunk chunk1 = type_of_chunk chunk2 ->
  size_chunk chunk1 = size_chunk chunk2 ->
  decode_encode_val v1 chunk1 chunk2 v2 ->
  v2 = Val.load_result chunk2 v1.
Proof.
  intros until v2; intros TY SZ DE.
  destruct chunk1; destruct chunk2; simpl in TY; try discriminate; simpl in SZ; try omegaContradiction;
  destruct v1; auto.
Qed.

Lemma decode_val_type:
  forall chunk cl,
  Val.has_type (decode_val chunk cl) (type_of_chunk chunk).
Proof.
  intros. unfold decode_val.
  destruct (proj_bytes cl).
  destruct chunk; simpl; auto.
Local Opaque Val.load_result.
  destruct chunk; simpl;
  (exact I || apply Val.load_result_type || destruct Archi.ptr64; (exact I || apply Val.load_result_type)).
Qed.

Lemma encode_val_int8_signed_unsigned:
  forall v, encode_val Mint8signed v = encode_val Mint8unsigned v.
Proof.
  intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int16_signed_unsigned:
  forall v, encode_val Mint16signed v = encode_val Mint16unsigned v.
Proof.
  intros. destruct v; simpl; auto.
Qed.

Lemma encode_val_int8_zero_ext:
  forall n, encode_val Mint8unsigned (Vint (Int.zero_ext 8 n)) = encode_val Mint8unsigned (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_zero_ext.
  compute; intuition congruence.
Qed.

Lemma encode_val_int8_sign_ext:
  forall n, encode_val Mint8signed (Vint (Int.sign_ext 8 n)) = encode_val Mint8signed (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_8_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma encode_val_int16_zero_ext:
  forall n, encode_val Mint16unsigned (Vint (Int.zero_ext 16 n)) = encode_val Mint16unsigned (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_zero_ext. compute; intuition congruence.
Qed.

Lemma encode_val_int16_sign_ext:
  forall n, encode_val Mint16signed (Vint (Int.sign_ext 16 n)) = encode_val Mint16signed (Vint n).
Proof.
  intros; unfold encode_val. decEq. apply encode_int_16_mod. apply Int.eqmod_sign_ext'. compute; auto.
Qed.

Lemma decode_val_cast:
  forall chunk l,
  let v := decode_val chunk l in
  match chunk with
  | Mint8signed => v = Val.sign_ext 8 v
  | Mint8unsigned => v = Val.zero_ext 8 v
  | Mint16signed => v = Val.sign_ext 16 v
  | Mint16unsigned => v = Val.zero_ext 16 v
  | _ => True
  end.
Proof.
  unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto.
  unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
  unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
  unfold Val.sign_ext. rewrite Int.sign_ext_idem; auto. omega.
  unfold Val.zero_ext. rewrite Int.zero_ext_idem; auto. omega.
Qed.

(** Pointers cannot be forged. *)

Definition quantity_chunk (chunk: memory_chunk) :=
  match chunk with
  | Mint64 | Mfloat64 | Many64 => Q64
  | _ => Q32
  end.

Inductive shape_encoding (chunk: memory_chunk) (v: val): list memval -> Prop :=
  | shape_encoding_f: forall q i mvl,
      (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
      q = quantity_chunk chunk ->
      S i = size_quantity_nat q ->
      (forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) ->
      shape_encoding chunk v (Fragment v q i :: mvl)
  | shape_encoding_b: forall b mvl,
      match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True | _ => False end ->
      (forall mv, In mv mvl -> exists b', mv = Byte b') ->
      shape_encoding chunk v (Byte b :: mvl)
  | shape_encoding_u: forall mvl,
      (forall mv, In mv mvl -> mv = Undef) ->
      shape_encoding chunk v (Undef :: mvl).

Lemma encode_val_shape: forall chunk v, shape_encoding chunk v (encode_val chunk v).
Proof.
  intros.
  destruct (size_chunk_nat_pos chunk) as [sz EQ].
  assert (A: forall mv q n,
             (n < size_quantity_nat q)%nat ->
             In mv (inj_value_rec n v q) ->
             exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q).
  {
    induction n; simpl; intros. contradiction. destruct H0.
    exists n; split; auto. omega. apply IHn; auto. omega.
  }
  assert (B: forall q,
             q = quantity_chunk chunk ->
             (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
             shape_encoding chunk v (inj_value q v)).
  {
Local Transparent inj_value.
    intros. unfold inj_value. destruct (size_quantity_nat_pos q) as [sz' EQ'].
    rewrite EQ'. simpl. constructor; auto.
    intros; eapply A; eauto. omega.
  }
  assert (C: forall bl,
             match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True | _ => False end ->
             length (inj_bytes bl) = size_chunk_nat chunk ->
             shape_encoding chunk v (inj_bytes bl)).
  {
    intros. destruct bl as [|b1 bl]. simpl in H0; congruence. simpl.
    constructor; auto. unfold inj_bytes; intros. exploit list_in_map_inv; eauto.
    intros (b & P & Q); exists b; auto.
  }
  assert (D: shape_encoding chunk v (list_repeat (size_chunk_nat chunk) Undef)).
  {
    intros. rewrite EQ; simpl; constructor; auto.
    intros. eapply in_list_repeat; eauto.
  }
  generalize (encode_val_length chunk v). intros LEN.
  unfold encode_val; unfold encode_val in LEN;
  destruct v; destruct chunk;
  (apply B || apply C || apply D || (destruct Archi.ptr64; (apply B || apply D)));
  auto.
Qed.

Inductive shape_decoding (chunk: memory_chunk): list memval -> val -> Prop :=
  | shape_decoding_f: forall v q i mvl,
      (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
      q = quantity_chunk chunk ->
      S i = size_quantity_nat q ->
      (forall mv, In mv mvl -> exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q) ->
      shape_decoding chunk (Fragment v q i :: mvl) (Val.load_result chunk v)
  | shape_decoding_b: forall b mvl v,
      match v with Vint _ => True | Vlong _ => True | Vfloat _ => True | Vsingle _ => True |  _ => False end ->
      (forall mv, In mv mvl -> exists b', mv = Byte b') ->
      shape_decoding chunk (Byte b :: mvl) v
  | shape_decoding_u: forall mvl,
      shape_decoding chunk mvl Vundef.

Lemma decode_val_shape: forall chunk mv1 mvl,
  shape_decoding chunk (mv1 :: mvl) (decode_val chunk (mv1 :: mvl)).
Proof.
  intros.
  assert (A: forall mv mvs bs, proj_bytes mvs = Some bs -> In mv mvs ->
                               exists b, mv = Byte b).
  {
    induction mvs; simpl; intros.
    contradiction.
    destruct a; try discriminate. destruct H0. exists i; auto.
    destruct (proj_bytes mvs); try discriminate. eauto.
  }
  assert (B: forall v q mv n mvs,
             check_value n v q mvs = true -> In mv mvs -> (n < size_quantity_nat q)%nat ->
             exists j, mv = Fragment v q j /\ S j <> size_quantity_nat q).
  {
    induction n; destruct mvs; simpl; intros; try discriminate.
    contradiction.
    destruct m; try discriminate. InvBooleans. apply beq_nat_true in H4. subst.
    destruct H0. subst mv. exists n0; split; auto. omega.
    eapply IHn; eauto. omega.
  }
  assert (U: forall mvs, shape_decoding chunk mvs (Val.load_result chunk Vundef)).
  {
    intros. replace (Val.load_result chunk Vundef) with Vundef. constructor.
    destruct chunk; auto.
  }
  assert (C: forall q, size_quantity_nat q = size_chunk_nat chunk ->
             (chunk = Mint32 \/ chunk = Many32 \/ chunk = Mint64 \/ chunk = Many64) ->
             shape_decoding chunk (mv1 :: mvl) (Val.load_result chunk (proj_value q (mv1 :: mvl)))).
  {
    intros. unfold proj_value. destruct mv1; auto.
    destruct (size_quantity_nat_pos q) as [sz EQ]. rewrite EQ.
    simpl. unfold proj_sumbool. rewrite dec_eq_true.
    destruct (quantity_eq q q0); auto.
    destruct (Nat.eqb sz n) eqn:EQN; auto.
    destruct (check_value sz v q mvl) eqn:CHECK; auto.
    simpl. apply beq_nat_true in EQN. subst n q0. constructor. auto.
    destruct H0 as [E|[E|[E|E]]]; subst chunk; destruct q; auto || discriminate.
    congruence.
    intros. eapply B; eauto. omega.
  }
  unfold decode_val.
  destruct (proj_bytes (mv1 :: mvl)) as [bl|] eqn:PB.
  exploit (A mv1); eauto with coqlib. intros [b1 EQ1]; subst mv1.
  destruct chunk; (apply shape_decoding_u || apply shape_decoding_b); eauto with coqlib.
  destruct chunk, Archi.ptr64; (apply shape_decoding_u || apply C); auto.
Qed.

(** * Compatibility with memory injections *)

(** Relating two memory values according to a memory injection. *)

Inductive memval_inject (f: meminj): memval -> memval -> Prop :=
  | memval_inject_byte:
      forall n, memval_inject f (Byte n) (Byte n)
  | memval_inject_frag:
      forall v1 v2 q n,
      Val.inject f v1 v2 ->
      memval_inject f (Fragment v1 q n) (Fragment v2 q n)
  | memval_inject_undef:
      forall mv, memval_inject f Undef mv.

Lemma memval_inject_incr:
  forall f f' v1 v2, memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2.
Proof.
  intros. inv H; econstructor. eapply val_inject_incr; eauto.
Qed.

(** [decode_val], applied to lists of memory values that are pairwise
  related by [memval_inject], returns values that are related by [Val.inject]. *)

Lemma proj_bytes_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall bl,
  proj_bytes vl = Some bl ->
  proj_bytes vl' = Some bl.
Proof.
  induction 1; simpl. congruence.
  inv H; try congruence.
  destruct (proj_bytes al); intros.
  inv H. rewrite (IHlist_forall2 l); auto.
  congruence.
Qed.

Lemma check_value_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  forall v v' q n,
  check_value n v q vl = true ->
  Val.inject f v v' -> v <> Vundef ->
  check_value n v' q vl' = true.
Proof.
  induction 1; intros; destruct n; simpl in *; auto.
  inv H; auto.
  InvBooleans. assert (n = n0) by (apply beq_nat_true; auto). subst v1 q0 n0.
  replace v2 with v'.
  unfold proj_sumbool; rewrite ! dec_eq_true. rewrite <- beq_nat_refl. simpl; eauto.
  inv H2; try discriminate; inv H4; congruence.
  discriminate.
Qed.

Lemma proj_value_inject:
  forall f q vl1 vl2,
  list_forall2 (memval_inject f) vl1 vl2 ->
  Val.inject f (proj_value q vl1) (proj_value q vl2).
Proof.
  intros. unfold proj_value.
  inversion H; subst. auto. inversion H0; subst; auto.
  destruct (check_value (size_quantity_nat q) v1 q (Fragment v1 q0 n :: al)) eqn:B; auto.
  destruct (Val.eq v1 Vundef). subst; auto.
  erewrite check_value_inject by eauto. auto.
Qed.

Lemma proj_bytes_not_inject:
  forall f vl vl',
  list_forall2 (memval_inject f) vl vl' ->
  proj_bytes vl = None -> proj_bytes vl' <> None -> In Undef vl.
Proof.
  induction 1; simpl; intros.
  congruence.
  inv H; try congruence.
  right. apply IHlist_forall2.
  destruct (proj_bytes al); congruence.
  destruct (proj_bytes bl); congruence.
  auto.
Qed.

Lemma check_value_undef:
  forall n q v vl,
  In Undef vl -> check_value n v q vl = false.
Proof.
  induction n; intros; simpl.
  destruct vl. elim H. auto.
  destruct vl. auto.
  destruct m; auto. simpl in H; destruct H. congruence.
  rewrite IHn; auto. apply andb_false_r.
Qed.

Lemma proj_value_undef:
  forall q vl, In Undef vl -> proj_value q vl = Vundef.
Proof.
  intros; unfold proj_value.
  destruct vl; auto. destruct m; auto.
  rewrite check_value_undef. auto. auto.
Qed.

Theorem decode_val_inject:
  forall f vl1 vl2 chunk,
  list_forall2 (memval_inject f) vl1 vl2 ->
  Val.inject f (decode_val chunk vl1) (decode_val chunk vl2).
Proof.
  intros. unfold decode_val.
  destruct (proj_bytes vl1) as [bl1|] eqn:PB1.
  exploit proj_bytes_inject; eauto. intros PB2. rewrite PB2.
  destruct chunk; constructor.
  assert (A: forall q fn,
     Val.inject f (Val.load_result chunk (proj_value q vl1))
                  (match proj_bytes vl2 with
                   | Some bl => fn bl
                   | None => Val.load_result chunk (proj_value q vl2)
                   end)).
  { intros. destruct (proj_bytes vl2) as [bl2|] eqn:PB2.
    rewrite proj_value_undef. destruct chunk; auto. eapply proj_bytes_not_inject; eauto. congruence.
    apply Val.load_result_inject. apply proj_value_inject; auto.
  }
  destruct chunk; destruct Archi.ptr64; auto.
Qed.

(** Symmetrically, [encode_val], applied to values related by [Val.inject],
  returns lists of memory values that are pairwise
  related by [memval_inject]. *)

Lemma inj_bytes_inject:
  forall f bl, list_forall2 (memval_inject f) (inj_bytes bl) (inj_bytes bl).
Proof.
  induction bl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_any:
  forall f vl,
  list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl.
Proof.
  induction vl; simpl; constructor; auto. constructor.
Qed.

Lemma repeat_Undef_inject_encode_val:
  forall f chunk v,
  list_forall2 (memval_inject f) (list_repeat (size_chunk_nat chunk) Undef) (encode_val chunk v).
Proof.
  intros. rewrite <- (encode_val_length chunk v). apply repeat_Undef_inject_any.
Qed.

Lemma repeat_Undef_inject_self:
  forall f n,
  list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef).
Proof.
  induction n; simpl; constructor; auto. constructor.
Qed.

Lemma inj_value_inject:
  forall f v1 v2 q, Val.inject f v1 v2 -> list_forall2 (memval_inject f) (inj_value q v1) (inj_value q v2).
Proof.
  intros.
Local Transparent inj_value.
  unfold inj_value. generalize (size_quantity_nat q). induction n; simpl; constructor; auto.
  constructor; auto.
Qed.

Theorem encode_val_inject:
  forall f v1 v2 chunk,
  Val.inject f v1 v2 ->
  list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2).
Proof.
Local Opaque list_repeat.
  intros. inversion H; subst; simpl; destruct chunk;
  auto using inj_bytes_inject, inj_value_inject, repeat_Undef_inject_self, repeat_Undef_inject_encode_val.
- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self.
- destruct Archi.ptr64; auto using inj_value_inject, repeat_Undef_inject_self.
- unfold encode_val. destruct v2; apply inj_value_inject; auto.
- unfold encode_val. destruct v2; apply inj_value_inject; auto.
Qed.

Definition memval_lessdef: memval -> memval -> Prop := memval_inject inject_id.

Lemma memval_lessdef_refl:
  forall mv, memval_lessdef mv mv.
Proof.
  red. destruct mv; econstructor. apply val_inject_id. auto.
Qed.

(** [memval_inject] and compositions *)

Lemma memval_inject_compose:
  forall f f' v1 v2 v3,
  memval_inject f v1 v2 -> memval_inject f' v2 v3 ->
  memval_inject (compose_meminj f f') v1 v3.
Proof.
  intros. inv H.
  inv H0. constructor.
  inv H0. econstructor.
  eapply val_inject_compose; eauto.
  constructor.
Qed.

(** * Breaking 64-bit memory accesses into two 32-bit accesses *)

Lemma int_of_bytes_append:
  forall l2 l1,
  int_of_bytes (l1 ++ l2) = int_of_bytes l1 + int_of_bytes l2 * two_p (Z.of_nat (length l1) * 8).
Proof.
  induction l1; simpl int_of_bytes; intros.
  simpl. ring.
  simpl length. rewrite Nat2Z.inj_succ.
  replace (Z.succ (Z.of_nat (length l1)) * 8) with (Z.of_nat (length l1) * 8 + 8) by omega.
  rewrite two_p_is_exp. change (two_p 8) with 256. rewrite IHl1. ring.
  omega. omega.
Qed.

Lemma int_of_bytes_range:
  forall l, 0 <= int_of_bytes l < two_p (Z.of_nat (length l) * 8).
Proof.
  induction l; intros.
  simpl. omega.
  simpl length. rewrite Nat2Z.inj_succ.
  replace (Z.succ (Z.of_nat (length l)) * 8) with (Z.of_nat (length l) * 8 + 8) by omega.
  rewrite two_p_is_exp. change (two_p 8) with 256.
  simpl int_of_bytes. generalize (Byte.unsigned_range a).
  change Byte.modulus with 256. omega.
  omega. omega.
Qed.

Lemma length_proj_bytes:
  forall l b, proj_bytes l = Some b -> length b = length l.
Proof.
  induction l; simpl; intros.
  inv H; auto.
  destruct a; try discriminate.
  destruct (proj_bytes l) eqn:E; inv H.
  simpl. f_equal. auto.
Qed.

Lemma proj_bytes_append:
  forall l2 l1,
  proj_bytes (l1 ++ l2) =
  match proj_bytes l1, proj_bytes l2 with
  | Some b1, Some b2 => Some (b1 ++ b2)
  | _, _ => None
  end.
Proof.
  induction l1; simpl.
  destruct (proj_bytes l2); auto.
  destruct a; auto. rewrite IHl1.
  destruct (proj_bytes l1); auto. destruct (proj_bytes l2); auto.
Qed.

Lemma decode_val_int64:
  forall l1 l2,
  length l1 = 4%nat -> length l2 = 4%nat -> Archi.ptr64 = false ->
  Val.lessdef
    (decode_val Mint64 (l1 ++ l2))
    (Val.longofwords (decode_val Mint32 (if Archi.big_endian then l1 else l2))
                     (decode_val Mint32 (if Archi.big_endian then l2 else l1))).
Proof.
  intros. unfold decode_val. rewrite H1.
  rewrite proj_bytes_append.
  destruct (proj_bytes l1) as [b1|] eqn:B1; destruct (proj_bytes l2) as [b2|] eqn:B2; auto.
  exploit length_proj_bytes. eexact B1. rewrite H; intro L1.
  exploit length_proj_bytes. eexact B2. rewrite H0; intro L2.
  assert (UR: forall l, length l = 4%nat -> Int.unsigned (Int.repr (int_of_bytes l)) = int_of_bytes l).
    intros. apply Int.unsigned_repr.
    generalize (int_of_bytes_range l). rewrite H2.
    change (two_p (Z.of_nat 4 * 8)) with (Int.max_unsigned + 1).
    omega.
  apply Val.lessdef_same.
  unfold decode_int, rev_if_be. destruct Archi.big_endian; rewrite B1; rewrite B2.
  + rewrite <- (rev_length b1) in L1.
    rewrite <- (rev_length b2) in L2.
    rewrite rev_app_distr.
    set (b1' := rev b1) in *; set (b2' := rev b2) in *.
    unfold Val.longofwords. f_equal. rewrite Int64.ofwords_add. f_equal.
    rewrite !UR by auto. rewrite int_of_bytes_append.
    rewrite L2. change (Z.of_nat 4 * 8) with 32. ring.
  + unfold Val.longofwords. f_equal. rewrite Int64.ofwords_add. f_equal.
    rewrite !UR by auto. rewrite int_of_bytes_append.
    rewrite L1. change (Z.of_nat 4 * 8) with 32. ring.
Qed.

Lemma bytes_of_int_append:
  forall n2 x2 n1 x1,
  0 <= x1 < two_p (Z.of_nat n1 * 8) ->
  bytes_of_int (n1 + n2) (x1 + x2 * two_p (Z.of_nat n1 * 8)) =
  bytes_of_int n1 x1 ++ bytes_of_int n2 x2.
Proof.
  induction n1; intros.
- simpl in *. f_equal. omega.
- assert (E: two_p (Z.of_nat (S n1) * 8) = two_p (Z.of_nat n1 * 8) * 256).
  {
    rewrite Nat2Z.inj_succ. change 256 with (two_p 8). rewrite <- two_p_is_exp.
    f_equal. omega. omega. omega.
  }
  rewrite E in *. simpl. f_equal.
  apply Byte.eqm_samerepr. exists (x2 * two_p (Z.of_nat n1 * 8)).
  change Byte.modulus with 256. ring.
  rewrite Z.mul_assoc. rewrite Z_div_plus. apply IHn1.
  apply Zdiv_interval_1. omega. apply two_p_gt_ZERO; omega. omega.
  assumption. omega.
Qed.

Lemma bytes_of_int64:
  forall i,
  bytes_of_int 8 (Int64.unsigned i) =
  bytes_of_int 4 (Int.unsigned (Int64.loword i)) ++ bytes_of_int 4 (Int.unsigned (Int64.hiword i)).
Proof.
  intros. transitivity (bytes_of_int (4 + 4) (Int64.unsigned (Int64.ofwords (Int64.hiword i) (Int64.loword i)))).
  f_equal. f_equal. rewrite Int64.ofwords_recompose. auto.
  rewrite Int64.ofwords_add'.
  change 32 with (Z.of_nat 4 * 8).
  rewrite Z.add_comm. apply bytes_of_int_append. apply Int.unsigned_range.
Qed.

Lemma encode_val_int64:
  forall v,
  Archi.ptr64 = false ->
  encode_val Mint64 v =
     encode_val Mint32 (if Archi.big_endian then Val.hiword v else Val.loword v)
  ++ encode_val Mint32 (if Archi.big_endian then Val.loword v else Val.hiword v).
Proof.
  intros. unfold encode_val. rewrite H.
  destruct v; destruct Archi.big_endian eqn:BI; try reflexivity;
  unfold Val.loword, Val.hiword, encode_val.
  unfold inj_bytes. rewrite <- map_app. f_equal.
  unfold encode_int, rev_if_be. rewrite BI. rewrite <- rev_app_distr. f_equal.
  apply bytes_of_int64.
  unfold inj_bytes. rewrite <- map_app. f_equal.
  unfold encode_int, rev_if_be. rewrite BI.
  apply bytes_of_int64.
Qed.


(*
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.SublistT.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimunLogic.Syntax.
Require Import Logic.QuantifierLogic.Syntax.
Require Import Logic.MinimunLogic.ProofTheory.Normal.
Require Import Logic.MinimunLogic.ProofTheory.Minimun.
Require Import Logic.MinimunLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.

Class BindedProofTheory (BL: BinderLanguage): Type := {
  binded_Gamma:> forall ts, ProofTheory (binded_L ts)
}.

Class QuantifierLogic
      (BL: BinderLanguage)
      {nL: forall ts, NormalLanguage (binded_L ts)}
      {qL: QuantifierLanguage BL}
      (BGamma: BindedProofTheory BL)
      {nGamma: forall ts, NormalProofTheory (binded_L ts) (binded_Gamma ts)}
      {mpGamma: forall ts, MinimunPropositionalLogic (binded_L ts) (binded_Gamma ts)} :=
{
  allp_elim: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- allp x --> ins_expr x e;
  allp_gen: forall (t: type) (ts: list type) (x: binded_expr ts) (y: binded_expr (t :: ts)),
    |-- lift_expr (sublistT_cons t (sublistT_refl ts)) x --> y ->
    |-- x --> allp y;
  exp_intros: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (e: binded_term ts t),
    |-- ins_expr x e --> exp x;
  exp_gen: forall (t: type) (ts: list type) (x: binded_expr (t :: ts)) (y: binded_expr ts),
    |-- x --> lift_expr (sublistT_cons t (sublistT_refl ts)) y ->
    |-- exp x --> y
}.

*)


From fae_gtlc_mu.cast_calculus Require Export types typing lang.
(* From fae_gtlc_mu.cast_calculus Require Export types typing lang. *)
From fae_gtlc_mu.stlc_mu Require Import types_notations.
From fae_gtlc_mu.backtranslation Require Export universe types cast_help.fix.

(* This file defines the embedding functions (figure 7) *)

(* TUnit → Universe *)
Definition embed_TUnit : val :=
  LamV (Fold (InjL (InjL (InjL (InjL (Var 0)))))).

Lemma embed_TUnit_typed Γ :
  Γ ⊢ₛ embed_TUnit : (TArrow TUnit Universe).
Proof.
  apply Lam_typed, Fold_typed. apply TUnit_Closed.
  repeat apply InjL_typed.
  all:try (intro σ; by asimpl).
  by apply Var_typed.
Qed.

(* Universe + Universe → Universe *)
Definition embed_Ground_TSum : val :=
  LamV (Fold ((InjL (InjL (InjL (InjR (Var 0))))))).

Definition embed_Ground_TSum_typed Γ :
  Γ ⊢ₛ embed_Ground_TSum : (TArrow (Universe + Universe) Universe)%types.
Proof.
  eapply (Lam_typed _ _ _ _).
  apply Fold_typed.
  repeat eapply (InjL_typed _ _ _ _ _).
  eapply (InjR_typed _ _ _ _).
  by apply Var_typed.
  Unshelve. all:try (intro σ; by asimpl).
Qed.

(* Universe × Universe → Universe *)
Definition embed_Ground_TProd : val :=
  LamV (Fold (InjL (InjL (InjR (Var 0))))).

Definition embed_Ground_TProd_typed Γ :
  Γ ⊢ₛ embed_Ground_TProd : ((TArrow (Universe × Universe) Universe))%types.
Proof.
  apply Lam_typed, Fold_typed; try closed_solver.
  repeat apply InjL_typed; try closed_solver.
  apply InjR_typed; try closed_solver.
  by eapply Var_typed; try closed_solver.
Qed.

(* (Universe → Universe) → Universe *)
Definition embed_Ground_TArrow : val :=
  LamV (Fold (InjL (InjR (Var 0)))).

Definition embed_Ground_TArrow_typed Γ :
  Γ ⊢ₛ embed_Ground_TArrow : (TArrow (TArrow Universe Universe) Universe).
Proof.
  eapply Lam_typed, Fold_typed; try closed_solver.
  repeat eapply InjL_typed; try closed_solver. eapply InjR_typed; try closed_solver.
  by apply Var_typed.
Qed.

(* (μ_.Universe) → Universe *)
(* Takes something of μ_.Universe, unfolds it so it is in Universe, and then puts in the last branch of the universe, after which folding again takes place *)
Definition embed_Ground_TRec : val :=
  LamV (Fold (InjR (Unfold (Var 0)))).

Definition embed_Ground_TRec_typed Γ :
  Γ ⊢ₛ embed_Ground_TRec : (TArrow (TRec Universe) Universe).
Proof.
  apply Lam_typed; try closed_solver. apply Fold_typed; try closed_solver.
  apply InjR_typed; try closed_solver.
  apply Unfold_typed_help; first by trivial.
  by apply Var_typed.
Qed.

(* Defines embedding function of type <<G>> → Universe for arbitrary ground type *)
Definition embed (τ : cast_calculus.types.type) (G : Ground τ) : val :=
  match G with
  | Ground_TUnit => embed_TUnit
  | Ground_TProd => embed_Ground_TProd
  | Ground_TSum => embed_Ground_TSum
  | Ground_TArrow => embed_Ground_TArrow
  | Ground_TRec => embed_Ground_TRec
  end.

Lemma embed_typed {τG : cast_calculus.types.type} {G : Ground τG} Γ :
  Γ ⊢ₛ (embed τG G) : (TArrow <<τG>> Universe).
Proof.
  destruct G.
    + apply embed_TUnit_typed.
    + apply embed_Ground_TProd_typed.
    + apply embed_Ground_TSum_typed.
    + apply embed_Ground_TArrow_typed.
    + apply embed_Ground_TRec_typed.
Qed.

Lemma embed_no_subs {τ : cast_calculus.types.type} {G : Ground τ} σ : (of_val (embed τ G)).[σ] = embed τ G.
Proof.
  destruct G; by asimpl.
Qed.

(* Below some derived functions which come in handy when defining the logical relations *)

(* (embed_TUnit v) evaluates to the value (embedV_TUnit v) *)
Definition embedV_TUnit (v : val) : val :=
  (FoldV (InjLV (InjLV (InjLV (InjLV v))))).

(* (embed_Ground_TSum v) evaluates to the value (embedV_Ground_TSum v) *)
Definition embedV_Ground_TSum (s : val) : val :=
  (FoldV ((InjLV (InjLV (InjLV (InjRV s)))))).

(* (embed_Ground_TProd v) evaluates to the value (embedV_Ground_TProd v) *)
Definition embedV_Ground_TProd (p : val) : val :=
  (FoldV (InjLV (InjLV (InjRV p)))).

(* (embed_Ground_TArrow v) evaluates to the value (embedV_Ground_TArrow v) *)
Definition embedV_Ground_TArrow (v : val) : val :=
  FoldV (InjLV (InjRV v)).

(** a bit different from the other ones... u : Universe instead of u : μX.Universe *)
Definition embedV_TUnknown (u : val) : val :=
  (FoldV (InjRV u)).


Require Import Ascii.
From Coq Require Import
     Sets.Ensembles
     NArith.BinNat
     ZArith.Int
     FSets.FMapFacts
     FSets.FSetFacts
     FSets.FSetInterface
     FSets.FMapAVL
     FSets.FSetAVL
     Structures.OrdersEx
     Structures.OrdersAlt
     Lists.List
     Strings.String
     Bool.Bool
     Numbers.Natural.Abstract.NProperties
     PArith.BinPos
     Structures.Equalities
     Strings.Ascii
     extraction.ExtrHaskellString
     extraction.ExtrHaskellNatInteger
     extraction.ExtrHaskellNatNum
     Arith.PeanoNat.

(* Our custom modules *)
Require Import Nat.
Require Import Lists.
Require Import Map.

Module Database.

Record Image : Set :=
  mkImage
    {
      id : N;
      filename : string;
      timestamp : N
    }.

Definition ImageId := N.
Definition CategoryId := N.
Definition Index := S.t.

Record ImageDb : Type :=
  mkImageDb
    {
      images : M.t Image;
      indices : M.t Index;
      next_id : ImageId
    }.

(* Main datatype operations *)
Definition newDb := {|
  images := M.empty Image;
  indices := M.empty Index;
  next_id := N.zero
                   |}.
Definition create_image (db : ImageDb) (img : Image) :=
  let newImg := {|
        id := next_id db;
        filename := filename img;
        timestamp := timestamp img
      |}
  in {|
    images := M.add (next_id db) newImg (images db);
    indices := indices db;
    next_id := N.succ (next_id db)
  |}.

Fixpoint find_category_ids (db : ImageDb) (cat : CategoryId) : Index :=
  match M.find cat (indices db) with
  | None => S.empty
  | Some xs => xs
  end.

(* Compute find_category_ids newDb N.zero. *)

Fixpoint set_from_list (xs : list N) : Index := fold_right S.add S.empty xs.
Fixpoint list_from_set (xs : Index) : list N := S.fold cons xs nil.

Fixpoint find_categories_ids (db : ImageDb) (categories : list CategoryId) : Index :=
  match categories with
  | nil => set_from_list (map fst (M.elements (images db)))
  | cons cat cats => S.inter (find_category_ids db cat) (find_categories_ids db cats)
  end.

Fixpoint find_imgs (db : ImageDb) (imgs : list ImageId) :=
  match imgs with
  | nil => nil
  | cons i is =>
    match M.find i (images db) with
    | None => find_imgs db is
    | Some img => cons img (find_imgs db is)
    end
  end.

Fixpoint find_img (db : ImageDb) (img : ImageId) : option Image := M.find img (images db).

Fixpoint find_categories (db : ImageDb) (categories : list CategoryId) : list Image :=
  find_imgs db (list_from_set (find_categories_ids db categories)).

Fixpoint delete_image (db : ImageDb) (img : ImageId) : ImageDb :=
  {|
    images  := M.remove img (images db);
    indices := M.map (S.remove img) (indices db);
    next_id := next_id db
  |}.

Fixpoint tag_image (db: ImageDb) (img : ImageId) (cat : CategoryId) : ImageDb :=
  let idxs :=
      match M.find cat (indices db) with
      | None => M.add cat (S.singleton img) (indices db)
      | Some idx => M.add cat (S.add img idx) (indices db)
      end
  in {|
    images  := images db;
    indices := idxs;
    next_id := next_id db
  |}.

Fixpoint untag_image (db : ImageDb) (img : ImageId) (cat : CategoryId) : ImageDb :=
  let idxs :=
      match M.find cat (indices db) with
      | None => indices db
      | Some idx => M.add cat (S.remove img idx) (indices db)
      end
  in {|
    images  := images db;
    indices := idxs;
    next_id := next_id db
  |}.

(* Useful helper functions *)
Definition num_images (db : ImageDb) := M.cardinal (images db).
Definition mem_image (db : ImageDb) (img : ImageId) := M.mem img (images db).

(* Invariants *)
Theorem count_empty_db : num_images newDb = 0.
Proof.
  compute.
  tauto.
Qed.

Definition InternallyConsistent (db : ImageDb) :=
  forall (some_id : ImageId),
    M.In some_id (images db) -> N.lt some_id (next_id db).

Lemma lt_zero : forall (n : N), N.lt n N.zero -> False.
Proof.
  induction n.
  compute. intro. discriminate.
  compute. intro. discriminate.
Qed.

Theorem preserves_consistency_1 : (InternallyConsistent newDb).
Proof.
  intro.
  intro.
  rewrite MF.empty_in_iff in H.
  contradiction.
Qed.

Theorem preserves_consistency_2 :
  forall (db : ImageDb) (img : Image),
    InternallyConsistent db -> InternallyConsistent (create_image db img).
Proof.
  intros.
  intro.
  intro.
  simpl.
  apply N.lt_succ_r.
  simpl in H0.
  apply MF.add_in_iff in H0.
  destruct H0.
  apply N.le_lteq.
  right.
  symmetry. apply H0.
  apply H in H0.
  apply N.le_lteq.
  left.
  apply H0.
Qed.

Theorem preserves_consistency_3 :
  forall (db : ImageDb) (img : ImageId),
    InternallyConsistent db -> InternallyConsistent (delete_image db img).
Proof.
  intros.
  intro.
  intro.
  destruct db.
  unfold delete_image in H0.
  unfold next_id in H0.
  unfold images in H0.

  unfold delete_image.
  unfold next_id.
  unfold InternallyConsistent in H.
  apply MP.F.remove_in_iff in H0.
  destruct H0.
  specialize (H some_id H1).
  unfold next_id in H.
  apply H.
Qed.

Theorem preserves_consistency_4 :
  forall (db : ImageDb) (img : ImageId) (cat : CategoryId),
    InternallyConsistent db -> InternallyConsistent (tag_image db img cat).
Proof.
  intros.
  destruct db.
  intro.
  intro.
  unfold tag_image.
  unfold next_id.

  unfold InternallyConsistent in H.
  specialize (H some_id H0).
  unfold next_id in H.
  apply H.
Qed.

Theorem preserves_consistency_5 :
  forall (db : ImageDb) (img : ImageId) (cat : CategoryId),
    InternallyConsistent db -> InternallyConsistent (untag_image db img cat).
Proof.
  intros.
  destruct db.
  intro. intro.
  unfold untag_image.
  unfold next_id.
  unfold untag_image in H0.
  unfold next_id in H0.
  unfold InternallyConsistent in H.
  specialize (H some_id H0).
  unfold next_id in H.
  apply H.
Qed.

Lemma next_id_nin :
  forall (db : ImageDb),
    InternallyConsistent db -> ~ (M.In (next_id db) (images db)).
Proof.
  intros.
  intro.
  apply H in H0.
  apply N.ltb_nlt in H0.
  apply H0.
  apply N.ltb_irrefl.
Qed.

Lemma consistent_adds_cardinal :
  forall (db : ImageDb),
    InternallyConsistent db -> add_diff_cardinal Image (next_id db) (images db) = 1.
Proof.
  intros.
  unfold add_diff_cardinal.
  assert (M.find (next_id db) (images db) = None).
  apply MF.not_find_in_iff.
  apply next_id_nin.
  apply H.
  rewrite H0. tauto.
Qed.

Theorem size_increases :
  forall (db : ImageDb) (img : Image),
    InternallyConsistent db -> (num_images (create_image db img) = num_images db + 1).
Proof.
  intros.
  unfold create_image.
  unfold num_images.
  unfold images.
  rewrite add_inc_cardinal.
  rewrite l_sub.
  apply consistent_adds_cardinal.
  apply H.
Qed.

Lemma num_images_1 :
  forall (db : ImageDb) (img : ImageId),
    num_images (delete_image db img) = M.cardinal (M.remove img (images db)).
Proof.
  intros.
  destruct db.
  unfold delete_image.
  unfold num_images.

  unfold images.
  tauto.
Qed.

Theorem size_decreases : forall (db : ImageDb) (img : ImageId),
    (Is_true (mem_image db img) /\ S (num_images (delete_image db img)) = num_images db) \/
    (~ Is_true (mem_image db img) /\ num_images (delete_image db img) = num_images db).
Proof.
  intros.
  case (MF.In_dec (images db) img).
  intros.
  left.
  unfold mem_image.
  split.
  apply MP.F.mem_in_iff in i.
  unfold Is_true. rewrite i. tauto.

  rewrite num_images_1.
  apply cardinal_remove_1. apply i.

  intros.
  right.
  split.
  unfold mem_image.
  unfold Is_true.
  case_eq (M.mem img (images db)).
  intro.
  rewrite <- MP.F.mem_in_iff in H. contradiction.

  intro.
  rewrite <- MP.F.not_mem_in_iff in H. tauto.

  rewrite num_images_1.
  apply cardinal_bijection.
  intros.
  split.
  intro.
  apply MF.remove_in_iff in H.
  destruct H.
  apply H0.

  intro.
  case (N.eq_dec img idx).
  intros.
  rewrite e in n. contradiction.
  intro.
  assert (img <> idx /\ M.In idx (images db)).
  auto.
  rewrite <- MP.F.remove_in_iff in H0.
  apply H0.
Qed.

Theorem size_nochange : forall (db : ImageDb) (img : ImageId) (cat : CategoryId),
    num_images (tag_image db img cat) = num_images db /\
    num_images (untag_image db img cat) = num_images db.
Proof.
  intros.
  split.
  destruct db.
  unfold num_images.
  unfold tag_image.
  unfold images. tauto.

  destruct db.
  unfold num_images.
  unfold untag_image.
  unfold images. tauto.
Qed.

End Database.

(* Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] *)
(*                                        "(\f0 fS n -> if n Prelude.<= 0 then f0 () else fS ( n Prelude.- 1))". *)
Extract Inductive list    => "[]" ["[]" "(:)"].
Extract Inductive option => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extraction Language Haskell.
Extraction "Database" Database.
(* Extraction create_image. *)
(* Extraction find_categories. *)
(* Extraction delete_image. *)
(* Extraction tag_image. *)
(* Extraction untag_image. *)