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

(**********************************************************************)
(*                   Substitution.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(* adapted from Substitution.v of Project Coq  to act on SF-terms     *)
(**********************************************************************)

Require Import Arith Omega List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.SF_calculus.SF_Terms.
Require Import IntensionalLib.SF_calculus.SF_Tactics.
Require Import IntensionalLib.SF_calculus.SF_reduction.
Require Import IntensionalLib.SF_calculus.SF_Normal.
Require Import IntensionalLib.SF_calculus.SF_Closed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with
   (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Lemma relocate_null :
forall (n n0 : nat), relocate n n0 0 = n.
Proof. split_all. unfold relocate. case (test n0 n); intro; auto with arith. Qed.

Lemma relocate_lessthan : forall m n k, m<=k -> relocate k m n = (n+k).
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.
Lemma relocate_greaterthan : forall m n k, m>k -> relocate k m n = k.
Proof. split_all. unfold relocate. elim(test m k); split_all; try noway. Qed.

Ltac relocate_lt :=
try (rewrite relocate_lessthan; [| omega]; relocate_lt);
try (rewrite relocate_greaterthan; [| omega]; relocate_lt);
try(rewrite relocate_null).

Lemma relocate_zero_succ :
forall n k, relocate 0 (S n) k = 0.
Proof.  split_all. Qed.

Lemma relocate_succ :
forall n n0 k, relocate (S n) (S n0) k = S(relocate n n0 k).
Proof.
intros; unfold relocate. elim(test(S n0) (S n)); elim(test n0 n); split_all.
noway.
noway.
Qed.

Lemma relocate_mono : forall M N n k, relocate M n k = relocate N n k -> M=N.
Proof.
intros M N n k.
unfold relocate.
elim(test n M); elim(test n N); split_all; omega.
Qed.

Lemma relocate_null2 :
forall n k, relocate 0 (S n) k = 0.
Proof. split_all. Qed.

Fixpoint lift_rec (L : SF) : nat -> nat -> SF :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
   end.

Definition lift (n : nat) (N : SF) := lift_rec N 0 n.

(* Lifting lemmas *)

Lemma lift_rec_null_term :
forall (U : SF)(n: nat), lift_rec U n 0 = U.
Proof.
simple induction U; split_all.
relocate_lt; auto.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift1 :
 forall (U : SF) (j i k : nat),
 lift_rec (lift_rec U i j) (j + i) k = lift_rec U i (j + k).
Proof.
simple induction U; simpl in |- *;  split_all.
unfold relocate.
elim (test i n); elim (test (j+i) (j+ n)); split_all; try noway.
assert(k + (j + n) = j + k + n) by omega. congruence.
elim (test (j + i) n); split_all; try noway. rewrite H; auto. rewrite H0; auto.
Qed.

Lemma lift_lift_rec :
 forall (U : SF) (k p n i : nat),
 i <= n ->
 lift_rec (lift_rec U i p) (p + n) k = lift_rec (lift_rec U n k) i p.
Proof.
simple induction U; simpl in |- *;  split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i (k+n)); split_all; try noway.
assert(k+(p+n) = p+ (k+n)) by omega.
rewrite H0; auto.
elim(test (p+n0) (p+n)); split_all; try noway.
elim(test i n); split_all; try noway.
elim(test n0 n); split_all; try noway.
elim(test (p+n0) n); split_all; try noway.
elim(test i n); split_all; try noway.
(* Ap *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma lift_lift_term :
 forall (U : SF) (k p n : nat),
 lift_rec (lift p U) (p+ n) k = lift p (lift_rec U n k).
Proof.
unfold lift in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

Lemma liftrecO : forall (U : SF) (n : nat), lift_rec U n 0 = U.
Proof.
simple induction U; simpl in |- *; intros; split_all; relocate_lt; congruence.
Qed.

Lemma liftO : forall (U : SF) , lift 0 U = U.
Proof.
unfold lift in |- *; split_all; apply liftrecO.
Qed.

Lemma lift_rec_lift_rec :
 forall (U : SF) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec (lift_rec U i n) k p = lift_rec U i (p + n).

Proof.
simple induction U; split_all.
(* Ref *)
unfold relocate.
elim(test i n); split_all; try noway.
elim(test k (n0 + n)); split_all; try noway.
replace (p+(n0+n)) with (p + n0 + n) by omega. auto.
elim(test k n); split_all; try noway.
(* Ap *)
rewrite H; split_all; rewrite H0; split_all; split_all.
Qed.

Lemma lift_rec_lift :
 forall (U : SF)  (n p k i : nat),
 k <= n -> lift_rec (lift  n U)  k p = lift (p + n) U.
Proof.
unfold lift in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

Lemma lift_rec_lift2 :
forall M n k, lift_rec (lift 1 M) (S n) k = lift 1 (lift_rec M n k).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite lift_lift_rec; auto.
omega.
Qed.

Lemma lift_rec_app: forall M N n k, lift_rec (App M N) n k = App (lift_rec M n k) (lift_rec N n k).
Proof. split_all. Qed.
Lemma lift_rec_op: forall o n k, lift_rec (Op o) n k = Op o.
Proof. split_all. Qed.
Lemma lift_rec_ref: forall i n k, lift_rec (Ref i) n k = Ref (relocate i n k).
Proof. split_all. Qed.

Lemma lift_rec_not_ref_0 : forall M, lift_rec M 0 1 <> Ref 0.
Proof. induction M; split_all; try discriminate. case n; split_all; discriminate. Qed.

Lemma lift_rec_null :
forall (U : SF) (n: nat), lift_rec U n 0 = U.
Proof. simple induction U; split_all.
 rewrite relocate_null; congruence.
rewrite H; auto. rewrite H0; auto.
Qed.

Ltac  lift_tac :=
unfold_op; rewrite ? lift_rec_app; rewrite ? lift_rec_op; rewrite ? lift_rec_ref; relocate_lt;
rewrite ? lift_rec_not_ref_0.

Lemma lift_rec_preserves_compound :
forall (M: SF), compound M -> forall (n k : nat), compound(lift_rec M n k).
Proof.
intros M c; induction c; split_all.
Qed.
Hint Resolve lift_rec_preserves_compound.

Lemma lift_rec_preserves_status:
forall M n k, status (lift_rec M n k) = status M.
Proof.
match goal with
  | |- forall M, ?P  =>   cut (forall p M, p >= rank M -> P );
      [intros H M;  eapply2 H |
       intro p; induction p; intro M;  [ assert(rank M >0) by eapply2 rank_positive; noway |]
      ]
  end.

induction M; split_all.
rewrite IHM1. (* pepm 2: omega.  *)
gen_case H M1. gen_case H s. gen_case H s1. gen_case H o. eapply2 IHp; omega. omega.
Qed.

Lemma lift_rec_preserves_normal: forall M n k, normal M -> normal (lift_rec M n k).
Proof. induction M; intros. split_all. split_all.
inversion H. apply nf_active; fold lift_rec; auto.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
rewrite lift_rec_preserves_status. auto.
simpl. eapply2 nf_compound.
replace  (App (lift_rec M1 n k) (lift_rec M2 n k))
with (lift_rec (App M1 M2) n k) by auto.
eapply2 lift_rec_preserves_compound.
Qed.

Lemma lift_rec_closed: forall M n k, maxvar M = 0 -> lift_rec M n k = M.
Proof. induction M; split_all. omega. max_out. rewrite IHM1; auto;  rewrite IHM2; auto. Qed.

Lemma map_lift0 : forall Ms, map (lift 0) Ms = Ms.
Proof. induction Ms; split_all.   rewrite IHMs. unfold lift; rewrite lift_rec_null. auto. Qed.

Lemma lift_preserves_maxvar2:
  forall M, forall k, maxvar (lift k M) - k = maxvar M.
Proof.
  induction M; split_all. relocate_lt. induction k; split_all.
  rewrite max_minus. unfold lift in *; rewrite IHM1; rewrite IHM2; auto.
Qed.

Lemma lift_rec_reflects_compound : forall M n k, compound (lift_rec M n k) -> compound M.
Proof.
induction M; split_all; inversion H; subst; split_all.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 s; try discriminate. subst; auto.
inversion H2; subst; auto.
gen_case H1 M1; try discriminate.  invsub.
gen_case H1 M1; try discriminate. inversion H1.
gen_case H2 s; try discriminate. subst; auto.
inversion H2; subst; auto.
Qed.

Lemma lift_rec_reflects_normal : forall M n k, normal (lift_rec M n k) -> normal M.
Proof.
induction M; split_all. inversion H; split_all.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
rewrite lift_rec_preserves_status in *. eapply2 nf_active.
replace (App (lift_rec M1 n k) (lift_rec M2 n k)) with (lift_rec (App M1 M2) n k) in H4 by auto.
eapply2 nf_compound. eapply2 lift_rec_reflects_compound.
Qed.

(* Substitution *)

Definition insert_Ref (N : SF) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : SF) : SF -> nat -> SF :=
  fun (N : SF) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  end.

Lemma subst_rec_op:
forall o N k, subst_rec (Op o) N k = Op o.
Proof.  split_all. Qed.

Lemma subst_rec_app:
forall M1 M2 N k, subst_rec (App M1 M2) N k = App (subst_rec M1 N k) (subst_rec M2 N k).
Proof.  split_all. Qed.

Lemma subst_rec_ref: forall i N k,  subst_rec (Ref i) N k = insert_Ref N i k.
Proof.  split_all. Qed.

Definition subst (M N : SF) := subst_rec M N 0.

(* The three cases of substitution of U for (Ref n) *)

Lemma subst_eq :
 forall (M U : SF) (n : nat), subst_rec (Ref n) U n = lift n U.
Proof.
simpl in |- *; unfold insert_Ref in |- *; split_all.
elim (compare n n); intro P; try noway.
elim P; intro Q; simpl in |- *; trivial with arith; try noway.
Qed.

Lemma subst_gt :
 forall (M U : SF) (n p : nat),
 n > p -> subst_rec (Ref n) U p = Ref (pred n).
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (M U : SF) (n p : nat), p > n -> subst_rec (Ref n) U p = Ref n.
Proof.
simpl in |- *; unfold insert_Ref in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : SF) (k p n : nat),
 lift_rec (subst_rec V U p) (p + n) k =
 subst_rec (lift_rec V (S (p + n)) k) (lift_rec U n k) p.
Proof.
simple induction V; split_all.
(* 1 Ref *)
unfold insert_Ref, relocate in |- *.
elim (test (S(p + n0)) n); elim (compare p n); split_all.
elim a; elim(compare p (k+n)); split_all.
unfold relocate.
elim(test (p+n0) (pred n)); elim a1; split_all; try noway.
replace (k + pred n) with (pred (k + n)) by omega; auto.
noway.
noway.
noway.
noway.
elim a; split_all.
unfold relocate. elim(test(p+n0) (pred n)); split_all.
noway.
unfold lift.
rewrite lift_lift_rec; auto; omega.
unfold relocate.
elim(test (p+n0) n); split_all.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

Lemma lift_subst :
 forall (U V : SF) (k n : nat),
 lift_rec (subst U V) n k =
 subst (lift_rec U (S n) k) (lift_rec V n k).
Proof.
unfold subst in |- *; intros.
replace n with (0 + n).
rewrite lift_rec_subst_rec; trivial with arith.
auto.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : SF) (n p k : nat),
 k <= n ->
 subst_rec (lift_rec U k p) V (p + n) =
 lift_rec (subst_rec U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Ref *)
unfold insert_Ref, relocate.
elim(test k n); split_all.
elim(compare n0 n); split_all; try noway.
elim a0; split_all; try noway.
elim(compare (p+n0) (p+n)); split_all.
elim a2; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega. auto.
noway.
elim(compare (p+n0) (p+n)); split_all.
elim a1; split_all; try noway.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
unfold lift. rewrite lift_rec_lift_rec; split_all; try omega.
elim(compare (p+n0) (p+n)); split_all.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.
(* 1 *)
rewrite H; split_all.  rewrite H0; split_all.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : SF) (n p : nat),
 subst_rec (lift p U) V (p + n) = lift p (subst_rec U V n).
Proof.
unfold lift in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : SF) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec (lift_rec U n (S p)) V q = lift_rec U n p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
unfold relocate. elim(test n0 n); split_all.
unfold insert_Ref.
elim(compare q (S(p+n))); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare q n); split_all; try noway.
elim a; split_all; try noway.

(* 1 *)
rewrite H; split_all.
rewrite H0; auto.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : SF) (n p : nat),
 subst_rec (subst_rec V U p) W (p + n) =
 subst_rec (subst_rec V W (S (p + n))) (subst_rec U W n) p.
Proof.
simple induction V;  split_all.

unfold insert_Ref in |- *.
elim (compare p n); split_all.
elim a; split_all.
elim (compare (S (p + n0)) n); split_all.
elim a1; split_all; try noway.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a3; split_all; try noway.
elim (compare p (pred n)); split_all; try noway.
elim a5; split_all; try noway.
unfold lift; split_all.
unfold insert_Ref.
elim (compare (p+n0) (pred n)); split_all; try noway.
elim a2; split_all; try noway.
subst. unfold lift.
rewrite subst_rec_lift_rec; split_all; try omega.
unfold insert_Ref.
elim(compare (p+n0) (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a1; split_all; try noway.
elim (compare (S (p + n0)) n); split_all; try noway.
elim a0; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a0; split_all; try noway.
unfold lift.
subst.
rewrite subst_rec_lift_rec1; split_all.  omega.

unfold insert_Ref.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Ref.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
rewrite H; auto. rewrite H0; auto.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : SF) (n : nat),
 subst_rec (subst_rec V U 0) W n =
 subst_rec (subst_rec V W (S n)) (subst_rec U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n) by trivial with arith.
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : SF) (n : nat),
 subst_rec (subst U V) W n =
 subst (subst_rec U W (S n)) (subst_rec V W n).
Proof.
unfold subst in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* to show (\ t)0 -> t  *)

Lemma subst_lift_null :
forall (W V : SF)(n : nat), subst_rec (lift_rec W n 1) V n = W.
Proof.
simple induction W; split_all.
unfold insert_Ref.
unfold relocate.
elim(test n0 n); split_all.
elim(compare n0 (S n)); split_all.
elim a0; split_all; noway.
noway.
elim(compare n0 n); split_all.
elim a; split_all. noway.
noway.
rewrite H; auto; rewrite H0; auto.
Qed.

(* more  Properties *)

Lemma subst_rec_lift2 :
forall M N n , subst_rec (lift 1 M) N (S n)  = lift 1 (subst_rec M N n).
Proof.
split_all.
unfold lift.
replace (S n) with (1+n) by omega.
rewrite subst_rec_lift_rec1; auto.
omega.
Qed.

Lemma insert_Ref_lt : forall M n k, n< k -> insert_Ref M n k = Ref n.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
Qed.

Lemma insert_Ref_eq : forall M n k, n= k -> insert_Ref M n k = lift k M.
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
unfold lift; unfold lift_rec. unfold relocate. elim(test 0 n); split_all; try noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Lemma insert_Ref_gt : forall M n k, n> k -> insert_Ref M n k = Ref (pred n).
Proof.
induction M; unfold insert_Ref; split_all.
elim (compare k n0); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
elim (compare k n); split_all.
elim a; split_all; try noway.
noway.
Qed.

Ltac insert_Ref_out :=
try (rewrite insert_Ref_lt; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_eq; [|unfold relocate; split_all; omega]; insert_Ref_out);
try (rewrite insert_Ref_gt; [|unfold relocate; split_all; omega]; insert_Ref_out).

Lemma fold_subst :  forall M1 M2 N, App (subst_rec M1 N 0) M2 = subst (App M1 (lift 1 M2)) N.
Proof.
  unfold subst, lift, subst_rec; split_all; fold subst_rec.
  rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
Qed.

Ltac  subst_tac :=
unfold_op; unfold subst;
rewrite ? subst_rec_app; rewrite ? subst_rec_op; rewrite ? subst_rec_ref;
rewrite ? subst_rec_lift_rec; try omega; rewrite ? lift_rec_null;
unfold subst_rec; fold subst_rec; insert_Ref_out; unfold pred.

Definition subst_preserves_l (red: termred) :=
forall (M M' N : SF), red M M' -> red  (subst M N) (subst M' N).

Definition subst_preserves_r (red: termred) :=
forall (M N N' : SF), red N N' -> red  (subst M N) (subst M N').

Definition subst_preserves (red: termred) :=
forall (M M' : SF), red M M' -> forall N N', red N N' ->
red  (subst M N) (subst M' N').

Lemma subst_preserves_l_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_l (multi_step red).
Proof. unfold subst_preserves_l.
 induction 2; split_all.
apply succ_red with (subst N0 N); auto.
Qed.

Lemma subst_preserves_r_multi_step :
forall (red: termred), subst_preserves_r red -> subst_preserves_r (multi_step red).
Proof. unfold subst_preserves_r.
 induction 2; split_all.
apply succ_red with (subst M N); auto.
Qed.

Lemma subst_preserves_multi_step :
forall (red: termred), subst_preserves_l red -> subst_preserves_r red -> subst_preserves (multi_step red).
Proof.
unfold subst_preserves. split_all.
assert(transitive (multi_step red)) by eapply2 transitive_red.
unfold transitive in *.
apply X with  (subst M' N); auto.
eapply2 subst_preserves_l_multi_step.
eapply2 subst_preserves_r_multi_step.
Qed.

Lemma subst_preserves_compound:
forall (M: SF), compound M -> forall N, compound(subst M N).
Proof. intros M c; induction c; unfold subst; split_all. Qed.
Hint Resolve subst_preserves_compound.

Lemma  subst_rec_preserves_components_l : forall (M : SF) n k, compound M ->
  subst_rec(left_component M) n k = left_component(subst_rec M n k).
Proof. induction M; split_all; inv1 compound. Qed.

Lemma  subst_rec_preserves_components_r :
forall (M : SF),  compound M -> forall n k,
subst_rec(right_component M) n k = right_component(subst_rec M n k).
Proof. induction M; split_all; inversion H; subst; split_all. Qed.
Lemma subst_rec_preserves_compounds:
forall M N k, compound M -> compound (subst_rec M N k).
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_left_component:
forall M N k, compound M ->
              subst_rec (left_component M) N k = left_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_rec_preserves_right_component:
forall M N k, compound M ->
              subst_rec (right_component M) N k = right_component (subst_rec M N k) .
Proof. intros; inv1 compound. Qed.

Lemma subst_preserves_sf_red1 : subst_preserves sf_red1.
Proof.
red.
intros M M' R; induction R; unfold subst; split_all.
(* 11 *)
unfold insert_Ref. elim(compare 0 i); split_all. elim a; split_all.
unfold lift. repeat rewrite lift_rec_null_term; auto.
(* 10 *)
eapply2 app_sf_red.
(* 9 *)
eapply2 s_red.
(* 8 *)
eapply2 f_op_red.
(* 7 *)
assert(compound P') by eapply2 preserves_compound_sf_red1.
rewrite subst_rec_preserves_components_l; split_all.
rewrite subst_rec_preserves_components_r; split_all.
eapply2 f_compound_red.
eapply2 subst_preserves_compound.
Qed.

Lemma subst_preserves_sf_red : subst_preserves sf_red.
Proof. eapply2 subst_preserves_multi_step. red; split_all.
eapply2 subst_preserves_sf_red1. red; split_all.
eapply2 subst_preserves_sf_red1.
Qed.

Lemma subst_rec_closed: forall M N k, maxvar M <= k -> subst_rec M N k = M.
Proof.
induction M; split_all.
unfold insert_Ref. elim(compare k n); split_all. elim a; split_all. noway. noway.
assert (max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert (max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega;  rewrite IHM2; try omega. auto.
Qed.

Lemma subst_decreases_maxvar :
forall M N,  max (pred (maxvar M)) (maxvar N) >= maxvar(subst M N).
Proof.
unfold subst; induction M; split_all.
unfold insert_Ref.
case n; split_all. unfold lift. rewrite lift_rec_null_term. auto.
case (maxvar N); split_all.
assert(max n0 n1  >= n0) by eapply2 max_is_max.
omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M1)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max (pred (maxvar M2)) (maxvar N)).
eapply2 max_monotonic. eapply2 max_is_max.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N) >=
max(max (pred (maxvar M1)) (maxvar N)) (max (pred (maxvar M2)) (maxvar N))).
eapply2 max_max2.
assert(max (max (pred (maxvar M1)) (maxvar N))
         (max (pred (maxvar M2)) (maxvar N))>=
max (maxvar (subst_rec M1 N 0)) (maxvar (subst_rec M2 N 0))).
eapply2 max_monotonic.
omega.
Qed.

Lemma subst_closed : forall M, maxvar M = 0 -> forall N, subst M N = M.
Proof.
induction M; split_all; subst. omega.
max_out. unfold subst in *; simpl. rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M := repeat (rewrite (subst_rec_closed M); [| auto]);
                     repeat (rewrite (lift_rec_closed M); [| auto]).

Lemma fold_subst_list:
  forall sigma M N,  App (fold_left subst sigma M) N =
                     fold_left subst sigma (App M (lift (length sigma) N)).
Proof.
  induction sigma; split_all.
  (* 2 *)
  unfold lift; rewrite lift_rec_null. auto.
  (* 1 *)
  rewrite IHsigma. unfold subst. simpl. unfold lift. rewrite subst_rec_lift_rec; try omega. auto.
Qed.

Lemma list_subst_preserves_op:
  forall sigma o, fold_left subst sigma (Op o) = Op o.
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_app:
  forall sigma M N, fold_left subst sigma (App M N) =
                    App (fold_left subst sigma M) (fold_left subst sigma N).
  Proof. induction sigma; split_all. unfold subst in *. split_all. Qed.

Lemma list_subst_preserves_sf_red:
  forall sigma M N, sf_red M N -> sf_red (fold_left subst sigma M) (fold_left subst sigma N).
Proof.  induction sigma; split_all. eapply2 IHsigma. eapply2 subst_preserves_sf_red. Qed.

Lemma list_subst_lift: forall sigma M, fold_left subst sigma (lift (length sigma) M) = M.
Proof.
  induction sigma; split_all. unfold lift; rewrite lift_rec_null. auto.
unfold lift, subst. rewrite subst_rec_lift_rec; try omega. unfold lift in *. rewrite IHsigma. auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2018-2019 Guillaume Bertholon
#
#
Copyright (C) 2018-2019 Érik Martin-Dorel
#
#
Copyright (C) 2018-2019 Pierre Roux

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Interface Flocq with Coq (>= 8.11) primitive floating-point numbers. *)

From Coq Require Import ZArith Reals Floats SpecFloat.
Require Import Zaux BinarySingleNaN.

(** Conversions from/to Flocq binary_float *)

Definition Prim2B (x : float) : binary_float prec emax :=
  SF2B (Prim2SF x) (Prim2SF_valid x).

Definition B2Prim (x : binary_float prec emax) : float :=
  SF2Prim (B2SF x).

Lemma B2Prim_Prim2B : forall x, B2Prim (Prim2B x) = x.
Proof.
intros x.
unfold Prim2B, B2Prim.
now rewrite B2SF_SF2B, SF2Prim_Prim2SF.
Qed.

Lemma Prim2B_B2Prim : forall x, Prim2B (B2Prim x) = x.
Proof.
intro x.
unfold Prim2B, B2Prim.
apply B2SF_inj.
rewrite B2SF_SF2B.
apply Prim2SF_SF2Prim.
apply valid_binary_B2SF.
Qed.

Lemma Prim2B_inj : forall x y, Prim2B x = Prim2B y -> x = y.
Proof.
intros x y Heq.
generalize (f_equal B2Prim Heq).
now rewrite 2!B2Prim_Prim2B.
Qed.

Lemma B2Prim_inj : forall x y, B2Prim x = B2Prim y -> x = y.
Proof.
intros x y Heq.
generalize (f_equal Prim2B Heq).
now rewrite 2!Prim2B_B2Prim.
Qed.

Lemma B2SF_Prim2B : forall x, B2SF (Prim2B x) = Prim2SF x.
Proof.
intros x.
apply SF2Prim_inj.
- rewrite SF2Prim_Prim2SF.
  apply B2Prim_Prim2B.
- apply valid_binary_B2SF.
- apply Prim2SF_valid.
Qed.

Lemma Prim2SF_B2Prim : forall x, Prim2SF (B2Prim x) = B2SF x.
Proof.
intro x; unfold B2Prim.
now rewrite Prim2SF_SF2Prim; [|apply valid_binary_B2SF].
Qed.

(** Basic properties of the Binary64 format *)

Local Instance Hprec : FLX.Prec_gt_0 prec := eq_refl _.

Local Instance Hmax : Prec_lt_emax prec emax := eq_refl _.

(** Equivalence between prim_float and Flocq binary_float operations *)

Theorem opp_equiv : forall x, Prim2B (- x) = Bopp (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite opp_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx].
Qed.

Theorem abs_equiv : forall x, Prim2B (abs x) = Babs (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite abs_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx].
Qed.

Theorem compare_equiv :
  forall x y,
  (x ?= y)%float = flatten_cmp_opt (Bcompare (Prim2B x) (Prim2B y)).
Proof.
intros x y.
rewrite compare_spec.
rewrite <-!B2SF_Prim2B.
now case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By].
Qed.

Lemma round_nearest_even_equiv s m l :
  round_nearest_even m l = choice_mode mode_NE s m l.
Proof.
case l; [reflexivity|intro c].
case c; [|reflexivity..].
now simpl; unfold Round.cond_incr; case Z.even.
Qed.

Lemma binary_round_aux_equiv sx mx ex lx :
  SpecFloat.binary_round_aux prec emax sx mx ex lx
  = binary_round_aux prec emax mode_NE sx mx ex lx.
Proof.
unfold SpecFloat.binary_round_aux, binary_round_aux.
set (mrse' := shr_fexp _ _ _).
case mrse'; intros mrs' e'; simpl.
now rewrite (round_nearest_even_equiv sx).
Qed.

Theorem mul_equiv :
  forall x y,
  Prim2B (x * y) = Bmult mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite mul_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_aux_equiv.
Qed.

Lemma binary_round_equiv s m e :
  SpecFloat.binary_round prec emax s m e =
  binary_round prec emax mode_NE s m e.
Proof.
unfold SpecFloat.binary_round, binary_round, shl_align_fexp.
set (mez := shl_align _ _ _); case mez as [mz ez].
apply binary_round_aux_equiv.
Qed.

Lemma binary_normalize_equiv m e szero :
  SpecFloat.binary_normalize prec emax m e szero
  = B2SF (binary_normalize prec emax Hprec Hmax mode_NE m e szero).
Proof.
case m as [|p|p].
- now simpl.
- simpl; rewrite B2SF_SF2B; apply binary_round_equiv.
- simpl; rewrite B2SF_SF2B; apply binary_round_equiv.
Qed.

Theorem add_equiv :
  forall x y,
  Prim2B (x + y) = Bplus mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite add_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
apply binary_normalize_equiv.
Qed.

Theorem sub_equiv :
  forall x y,
  Prim2B (x - y) = Bminus mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite sub_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
apply binary_normalize_equiv.
Qed.

Theorem div_equiv :
  forall x y,
  Prim2B (x / y) = Bdiv mode_NE (Prim2B x) (Prim2B y).
Proof.
intros x y.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite div_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx];
  case (Prim2B y) as [sy|sy| |sy my ey By];
  [now (trivial || simpl; case Bool.eqb)..|].
simpl.
rewrite B2SF_SF2B.
set (melz := SFdiv_core_binary _ _ _ _ _ _).
case melz as [[mz ez] lz].
apply binary_round_aux_equiv.
Qed.

Theorem sqrt_equiv :
  forall x, Prim2B (sqrt x) = Bsqrt mode_NE (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite sqrt_spec.
rewrite <-B2SF_Prim2B.
case Prim2B as [sx|sx| |sx mx ex Bx]; [now (trivial || case sx)..|].
case sx; [reflexivity|].
simpl.
rewrite B2SF_SF2B.
set (melz := SFsqrt_core_binary _ _ _ _).
case melz as [[mz ez] lz].
apply binary_round_aux_equiv.
Qed.

Theorem normfr_mantissa_equiv :
  forall x,
  Int63.to_Z (normfr_mantissa x) = Z.of_N (Bnormfr_mantissa (Prim2B x)).
Proof.
intro x.
rewrite normfr_mantissa_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B.
Qed.

Theorem ldexp_equiv :
  forall x e,
  Prim2B (ldexp x e) = Bldexp mode_NE (Prim2B x) e.
Proof.
intros x e.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite ldexp_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_equiv.
Qed.

Theorem ldshiftexp_equiv :
  forall x e,
  Prim2B (ldshiftexp x e) = Bldexp mode_NE (Prim2B x) (Int63.to_Z e - shift).
Proof.
intros x e.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite ldshiftexp_spec.
rewrite <-!B2SF_Prim2B.
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; [now trivial..|].
simpl.
rewrite B2SF_SF2B.
apply binary_round_equiv.
Qed.

Theorem frexp_equiv :
  forall x : float,
  let (m, e) := frexp x in
  (Prim2B m, e) = Bfrexp (Prim2B x).
Proof.
intro x.
generalize (frexp_spec x).
destruct frexp as [f e].
rewrite <-(B2SF_Prim2B x).
replace (SFfrexp _ _ _)
  with (let (f, e) := Bfrexp (Prim2B x) in
        (B2SF f, e)).
- case Bfrexp; intros f' e' [= H ->]; f_equal.
  now apply B2SF_inj; rewrite B2SF_Prim2B.
- case (Prim2B x) as [s|s| |s m e' Hme] ; try easy.
  simpl.
  rewrite B2SF_SF2B.
  unfold Ffrexp_core_binary.
  change (digits2_pos m) with (Digits.digits2_pos m).
  now destruct Pos.leb.
Qed.

Theorem frshiftexp_equiv :
  forall x : float,
  let (m, e) := frshiftexp x in
  (Prim2B m, (Int63.to_Z e - shift)%Z) = Bfrexp (Prim2B x).
Proof.
intro x.
generalize (frexp_equiv x).
unfold frexp.
now case frshiftexp.
Qed.

Theorem infinity_equiv : infinity = B2Prim (B754_infinity false).
Proof. now compute. Qed.

Theorem neg_infinity_equiv : neg_infinity = B2Prim (B754_infinity true).
Proof. now compute. Qed.

Theorem nan_equiv : nan = B2Prim B754_nan.
Proof. now compute. Qed.

Theorem zero_equiv : zero = B2Prim (B754_zero false).
Proof. now compute. Qed.

Theorem neg_zero_equiv : neg_zero = B2Prim (B754_zero true).
Proof. now compute. Qed.

Theorem one_equiv : one = B2Prim Bone.
Proof. now compute. Qed.

Theorem two_equiv : two = B2Prim (Bplus mode_NE Bone Bone).
Proof. now compute. Qed.

Theorem ulp_equiv :
  forall x, Prim2B (ulp x) = Bulp' (Prim2B x).
Proof.
intro x.
unfold ulp, Bulp'.
rewrite one_equiv, ldexp_equiv, Prim2B_B2Prim.
generalize (frexp_equiv x).
case frexp; intros f e.
destruct Bfrexp as [f' e'].
now intros [= _ <-].
Qed.

Theorem next_up_equiv :
  forall x, Prim2B (next_up x) = Bsucc (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite next_up_spec.
rewrite <-B2SF_Prim2B.
assert (Hsndfrexp : forall x : binary_float prec emax, snd (SFfrexp prec emax (B2SF x)) = snd (Bfrexp x)).
{ intro x'.
  generalize (frexp_spec (B2Prim x')).
  generalize (frexp_equiv (B2Prim x')).
  case frexp; intros f' e'.
  rewrite Prim2B_B2Prim, Prim2SF_B2Prim.
  intros H H'; generalize (f_equal snd H'); generalize (f_equal snd H); simpl.
  now intros ->. }
assert (Hldexp : forall x e, SFldexp prec emax (B2SF x) e = B2SF (Bldexp mode_NE x e)).
{ intros x' e'.
  rewrite <-(Prim2B_B2Prim x'), B2SF_Prim2B, <-ldexp_spec.
  now rewrite <-B2SF_Prim2B, ldexp_equiv. }
assert (Hulp : forall x, SFulp prec emax (B2SF x) = B2SF (Bulp' x)).
{ intro x'.
  unfold SFulp, Bulp'.
  now rewrite Hsndfrexp, <-Hldexp. }
assert (Hpred_pos : forall x, (0 < B2R x)%R -> SFpred_pos prec emax (B2SF x) = B2SF (Bpred_pos' x)).
{ intros x' Fx'.
  unfold SFpred_pos, Bpred_pos'.
  rewrite Hsndfrexp.
  set (fe := fexp _ _ _).
  change (SFone _ _) with (B2SF Bone).
  rewrite Hldexp, Hulp.
  case x' as [sx|sx| |sx mx ex Bx]; try easy.
  unfold B2SF at 1.
  set (y := Bldexp _ _ _).
  set (z := Bulp' _).
  case Pos.eqb.
  - rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
    rewrite <-(Prim2B_B2Prim y).
    now rewrite <-sub_equiv, !B2SF_Prim2B, sub_spec.
  - rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
    rewrite <-(Prim2B_B2Prim z).
    now rewrite <-sub_equiv, !B2SF_Prim2B, sub_spec. }
case Prim2B as [sx|sx| |sx mx ex Bx]; [reflexivity|now case sx|reflexivity|].
rewrite <- Bsucc'_correct by easy.
unfold SF64succ, SFsucc, B2SF at 1, Bsucc'.
case sx.
- unfold B2SF at 1, SFopp at 2.
  rewrite <-(Prim2B_B2Prim (Bpred_pos' _)).
  rewrite <- opp_equiv, B2SF_Prim2B, opp_spec, Prim2SF_B2Prim.
  rewrite <- Hpred_pos.
  easy.
  now apply Float_prop.F2R_gt_0.
- rewrite Hulp.
  rewrite Bulp'_correct by easy.
  rewrite <-(Prim2B_B2Prim (B754_finite _ _ _ _)).
  rewrite <-(Prim2B_B2Prim (Bulp _)).
  rewrite <-add_equiv, !B2SF_Prim2B, add_spec, !Prim2SF_B2Prim.
  now unfold SF64add.
Qed.

Theorem next_down_equiv :
  forall x, Prim2B (next_down x) = Bpred (Prim2B x).
Proof.
intro x.
apply B2Prim_inj.
rewrite B2Prim_Prim2B.
apply Prim2SF_inj.
rewrite Prim2SF_B2Prim.
rewrite next_down_spec.
rewrite <-B2SF_Prim2B.
unfold Bpred.
rewrite <-(Prim2B_B2Prim (Bopp (Prim2B x))).
rewrite <-next_up_equiv, <-opp_equiv, !B2SF_Prim2B, opp_spec, next_up_spec.
unfold SF64pred, SFpred, SF64succ.
do 2 f_equal.
now rewrite <-opp_equiv, B2Prim_Prim2B, opp_spec.
Qed.

Theorem is_nan_equiv :
  forall x, PrimFloat.is_nan x = is_nan (Prim2B x).
Proof.
intro x.
unfold PrimFloat.is_nan.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
case Prim2B as [sx|sx| |sx mx ex Bx]; [reflexivity|now case sx|reflexivity| ].
simpl.
rewrite Bool.negb_false_iff.
unfold SFeqb, SFcompare.
rewrite Z.compare_refl, Pos.compare_refl.
now case sx.
Qed.

Theorem is_zero_equiv :
  forall x,
  is_zero x = match Prim2B x with B754_zero _ => true | _ => false end.
Proof.
intro x.
unfold is_zero.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B as [sx|sx| |sx mx ex Bx]; try reflexivity; case sx.
Qed.

Theorem is_infinity_equiv :
  forall x,
  is_infinity x = match Prim2B x with B754_infinity _ => true | _ => false end.
Proof.
intro x.
unfold is_infinity.
rewrite eqb_spec.
rewrite <-B2SF_Prim2B.
rewrite B2SF_Prim2B, abs_spec.
rewrite <-B2SF_Prim2B.
now case Prim2B.
Qed.

Theorem get_sign_equiv : forall x, get_sign x = Bsign (Prim2B x).
Proof.
intro x.
unfold get_sign.
rewrite is_zero_equiv.
rewrite ltb_spec.
rewrite <-(B2Prim_Prim2B x).
case (Prim2B x) as [sx|sx| |sx mx ex Bx]; rewrite Prim2B_B2Prim.
- now rewrite div_spec; case sx.
- now case sx.
- now simpl.
- now rewrite Prim2SF_B2Prim; case sx.
Qed.

Theorem is_finite_equiv :
  forall x, PrimFloat.is_finite x = is_finite (Prim2B x).
Proof.
intro x.
unfold PrimFloat.is_finite.
rewrite is_nan_equiv, is_infinity_equiv.
now case (Prim2B x) as [sx|sx| |sx mx ex Bx].
Qed.

Theorem of_int63_equiv :
  forall i,
  Prim2B (of_int63 i)
  = binary_normalize prec emax Hprec Hmax mode_NE (Int63.to_Z i) 0 false.
Proof.
intro i.
apply B2SF_inj.
rewrite B2SF_Prim2B.
rewrite of_int63_spec.
apply binary_normalize_equiv.
Qed.

Theorem eqb_equiv :
  forall x y,
  (x == y)%float = Beqb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite eqb_spec.
unfold Beqb.
now rewrite !B2SF_Prim2B.
Qed.

Theorem ltb_equiv :
  forall x y,
  (x < y)%float = Bltb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite ltb_spec.
unfold Bltb.
now rewrite !B2SF_Prim2B.
Qed.

Theorem leb_equiv :
  forall x y,
  (x <= y)%float = Bleb (Prim2B x) (Prim2B y).
Proof.
intros x y.
rewrite leb_spec.
unfold Bleb.
now rewrite !B2SF_Prim2B.
Qed.


(** * Compilation of Imp to Asm *)

(** We are now ready to define our compiler.
    The compilation of [expr]essions is of little interest.
    The interesting part is in the structure of the
    compilation of instructions: we build higher level
    [asm] combinators from the primitive ones defined
    in [AsmCombinators.v]. Each of these combinator
    transcribes a control flow construct of the _Imp_
    language as a linking operation over _Asm_.
    Their correctness will be shown in the same style as
    the elementary combinators, isolating the control
    flow reasoning.
    Additionally, although naturally their choice here
    is tied to _Imp_, they are fairly generic constructs
    and could therefore be reused.
*)

(* begin hide *)
From ITreeTutorial Require Import Imp Asm Fin Utils_tutorial AsmCombinators.

From Coq Require Import
     Psatz
     List
     String
     Morphisms
     Setoid
     Decimal
     Numbers.DecimalString
     ZArith
     RelationClasses.

From ITree Require Import
     ITree.

Import ListNotations.
Open Scope string_scope.
(* end hide *)

(* ================================================================= *)
(** ** Compilation of expressions *)

Section compile_assign.

  (** Expressions are compiled straightforwardly.
      The argument [l] is the number of registers already introduced to compile
      the expression, and is used for the name of the next one.
      The result of the computation [compile_expr l e] always ends up stored in [l].
   *)
  Fixpoint compile_expr (l:reg) (e: expr): list instr :=
    match e with
    | Var x => [Iload l x]
    | Lit n => [Imov l (Oimm n)]
    | Plus e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Iadd l l (Oreg (1 + l))]
    | Minus e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Isub l l (Oreg (1 + l))]
    | Mult e1 e2 =>
      let instrs1 := compile_expr l e1 in
      let instrs2 := compile_expr (1 + l) e2 in
      instrs1 ++ instrs2 ++ [Imul l l (Oreg (1 + l))]
      end.

  (** Compiles the expression and then moves the result (in register [0]) to address
      [x].  Note: here we assume a one-to-one mapping of _Imp_ global variable names
      and _Asm_ addresses.
  *)
  Definition compile_assign (x: Imp.var) (e: expr): list instr :=
    let instrs := compile_expr 0 e in
    instrs ++ [Istore x (Oreg 0)].

End compile_assign.

(* ================================================================= *)
(** ** Control flow combinators *)

(** Sequencing of blocks: the program [seq_asm ab bc] links the
    exit points of [ab] with the entry points of [bc].

[[
           B
   A---ab-----bc---C
]]

   ... can be implemented using just [app_asm], [relabel_asm] and [loop_asm].

  Indeed, [app_asm ab bc] can be visualized as:
[[
  A---ab---B
  B---bc---C
]]
 i.e. a [asm (A + B) (B + C)]. To link them, we need first to swap the entry points.

We obtain the following diagram:
[seq_asm ab bc]
[[
       +------+
       |      |
   A------ab--+B
       |
      B+--bc------C
]]

Which translates to:
 *)
Definition seq_asm {A B C} (ab : asm A B) (bc : asm B C)
  : asm A C :=
  loop_asm (relabel_asm swap (id_ _) (app_asm ab bc)).

(** Location of temporary for [if]. *)
Definition tmp_if := 0.

(** Turns the list of instructions resulting from the conditional
    expression of a _if_ to a block with two exit points.
 *)
Definition cond_asm (e : list instr) : asm 1 2 :=
  raw_asm_block (after e (Bbrz tmp_if (fS f0) f0)).

(** Conditional branch of blocks.
    The program [if_asm e tp fp] creates a block out of [e] jumping
    either left or right.
    Using [seq_asm], this block is sequenced with the vertical
    composition [app_asm] of [tp] and [fp].
    Remains one mismatch: [app_asm] duplicates the domain of outputs,
    although they share the same. We hence use [relabel_asm] to collapse
    them together.

 [if_asm e tp fp]
[[
           true
       /ee-------tp---A\
    1--                 --A
       \ee-------fp---A/
           false
]]
 *)
Definition if_asm {A}
           (e : list instr) (tp : asm 1 A) (fp : asm 1 A) :
  asm 1 A :=
  seq_asm (cond_asm e)
          (relabel_asm (id_ _) merge (app_asm tp fp)).

(* Conditional looping of blocks.
   The program [while_asm e p] composes vertically two programs:
   an [if_asm] construct with [p] followed by a jump on the true branch,
   and a unique jump on the false branch.
   The loop is then closed with [loop_asm] by matching the jump from the
   true branch to the entry point.

[while_asm e p]
[[
      +-------------+
      |             |
      |    true     |
      |  e-------p--+
  1---+--e--------------1
           false
]]
*)
Definition while_asm (e : list instr) (p : asm 1 1) :
  asm 1 1 :=
  loop_asm (relabel_asm (id_ _) merge
    (app_asm (if_asm e
                (relabel_asm (id_ _) inl_ p)
                (pure_asm inr_))
            (pure_asm inl_))).

(** Equipped with our combinators, the compiler writes itself
    by induction on the structure of the statement.
*)
Fixpoint compile (s : stmt) {struct s} : asm 1 1 :=
  match s with
  | Skip       => id_asm
  | Assign x e => raw_asm_block (after (compile_assign x e) (Bjmp f0))
  | Seq l r    => seq_asm (compile l) (compile r)
  | If e l r   => if_asm (compile_expr 0 e) (compile l) (compile r)
  | While e b  => while_asm (compile_expr 0 e) (compile b)
  end.

(** We now consider its proof of correctness in [Imp2AsmCorrectness.v]. *)


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of statements and expressions, pg. 58, 59.

*)

Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

(* Test the S judgement. *)

(* ?TODO Let's make these tests more meaninful. *)

(* Let's make some e->e' transitions that actually evaluate something to test this stuff. *)

Definition s  := (if_s (i_e (i_i 0))
                       (e_s (i_e (i_i 0)))
                       (e_s (i_e (i_i 1)))).
Definition s' := (e_s (i_e (i_i 0))).

Definition e  := (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) zero_pe).
Definition e' := (i_e (i_i 0)).

Definition hxv := (H.ctxt x v hdot).

Example S_Let_3_1_test :
  S hdot (letx x v s) (H.ctxt x v hdot) s.
Proof.
  apply S_let_3_1;
  eauto 20 with Chapter3.
Qed.

Example S_seq_3_2_test :
  S hdot (seq (e_s v) s) hdot s.
Proof.
  apply S_seq_3_2.
  eauto 20 with Chapter3.
Qed.

Example S_return_3_3_test :
 S hdot (seq (retn v) s) hdot (retn v).
Proof.
  apply S_return_3_3.
  eauto 20 with Chapter3.
Qed.

Example S_if0_3_4_test :
 S hdot (if_s (i_e (i_i 0)) s1 s2)
   hdot s1.
Proof.
  apply S_if0_3_4.
Qed.

Example S_if_ne_0_3_5_test :
  S hdot (if_s vi1 s1 s2) hdot s2.
Proof.
  apply S_if_ne_0_3_5.
  eauto 20 with Chapter3.
Qed.

Example S_while_3_6_test :
 S hdot (while e s)
   hdot (if_s e (seq s (while e s)) (e_s (i_e (i_i 0)))).
Proof.
  apply S_while_3_6.
Qed.

(* Bug 8, just naming in two constructors. *)

(* TODO Questionable test? *)
Example S_open_3_7_test :
  S hdot (open (pack tau' v (etype aliases alpha k tau)) alpha x s)
    hdot (letx x' v (subst_St s tau alpha)).
Proof.
  apply S_open_3_7.
  eauto 20 with Chapter3.
Qed.

(* TODO Questionable test? *)
Definition etau := (etype aliases alpha A tau).
Definition H38 := (H.ctxt x (pack etau v etau) hdot).
Example pack_value:
  H.map H38 x = Some v' ->
  Value v'.
Proof.
  intros H.
  compute in H.
  compute.
  eauto 20 with Chapter3.
Qed.

(* Okay so H evaluates right and is a value. *)
(* Bug 20, State unbound. *)
(* Bug 21, Pack not in Values! *)
(* Is this a bug with get or is this just not syntax directed without
  some Tacticals. At least need Tactical for adding nil. *)
(* Bug 22, why is this not syntax directed ? Automation bug really. *)
Example S_openstar_3_8_test :
  S H38 (openstar (p_e x []) alpha x' s)
    H38 (letx x'  (amp (p_e x ([] ++ [u_pe])))
                          (subst_St s tau alpha)).
Proof.
  apply S_openstar_3_8 with
  (tau':= etau) (v:= v) (q:= aliases) (k:=A)
  (v':= (pack etau v etau));
  eauto 20 with Chapter3.
Qed.

Example S_exp_3_9_1_test :
  S hdot (e_s e) hdot (e_s e').
Proof.
  apply S_exp_3_9_1.
  eauto 20 with Chapter3.
Qed.

Example S_ret_3_9_2_test :
  S hdot (retn e) hdot (retn e').
Proof.
  apply S_ret_3_9_2.
  eauto 20 with Chapter3.
Qed.

Example S_if_3_9_3_test :
  S hdot (if_s e s1 s2) hdot (if_s e' s1 s2).
Proof.
  apply S_if_3_9_3.
  eauto 20 with Chapter3.
Qed.

Example S_letx_3_9_4_test :
  S hdot (letx x e s) hdot (letx x e' s).
Proof.
  apply S_letx_3_9_4.
  eauto 20 with Chapter3.
Qed.

(* ? TODO e not a value.*)
Example S_open_3_9_5_test :
  S hdot (open e alpha x s) hdot (open e' alpha x s).
Proof.
  apply S_open_3_9_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 9 - extra tvar. *)
(* Bug 10. If returning the wrong clause. *)
Example S_seq_3_10_test :
  S hdot (seq s s2) hdot (seq s' s2).
Proof.
  apply S_seq_3_10.
  eauto 20 with Chapter3.
Qed.

Example S_openstar_3_11_test :
 S hdot (openstar (dot (p_e x []) zero_pe)    alpha x s)
   hdot (openstar      (p_e x [i_pe zero_pe]) alpha x s).
Proof.
  apply S_openstar_3_11.
  eauto 20 with Chapter3.
  apply L_xpi_3_1.
Qed.

(* Test R. *)

Definition h703 := (H.ctxt x v hdot).
Example R_get_3_1_test:
  R h703  (e_s (p_e x nil))
    h703  (e_s v).
Proof.
  (* I don't care because eauto can find this v'. *)
  apply R_get_3_1 with (v':=v);
  eauto 20 with Chapter3.
Qed.

Example R_assign_3_2_test:
  R (H.ctxt x (i_e (i_i 2)) hdot) (e_s (assign (p_e x []) (i_e (i_i 3))))
    (H.ctxt x (i_e (i_i 3)) hdot) (e_s (i_e (i_i 3))).
Proof.
 (* eauto 20 with Chapter3. works. *)
  eapply R_assign_3_2; try reflexivity;
  eauto 20 with Chapter3.
Qed.

Example R_initial_assign_3_2_test:
  R hdot (e_s (assign (p_e x []) (i_e (i_i 3))))
    (H.ctxt x (i_e (i_i 3)) hdot) (e_s (i_e (i_i 3))).
Proof.
 apply R_initial_assign_3_2;
 eauto 20 with Chapter3.
Qed.

Example R_star_3_3_test:
  R hxv (e_s (star (amp (p_e x nil))))
    hxv (e_s (p_e x nil)).
Proof.
  apply R_star_amp_3_3.
Qed.

Example R_dot_3_4_0_test:
  R hdot (e_s (dot (cpair v0 v1) zero_pe))
    hdot (e_s v0).
Proof.
  apply R_dot_3_4_0.
Qed.

Example R_dot_3_4_1_test:
  R hdot (e_s (dot (cpair v0 v1) one_pe))
    hdot (e_s v1).
Proof.
  apply R_dot_3_4_1.
Qed.

Example R_appl_3_5_test:
  R hdot (e_s (appl (f_e (dfun tau x tau' s)) v))
    hdot (e_s (call (letx x v s))).
Proof.
  apply R_appl_3_5.
  eauto 20 with Chapter3.
Qed.

Example R_call_3_6_test:
  R hdot (e_s (call (retn v)))
    hdot (e_s v).
Proof.
  apply R_call_3_6.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_7_test:
  R hdot (e_s (inst (f_e (ufun alpha k f)) tau))
    hdot (e_s (f_e (subst_F f tau alpha))).
Proof.
  apply R_inst_3_7.
Qed.

(* Bug 12, R instead of S in the precondition. *)

Example R_call_3_8_test:
  R hdot (e_s (call s)) hdot (e_s (call s')).
Proof.
  apply R_call_3_8.
  eauto 20 with Chapter3.
Qed.

(* Originally I had an invalid left expression here. *)

Example R_amp_3_9_1_test:
  R hxv (e_s (amp (dot (p_e x nil) zero_pe)))
    hxv (e_s (amp (p_e x [i_pe zero_pe]))).
Proof.
  apply R_amp_3_9_1.
  apply L_xpi_3_1.
Qed.

Example R_assign_3_9_2_test:
  R hdot (e_s (assign (star (amp (p_e x nil))) v0))
    hdot (e_s (assign (p_e x nil) v0)).
Proof.
  apply R_assign_3_9_2.
  eauto 20 with Chapter3.
Qed.

(* These would be nice for test but I can't make a statement into an expression. Even an If. *)

(* TODO It would be better if I went from h to h' here. *)
Example R_star_3_10_1_test:
  R hdot (e_s (star (star (amp (p_e x [])))))
    hdot (e_s (star (p_e x []))).
Proof.
  apply R_star_3_10_1.
  eauto 20 with Chapter3.
Qed.

Example R_dot_3_10_2_test:
  R hdot (e_s (dot (star (amp (p_e x [])))  zero_pe))
    hdot (e_s (dot (p_e x [])               zero_pe)).
Proof.
  apply R_dot_3_10_2.
  eauto 20 with Chapter3.
Qed.

(* TODO I should really make these change h to h' under e's evaluation. *)

Example Bug14_e_e':
 ~ R hdot (e_s (i_e (i_i 0)))
     hdot (e_s (i_e (i_i 1))).
Proof.
  compute.
  intros H.
  inversion H.
Qed.

(* Bug 17, L's instead of R's on precondition to 3.10 rules. *)
Example R_assign_3_10_3_test:
  R h (e_s (assign (p_e x pdot) e))
    h (e_s (assign (p_e x pdot) e')).
Proof.
  apply R_assign_3_10_3.
  eauto 20 with Chapter3.
Qed.

Example R_inst_3_10_4_test:
  R h  (e_s (inst e tau))
    h (e_s (inst e' tau)).
Proof.
  apply R_inst_3_10_4.
  eauto 20 with Chapter3.
Qed.

Example R_pack_3_10_5_test:
  R h  (e_s (pack tau' e  (etype witnesschanges alpha k tau)))
    h  (e_s (pack tau' e' (etype witnesschanges alpha k tau))).
Proof.
  apply R_pack_3_10_5.
  eauto 20 with Chapter3.
Qed.

(* Bug 18, Tau unquantified in three rules. *)
Example R_cpair_3_10_6_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_6.
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_7_test:
  R h (e_s (cpair v e))
    h (e_s (cpair v e')).
Proof.
  apply R_cpair_3_10_7;
  eauto 20 with Chapter3.
Qed.

Example R_cpair_3_10_8_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_8.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_9_test:
  R h (e_s (appl e e2))
    h (e_s (appl e' e2)).
Proof.
  apply R_appl_3_10_9.
  eauto 20 with Chapter3.
Qed.

Example R_appl_3_10_10_test:
  R h (e_s (appl v e))
    h (e_s (appl v e')).
Proof.
  apply R_appl_3_10_10;
  eauto 20 with Chapter3.
Qed.

(* Test L *)

Example L_xpi_3_1_test:
  L h (e_s (dot (p_e x nil) zero_pe))
    h (e_s (p_e x [(i_pe zero_pe)])).
Proof.
 apply L_xpi_3_1.
Qed.

Example L_staramp_3_2_test:
  L h (e_s (star (amp (p_e x nil)))) h (e_s (p_e x nil)).
Proof.
 apply L_staramp_3_2.
Qed.

(* Bug 11, h should have been h'. *)
(* Bug 14, extra e in quantification. *)
Example L_star_3_3_test:
  L h (e_s (star e)) h (e_s (star e')) .
Proof.
 eapply L_star_3_3.
 eauto 20 with Chapter3.
Qed.

(* Bug 19, extra quantified variable. *)
Example L_ei_3_4_test:
  L hdot (e_s (dot (dot (p_e x []) zero_pe) zero_pe))
    hdot (e_s (dot (p_e x ([] ++ [i_pe zero_pe])) zero_pe)).
Proof.
 apply L_ei_3_4.
 eauto 20 with Chapter3.
Qed.


From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_examples.logrel.prelude Require Export base.

Module stlc.
  Inductive expr :=
    | Var (x : var)
    | Lam (e : {bind 1 of expr})
    | App (e1 e2 : expr)
    (* Unit *)
    | Unit
    (* Products *)
    | Pair (e1 e2 : expr)
    | Fst (e : expr)
    | Snd (e : expr)
    (* Sums *)
    | InjL (e : expr)
    | InjR (e : expr)
    | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr}).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Inductive val :=
    | LamV (e : {bind 1 of expr})
    | UnitV
    | PairV (v1 v2 : val)
    | InjLV (v : val)
    | InjRV (v : val).

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr}).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    end.

  Definition state : Type := ().

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κ e2 σ2 ef :
    head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.
End stlc.

(** Language *)
Canonical Structure stlc_ectxi_lang := EctxiLanguage stlc.lang_mixin.
Canonical Structure stlc_ectx_lang := EctxLanguageOfEctxi stlc_ectxi_lang.
Canonical Structure stlc_lang := LanguageOfEctx stlc_ectx_lang.

Export stlc.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.


Require Import Coq.Classes.Morphisms.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.Instantiate.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.CoreK.

Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Nat.
Require Import MirrorCore.Util.Compat.

Set Implicit Arguments.
Set Strict Implicit.

Polymorphic Lemma equiv_hlist_app'
  : forall {T} (F : T -> Type)
      (eqv : forall x : T, Relation_Definitions.relation (F x))
      (a b : list T) (c c' : hlist F a) (d d' : hlist F b),
    equiv_hlist eqv (hlist_app c d) (hlist_app c' d') <->
    (equiv_hlist eqv c c' /\ equiv_hlist eqv d d').
Proof using.
  intros. symmetry. eapply equiv_hlist_app.
Qed.

Ltac solve_equiv_hlist :=
  repeat match goal with
         | |- _ => assumption
         | |- _ => reflexivity
         | |- equiv_hlist _ (hlist_app _ _) (hlist_app _ _) =>
           eapply equiv_hlist_app'; split; auto
         | |- _ => constructor
         end.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk _}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Fixpoint instantiateGoal (f : nat -> option expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | GGoal g => GGoal (instantiate f 0 g)
      | GAll t g' => GAll t (instantiateGoal f g')
      | GExs ts sub g' =>
        GExs ts (amap_instantiate f sub) (instantiateGoal f g')
      | GHyp h g' => GHyp (instantiate f 0 h) (instantiateGoal f g')
      | GConj_ a b =>
        GConj_ (instantiateGoal f a) (instantiateGoal f b)
    end.

  Definition GExs_nil_check (ts : list typ) (s : amap _)
             (g : Goal typ expr) : Goal typ expr :=
    match ts with
      | nil => g
      | _ :: _ => GExs ts s g
    end.

  Theorem GExs_nil_check_respects tus tvs ts sub
  : only_in_range (length tus) (length ts) sub ->
    WellFormed_amap sub ->
    (EqGoal (tus ++ ts) tvs ==> EqGoal tus tvs)%signature
         (@GExs typ expr ts sub) (GExs_nil_check ts sub).
  Proof.
    red. intros; subst.
    unfold EqGoal in *. simpl.
    destruct ts.
    { simpl in *.
      rewrite goalD_conv with (pfu := HList.app_nil_r_trans tus)
                              (pfv := eq_refl).
      autorewrite_with_eq_rw.
      destruct H1.
      split.
      { split.
        { intro. rewrite app_nil_r in H1. apply H1.
          inv_all. rewrite app_nil_r in *. assumption. }
        { rewrite app_nil_r in *.
          intros. apply H1 in H3.
          constructor; auto.
          eapply only_in_range_0_WellFormed_pre_entry; eauto.
          rewrite app_nil_r. assumption. } }
      { inversion H2; try constructor.
        eapply only_in_range_0_substD with (tus := tus++nil) (tvs:=tvs) in H; eauto.
        destruct H as [ ? [ ? ? ] ].
        rewrite H.
        constructor.
        do 5 red; intros; equivs.
        autorewrite with eq_rw.
        do 5 red in H5.
        rewrite H5; try reflexivity.
        unfold tenv.
        rewrite <- hlist_app_nil_r.
        revert H6. clear. firstorder. } }
    { simpl in *.
      destruct H1.
      split.
      { split; intros; inv_all; constructor; tauto. }
      inversion H2; try constructor.
      match goal with
        | |- _ _ match ?X with _ => _ end
                 match ?Y with _ => _ end =>
          change Y with X ; destruct X
      end; constructor.
      clear - H5; do 5 red; intros; equivs.
      eapply exists_iff. intros.
      eapply Quant._exists_iff. intros.
      eapply and_iff. reflexivity.
      intros. eapply H5; reflexivity. }
  Qed.

  Definition GExs_do_solved (tes : tenv typ) (m : amap expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved =>
        if amap_is_full (length tes) m then
          GSolved
        else
          GExs tes m g
      | _ => GExs tes m g
    end.

  Definition GHyp_do_solved (e : expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | _ => GHyp e g
    end.

  Definition GAll_do_solved (ts : typ) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | _ => GAll ts g
    end.

  Lemma WellFormed_Goal_All_iff
  : forall tus tvs t (g : Goal typ expr),
      WellFormed_Goal tus tvs (GAll t g) <->
      WellFormed_Goal tus (tvs ++ t :: nil) g.
  Proof using.
    split. intros; inv_all; subst. auto.
    intros. constructor. auto.
  Qed.

  (** DUPLICATE **)
  Lemma WellFormed_Goal_Solved_iff
  : forall tus tvs,
      WellFormed_Goal (typ:=typ) (expr:=expr) tus tvs GSolved <->
      True.
  Proof using.
    split. intros; inv_all; subst. auto.
    intros. constructor.
  Qed.

  Theorem GAll_do_solved_respects tus tvs t
  : (EqGoal tus (tvs ++ t :: nil) ==> EqGoal tus tvs)%signature
      (GAll_do_solved t) (@GAll typ expr t).
  Proof.
    red. red. simpl. unfold GAll_do_solved. simpl.
    intros.  destruct H. split.
    { clear - H.
      destruct x;
        (try rewrite WellFormed_Goal_All_iff);
        (try rewrite H);
        (try rewrite WellFormed_Goal_All_iff);
        try reflexivity.
      rewrite <- H.
      split; constructor. }
    { destruct x; simpl in *;
      try solve [ destruct H0; constructor;
                  do 5 red; intros; eapply forall_iff; intros; eapply H0; eauto;
                  solve_equiv_hlist ].
      inversion H0. subst.
      constructor.
      do 5 red; intros. split; auto.
      intros. eapply H3. eauto.
      eapply equiv_hlist_app'. split; eauto.
      constructor. reflexivity. constructor. auto. }
  Qed.

  Lemma WellFormed_Goal_Hyp_iff
  : forall tus tvs t (g : Goal typ expr),
      WellFormed_Goal tus tvs (GHyp t g) <->
      WellFormed_Goal tus tvs g.
  Proof.
    split. intros; inv_all; subst. auto.
    intros. constructor. auto.
  Qed.

  Theorem GHyp_do_solved_respects tus tvs t tD
  : propD tus tvs t = Some tD ->
    (EqGoal tus tvs ==> EqGoal tus tvs)%signature
      (GHyp_do_solved t) (@GHyp typ expr t).
  Proof.
    red. red. simpl. unfold GHyp_do_solved. simpl.
    intros. destruct H0. split.
    { clear - H0.
      destruct x;
        (try rewrite WellFormed_Goal_Hyp_iff);
        (try rewrite H0);
        (try rewrite WellFormed_Goal_Hyp_iff);
        try reflexivity. }
    { destruct x; simpl in *; rewrite H;
      try solve
          [ destruct H1; constructor;
            do 5 red; intros;
            eapply impl_iff; intros;
            [ equivs; reflexivity |  eapply H1; eauto ] ].
      inversion H1. subst.
      constructor.
      do 5 red; intros. split; auto.
      simpl; intros. eapply H4; eauto. }
  Qed.

  Lemma WellFormed_Goal_iff_GExs_cancel
  : forall (tus tvs ts : tenv typ) m x y,
      (WellFormed_Goal (tus ++ ts) tvs x <->
       WellFormed_Goal (tus ++ ts) tvs y) ->
      (WellFormed_Goal tus tvs (GExs ts m x) <->
       WellFormed_Goal tus tvs (GExs ts m y)).
  Proof using.
    intros. split; intros; inv_all; subst; constructor; tauto.
  Qed.

  Lemma GoalImplies_GExs_do_solved
  : forall c (cs : ctx_subst c) ts m g,
      GoalImplies (cs, GExs ts m g)
                  (cs, GExs_do_solved ts m g).
  Proof.
    Transparent GoalImplies. simpl; intros.
    split; auto.
    split.
    { destruct g; simpl; auto.
      destruct (amap_is_full (length ts) m);
        auto. constructor. }
    { forward; inv_all; subst.
      destruct g; simpl in *; forwardy; inv_all; subst;
      Cases.rewrite_all_goal.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * Opaque amap_is_full.
        match goal with
          | |- match _ _ _ (if ?X then _ else _) with _ => _ end =>
            consider X; intros; simpl
        end.
        + split; [ reflexivity | ].
          intros. eapply Pure_pctxD; eauto. intros.
          eapply Quant._exists_sem.
          eapply subst_getInstantiation in H3; eauto.
          destruct H3.
          exists (hlist_map (fun t (x : exprT _ _ (typD t))=> x us0 vs0) x).
          eauto.
        + change_rewrite H3.
          split; [ reflexivity | ].
          intros. eapply Pure_pctxD; eauto. }
  Qed.

  Fixpoint toResult (ctx ctx' : Ctx typ expr)
           (g : Goal typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs => More_ cs g
      | CAll ctx' t => fun cs =>
        @toResult ctx ctx' (GAll t g) (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @toResult ctx ctx'  (GHyp h g) (fromHyp cs)
      | CExs ctx' ts => fun cs : ctx_subst (CExs (Ctx_append ctx ctx') ts) =>
        let '(s,cs') := fromExs cs in
        @toResult ctx ctx' (GExs ts s g) cs'
    end.

  Fixpoint reduceResult (ctx ctx' : Ctx typ expr)
           (g : Goal typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs =>
        (** TODO: this should be More_ but to do the right reasoning,
         ** I need to find a better equivalence relation
         **)
        More cs g
      | CAll ctx' t => fun cs =>
        @reduceResult ctx ctx' (GAll_do_solved t g) (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @reduceResult ctx ctx'  (GHyp_do_solved h g) (fromHyp cs)
      | CExs ctx' ts => fun cs : ctx_subst (CExs (Ctx_append ctx ctx') ts) =>
        let '(s,cs') := fromExs cs in
        @reduceResult ctx ctx' (GExs_do_solved ts s g) cs'
    end.

  (** This assumes that the goal is a [GSolved] **)
  Fixpoint solveGoal (ctx ctx' : Ctx typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs => Solved cs
      | CAll ctx' t => fun cs =>
        @solveGoal ctx ctx' (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @solveGoal ctx ctx' (fromHyp cs)
      | CExs ctx' ts => fun cs =>
        let '(s,cs') := fromExs cs in
        let g' := GExs_do_solved ts s GSolved in
        match g' with
          | GSolved => @solveGoal ctx ctx' cs'
          | g' => @toResult ctx ctx' g' cs'
        end
    end.

  Lemma solveGoal_toGoal
  : forall ctx ctx' (cs : ctx_subst (Ctx_append ctx ctx')),
      (EqResult)
        (@solveGoal ctx ctx' cs) (toResult ctx ctx' GSolved cs).
  Proof.
  Abort.

  Definition reduceGoal (ctx ctx' : Ctx typ expr)
             (s : ctx_subst (Ctx_append ctx ctx'))
             (g : Goal typ expr)
  : Result ctx :=
    match g with
      | GSolved => @solveGoal ctx ctx' s
      | _ => @reduceResult ctx ctx' g s
    end.

  Definition ResultImplies ctx (r1 r2 : Result ctx) : Prop :=
    match fromResult r1 , fromResult r2 with
      | _ , None => True
      | Some a , Some b => GoalImplies a b
      | None , _ => False
    end.

End parameterized.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import coloring.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* A quiz is a pair of binary trees that covers the inner regions of a    *)
(* configuration and store their arity. The embedding lemmas allow us to  *)
(* use questions to actually test for an isomorphic embedding of the      *)
(* configuration in a minimal uncolorable cubic map.                      *)

(* We are only interested in arities between 5 and 11 (in fact 9, 10, and 11 *)
(* only occur at the hub).                                                   *)

Inductive qarity : Set :=
  | Qa5 : qarity
  | Qa6 : qarity
  | Qa7 : qarity
  | Qa8 : qarity
  | Qa9 : qarity
  | Qa10 : qarity
  | Qa11 : qarity.

Definition nat_of_qarity (qa : qarity) : nat :=
  match qa with
  | Qa5 => 5
  | Qa6 => 6
  | Qa7 => 7
  | Qa8 => 8
  | Qa9 => 9
  | Qa10 => 10
  | Qa11 => 11
  end.

Coercion nat_of_qarity : qarity >-> nat.

Definition qarity_of_nat (n : nat) : qarity :=
  match n with
  | S (S (S (S (S O)))) => Qa5
  | S (S (S (S (S (S O))))) => Qa6
  | S (S (S (S (S (S (S O)))))) => Qa7
  | S (S (S (S (S (S (S (S O))))))) => Qa8
  | S (S (S (S (S (S (S (S (S O)))))))) => Qa9
  | S (S (S (S (S (S (S (S (S (S O))))))))) => Qa10
  | _ => Qa11
  end.

Lemma qarity_of_qarity : forall qa : qarity, qarity_of_nat qa = qa.
Proof. by case. Qed.

Lemma qarityDataP : comparable qarity.
Proof. rewrite /comparable; decide equality. Qed.

(* We specialize the question tree constructor according to the presence    *)
(* of left and right branches. We also need skewed left and right branches, *)
(* for configurations whose interior has an articulation.                   *)

Inductive question : Set :=
  | Qask0 : question
  | Qask1 : qarity -> question
  | QaskL : qarity -> question -> question
  | QaskR : qarity -> question -> question
  | QaskLR : qarity -> question -> question -> question
  | QaskLL : qarity -> question -> question
  | QaskRR : qarity -> question -> question.

Lemma questionDataP : comparable question.
Proof. rewrite /comparable; decide equality; apply qarityDataP. Qed.
Definition questionData : dataSet := Eval compute in
  compareData questionDataP.
Canonical Structure questionData.

Definition isQaskR q := if q is QaskR _ _ then true else false.

Fixpoint flatq (q : question) : natseq :=
  match q with
  | Qask0 => seq0
  | Qask1 qa => seq1 (qa : nat)
  | QaskL qa ql => Adds (qa : nat) (flatq ql)
  | QaskR qa qr => Adds (qa : nat) (flatq qr)
  | QaskLR qa ql qr => Adds (qa : nat) (cat (flatq ql) (flatq qr))
  | QaskLL qa qll => Adds (qa : nat) (flatq qll)
  | QaskRR qa qrr => Adds (qa : nat) (flatq qrr)
  end.

(* Mirror image questions. *)

Fixpoint flipq (q : question) : question :=
  match q with
  | QaskL qa ql => QaskR qa (flipq ql)
  | QaskR qa qr => QaskL qa (flipq qr)
  | QaskLR qa ql qr => QaskLR qa (flipq qr) (flipq ql)
  | QaskLL qa qll => QaskRR qa (flipq qll)
  | QaskRR qa qrr => QaskLL qa (flipq qrr)
  | _ => q
  end.

Definition qstepL (g : hypermap) (x : g) := node (edge (node x)).
Definition qstepR (g : hypermap) (x : g) := node (edge x).

Inductive quiz : Set := Quiz : forall q0 q1 : question, quiz.

Definition isQuizR qz := let: Quiz q0 q1 := qz in isQaskR q0 && isQaskR q1.

Definition flatqz qz := let: Quiz q0 q1 := qz in cat (flatq q0) (flatq q1).

Definition flipqz qz :=
  if qz is Quiz (QaskR qa0 q01) (QaskR qa1 q10) then
    Quiz (QaskR qa0 (flipq q10)) (QaskR qa1 (flipq q01))
  else qz.

Section FitQuiz.

Variable g : hypermap.

Fixpoint walkq (x : g) (q : question) {struct q} : seq g :=
  match q with
  | Qask0 => seq0
  | Qask1 qa => seq1 x
  | QaskL qa ql => Adds x (walkq (qstepL x) ql)
  | QaskR qa qr => Adds x (walkq (qstepR x) qr)
  | QaskLR qa ql qr => Adds x (cat (walkq (qstepL x) ql) (walkq (qstepR x) qr))
  | QaskLL qa qll =>
    let xl := qstepL x in Adds (edge (node xl)) (walkq (qstepL xl) qll)
  | QaskRR qa qrr => let xr := qstepR x in Adds xr (walkq (qstepR xr) qrr)
  end.

Definition fitq (x : g) q := (flatq q : seq _) =d maps arity (walkq x q).

Lemma size_walkq : forall (x : g) q, size (walkq x q) = size (flatq q).
Proof. move=> x q; elim: q x => //= *; rewrite ?size_cat; congr S; auto. Qed.

Lemma fitq_cat : forall x q s s',
 (cat (flatq q) s =d maps arity (cat (walkq x q) s'))
    = fitq x q && (s =d maps arity s').
Proof.
move=> x q s s'; rewrite /fitq; move: (introT eqP (size_walkq x q)).
elim: {q x}(walkq x q) (flatq q) => [|x s1 Hrec] [|n s2] //= Es12.
rewrite !eqseq_adds -andbA; congr andb; auto.
Qed.

Lemma size_flipq : forall q, size (flatq (flipq q)) = size (flatq q).
Proof. elim=> //= *; rewrite ?size_cat 1?addnC; congr S; auto. Qed.

Definition walkqz x qz :=
  let: Quiz q0 q1 := qz in cat (walkq x q0) (walkq (edge x) q1).

Lemma size_walkqz : forall x qz, size (walkqz x qz) = size (flatqz qz).
Proof. by move=> x [q0 q1]; rewrite /= ?size_cat ?size_walkq. Qed.

Definition fitqz x qz := flatqz qz =d maps arity (walkqz x qz).

End FitQuiz.

Lemma fitqz_flip : forall g x qz, plain_cubic g -> isQuizR qz ->
  @fitqz g x (flipqz qz) = @fitqz (mirror g) (face x) qz.
Proof.
move=> g x [q0 q1] [HgE HgN]; case: q0 => //=; case: q1 => //=.
move=> qa1 q10 qa0 q01 _; move Dh: (fun y : g => y : mirror g) => h.
rewrite (congr1 (fun f => f (face x)) Dh); move: x.
have De2: forall x : g, edge (edge x) = x by apply plain_eq.
have Dn3: forall x : g, node (node (node x)) = x by apply cubic_eq.
have Hh1: forall x : g, arity (h x) = arity x.
 by move=> x; rewrite -Dh arity_mirror.
have HhL: forall x : g, qstepL (h x) = h (qstepR x).
move=> x; rewrite -Dh /= /comp (f_finv (Inode g)) -{1}[x]De2 -{1}[edge x]Dn3.
  by rewrite Enode (finv_f (Inode g)).
have HhR: forall x : g, qstepR (h x) = h (qstepL x).
  move=> x; apply: (etrans _ (HhL _)).
  by rewrite -Dh /qstepL /qstepR /= (finv_f (Inode g)).
have HhE: forall x : g, edge (h (face x)) = h (face (edge x)).
  by move=> x; rewrite -Dh /= -{1}[x]De2 /comp Eedge.
have EaEN: forall x, arity (edge (node x)) = arity x.
  by move=> g' x; rewrite -arity_face Enode.
  move: (mirror g) h {Dh}Hh1 HhL HhR HhE => g' h Hh1 HhL HhR HhE.
have Eqs1: forall (n n' : nat) s s',
  (Adds n s =d Adds n' s') = (n =d n') && (s =d s') by done.
have Hq: forall q x, fitq x (flipq q) = fitq (h x) q.
  rewrite /fitq; elim=> //= *; rewrite ?HhL ?HhR ?EaEN Hh1 //;
    rewrite ?Eqs1 ?fitq_cat /fitq; try congr andb; auto.
  by rewrite andbC; congr andb.
move=> x; rewrite /fitqz /= !Eqs1 !fitq_cat /= !Eqs1 HhE !Hh1 !arity_face !HhR.
congr andb; rewrite !(andbC ((qa1 : nat) =d _)) !andbA; congr andb; rewrite andbC.
congr andb; apply: (etrans (Hq _ _) (congr1 (fun y => fitq (h y) _) _)).
  by rewrite /qstepL -{2}[x]De2 Eedge.
by rewrite /qstepL Eedge.
Qed.

Section QuizEmbedding.

Variables (gm gc : hypermap) (rc : seq gc).

Notation ac := (kernel rc).
Notation bc := (setC rc).
Let Hacbc := subsetP (kernel_off_ring rc).
Let HacF := kernelF rc.

Hypotheses (Hgm : plain_cubic gm) (Hgc : plain_quasicubic rc).
Let De2m := plain_eq Hgm.
Let Dn3m := cubic_eq Hgm.
Let De2c := plain_eq Hgc.
Let Dn3c := quasicubic_eq Hgc.

(* Adds the (disjoint) domain covered by the question to a previously covered *)
(* domain. The empty set is returned if the question is invalid (wrong arity, *)
(* cover overlap).                                                            *)

Variables (x0m : gm) (x0c : gc) (qz : quiz).
Let s0c : seq gc := walkqz x0c qz.
Let s0m : seq gm := walkqz x0m qz.

Definition valid_quiz :=
  and4 (isQuizR qz) (fitqz x0c qz) (simple s0c) (fband s0c =1 ac).

Hypotheses (Hqzc : valid_quiz) (Hqzm : fitqz x0m qz).

Definition embedqz x :=
  let i := find (cface x) s0c in
  let j := findex face (sub x0c s0c i) x in
  iter j face (sub x0m s0m i).

Notation h := embedqz.
Notation hc := (edge_central h).
Let HhcE := edge_central_edge h Hgc Hgm.

Remark Embedqz_Dhx0 : h x0c = x0m.
Proof.
rewrite /h /s0c /s0m; case: Hqzc => [H _ _ _]; case: qz H => [q0 q1].
by case q0; rewrite //= connect0 /= findex0.
Qed.
Notation Dhx0 := Embedqz_Dhx0.

Remark Embedqz_Dhs0 : forall i : nat, h (sub x0c s0c i) = sub x0m s0m i.
Proof.
move=> i; case Hi: (size s0c <= i).
  by rewrite !sub_default ?Dhx0 //; move: Hi; rewrite /s0c /s0m !size_walkqz.
rewrite leqNgt in Hi; move/idP: Hi => Hi.
set x := sub x0c s0c i; rewrite /h.
suffice ->: find (cface x) s0c = i by rewrite -/x findex0.
case: Hqzc => [_ _ Uq _]; move: Uq.
rewrite -(cat_take_drop i s0c) (drop_sub x0c Hi) -/x.
rewrite /simple maps_cat uniq_cat /=; move/and3P=> [_ Uq _].
rewrite find_cat /= connect0 (size_takel (ltnW Hi)) addn0.
case: (hasPx (cface x) (take i s0c)) => // [[y Hy Hxy]].
case/norP: Uq; case/mapsP; exists y; first done.
symmetry; exact: (rootP (Sface _)).
Qed.
Notation Dhs0 := Embedqz_Dhs0.

Remark Embedqz_Dhex0 : h (edge x0c) = edge x0m.
Proof.
case: Hqzc => [H _ _ _]; move: Dhs0 H; rewrite /s0c /s0m; case qz.
move=> /= q0 q1 H; move: {H}(H (size (flatq q0))).
by rewrite !sub_cat !size_walkq /= ltnn subnn andbC; case q1.
Qed.
Notation Dhex0 := Embedqz_Dhex0.

Lemma embedqz_arity : forall x, ac x -> arity (h x) = arity x.
Proof.
case: Hqzc => [_ Haqc _ Dac] x; rewrite -{}Dac /h; move=> Hx.
set i := find (cface x) s0c; set y := sub x0c s0c i.
set j := findex face y x.
have Hi: i < size s0c by rewrite /i -has_find.
have Hy: s0c y by exact: mem_sub Hi.
have Hxy: cface x y by exact: sub_find.
move: Haqc Hqzm; rewrite /fitqz -/s0c -/s0m => Eaqc Eqzm.
rewrite (arity_cface Hxy) /y -(sub_maps x0c 0) // -(eqP Eaqc) (eqP Eqzm).
rewrite (sub_maps x0m 0); first by elim j=> *; rewrite /= ?arity_face.
by move: Hi; rewrite /s0c /s0m !size_walkqz.
Qed.

Lemma embedqz_face : forall x, ac x -> h (face x) = face (h x).
Proof.
case: Hqzc => [_ _ _ Dac] x; rewrite -Dac => Hx.
set i := find (cface x) s0c; rewrite /h -(eq_find (cface1 x)) -/i.
set yc := sub x0c s0c i.
have Hxyc: cface yc x by rewrite Sface /yc /i sub_find.
rewrite -Dhs0 -/yc -{1}(iter_findex Hxyc).
move: (findex face yc x) (@findex_max _ face yc x) => j Hj.
rewrite leq_eqVlt in Hj; case/orP: {Hj}(Hj Hxyc) => [Dj|Hj].
  rewrite -[j]/(pred (S j)) (eqP Dj) -/(finv face yc) (f_finv (Iface gc)).
  rewrite findex0 /= -/(arity yc) -embedqz_arity.
    by rewrite -/(finv face (h yc)) (f_finv (Iface gm)).
  by rewrite -Dac (closed_connect (fbandF s0c) Hxyc).
by rewrite f_iter findex_iter.
Qed.

Lemma embedqz_central : sub_set s0c hc.
Proof.
have Hq: forall x q, ac x -> ac (edge x) -> hc x -> let s := walkq (node x) q in
    all ac s -> (maps h s =d walkq (node (h x)) q) -> all hc s.
  move=> x q; elim: q x => //= _.
  - move=> x HxF _ HxE _; case/andP; move/eqP=> Dhnx _.
    rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11 //.
    by rewrite (fclosed1 HacF) Enode.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> Dhnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    have HennxE: hc (edge (node (node x))).
      rewrite /edge_central De2c -{1}[node (node x)]Enode (Dn3c (Hacbc HxF)).
      rewrite (embedqz_face HexF) (eqP HxE) -{1}[h x]Dn3m Enode.
      by rewrite -[h (edge _)]Eface -embedqz_face // De2m Enode Dhnx set11.
    rewrite HnxE /= /qstepL Hrec //.
    rewrite De2c -[node (node x)]Enode (Dn3c (Hacbc HxF)).
      by rewrite -(fclosed1 HacF).
    by rewrite -[h (edge _)]Eface -embedqz_face // Enode Dhnx.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> Dhnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    by rewrite HnxE /= /qstepR Hrec ?De2c 1?HhcE // (eqP HnxE) Dhnx.
  - move=> ql Hrecl qr Hrecr x HxF HexF HxE /=.
    rewrite !all_cat eqseq_adds maps_cat eqseq_cat ?size_maps ?size_walkq //.
    move/and3P=> [HnxF HslF HsrF]; case/and3P; move/eqP=> Dhnx Hsl Hsr.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    have HennxE: hc (edge (node (node x))).
    rewrite /edge_central De2c -{1}[node (node x)]Enode (Dn3c (Hacbc HxF)).
    rewrite (embedqz_face HexF) (eqP HxE) -{1}[h x]Dn3m Enode.
    rewrite -[h (edge _)]Eface -embedqz_face //.
      by rewrite De2m Enode Dhnx set11.
    rewrite HnxE /= /qstepL /qstepR Hrecl // ?Hrecr // ?De2c ?HhcE //.
    + by rewrite (eqP HnxE) Dhnx.
    + by rewrite -[node (node x)]Enode (Dn3c (Hacbc HxF)) -(fclosed1 HacF).
    by rewrite -[h (edge _)]Eface -embedqz_face // Enode Dhnx.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HenLnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> DhenLnx Hs.
    have HfexF: ac (face (edge x)) by rewrite -(fclosed1 HacF).
    have HffexF: ac (face (face (edge x))) by rewrite -(fclosed1 HacF).
    have HenLnxE: hc (edge (node (qstepL (node x)))).
      rewrite /edge_central De2c DhenLnx /qstepL De2m.
      rewrite -{1}[x]Eedge (Dn3c (Hacbc HfexF)).
      rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc HffexF)).
      rewrite !embedqz_face // (eqP HxE) -{2}[h x]Eedge Dn3m.
      by rewrite -{2}[face (edge _)]Eface De2m Dn3m set11.
    rewrite HenLnxE /= {1}/qstepL Hrec ?DhenLnx //.
    rewrite De2c -{1}[x]Eedge /qstepL (Dn3c (Hacbc HfexF)).
    by rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc HffexF)).
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HRnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> DhRnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HenenxF: ac (edge (node (edge (node x)))).
      by rewrite (fclosed1 HacF) Enode.
    have HRnxE: hc (qstepR (node x)).
      rewrite /edge_central DhRnx /qstepR -(monic2F_eqd (Eface gm)).
      rewrite -embedqz_face // Enode.
      by rewrite -(monic2F_eqd (Eface gm)) -embedqz_face // Enode set11.
    by rewrite HRnxE /= {1}/qstepR Hrec ?De2c ?HhcE // (eqP HRnxE) DhRnx.
have Hx0E: hc x0c by rewrite /edge_central Dhx0 Dhex0 set11.
have Hex0E: hc (edge x0c) by rewrite HhcE.
move: Hqzc => [Hqz _ _ Dac].
have Hs0F: subset s0c ac by rewrite -(eq_subset_r Dac); apply ring_fband.
have Ehs0: maps h s0c =d s0m.
  apply/eqP; pose n := size (flatqz qz).
  have Dnc: size s0c = n by rewrite /s0c size_walkqz.
  have Dnm: size s0m = n by rewrite /s0m size_walkqz.
  rewrite -(take_size s0c) -(take_size s0m) Dnc Dnm.
  elim: {-2}n (leqnn n) => [|i Hrec] Hi; first by rewrite !take0.
  rewrite (take_sub x0c) ?Dnc // maps_add_last Dhs0 (Hrec (ltnW Hi)).
  by rewrite -take_sub // Dnm.
apply: subsetP; move: Hs0F Ehs0 {Dac}; rewrite /s0c /s0m !subset_all.
case: qz Hqz => [q0 q1] /=.
rewrite !all_cat maps_cat eqseq_cat; last by rewrite size_maps !size_walkq.
case: q0 => //= [_ q01]; case: q1 => //= [_ q10] _; rewrite Hx0E Hex0E /=.
case/and3P; case/andP; move=> Hx0cF Hs01F Hex0cF Hs10F; rewrite !eqseq_adds.
case/and3P; case/andP; move/eqP=> <- Hs01; move/eqP=> <- Hs10.
rewrite /qstepR !Hq // ?De2c // ?(eqP Hx0E) //.
by rewrite /qstepR (eqP Hx0E) De2c De2m in Hs10 |- *.
Qed.

Lemma embedqz_rlinked : rlink_connected (setI ac hc).
Proof.
have Hq1: forall x a, fband a x ->
    rlink_connected (setI (fband a) hc) -> hc (node x) ->
    rlink_connected (setI (fband (add_last a (node x))) hc).
  move=> x a Hx Ha Hnx y z; rewrite {1 2}/setI -cats1 !fband_cat /= !orbF.
  have Henx: setI (fband a) hc (edge (node x)).
    by rewrite /setI (fclosed1 (fbandF a)) Enode Hx HhcE.
  case Hynx: (cface y (node x)).
    case Hznx: (cface z (node x)).
      move=> _ _; exists (Seq0 gc); last done.
      by rewrite /= /rlink Eface (same_cface Hynx) Sface andbT.
    rewrite orbF; move{Hznx} => _ Hz.
    case: {Ha}(Ha _ _ Henx Hz) => [p Hp Hap]; exists (Adds (node x) p).
      by move: Hp; rewrite Eedge /= {2}/rlink Eface Hynx.
    rewrite /= /setI fband_cat Hnx /= connect0 orbT.
    apply/allP => [t Ht]; rewrite fband_cat demorgan2; apply/orP; left.
    by apply: (allP Hap).
  case Hznx: (cface z (node x)) {Hynx}; rewrite !orbF.
    move=> Hy; case: {Ha}(Ha _ _ Hy Henx) => [p Hp Hap].
    exists (add_last p (edge (node x))).
      by rewrite -cats1 path_cat Hp last_add_last /= /rlink De2c Sface Hznx.
    apply/allP => [t Ht]; rewrite /setI fband_cat demorgan2; apply/orP; left.
    rewrite mem_add_last in Ht; case/setU1P: Ht => [<-|Ht] //.
    by apply: (allP Hap).
  move=> Hy Hz; case: {Ha}(Ha _ _ Hy Hz) => [p Hp Hap]; exists p; auto.
  apply/allP => [t Ht]; rewrite /setI fband_cat demorgan2; apply/orP; left.
  by apply: (allP Hap).
have Hq: forall x a q, fband a x -> fband a (edge x) -> all ac a ->
    rlink_connected (setI (fband a) hc) -> let s := walkq (node x) q in
    all (setI ac hc) s -> rlink_connected (setI (fband (cat a s)) hc).
  move=> x a q; elim: q x a => /=; try by move=> *; rewrite cats0.
  - by move=> _ x a Hx _ _ HaE; rewrite cats1 andbT; case/andP; auto.
  - move=> _ ql Hrec x a Hx Hex Ha HaE; case/andP; move/andP=> [Hnx HnxE] Hql.
    rewrite -cat_add_last /qstepL; apply Hrec; auto.
    + by rewrite -cats1 fband_cat /= cface1 Enode connect0 orbT.
    + rewrite De2c -2!(Enode gc (node (node _))) (Dn3c (Hacbc Hnx)) Enode.
      by rewrite -cats1 fband_cat -(fclosed1 (fbandF a)) Hex.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ qr Hrec x a Hx _ Ha HaE; case/andP; move/andP=> [Hnx HnxE] Hqr.
    rewrite -cat_add_last /qstepR; apply Hrec; auto.
    + by rewrite -cats1 fband_cat (fclosed1 (fbandF a)) Enode Hx.
    + by rewrite De2c -cats1 fband_cat /= connect0 orbT.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ ql Hrecl qr Hrecr x a Hx Hex Ha HaE; rewrite all_cat; case/and3P.
    move/andP=> [Hnx HnxE] Hql Hqr.
    rewrite -cat_add_last catA /qstepR; apply Hrecr; auto.
    + by rewrite cat_add_last fband_cat /= (fclosed1 (fbandF a)) Enode Hx.
    + by rewrite De2c cat_add_last fband_cat /= connect0 orbT.
    + rewrite cat_add_last all_cat Ha /= Hnx /=.
      by rewrite all_setI in Hql; case/andP: Hql.
    rewrite /qstepL; apply Hrecl; auto.
    + by rewrite -cats1 fband_cat /= cface1 Enode connect0 orbC.
    + rewrite De2c -2!(Enode gc (node (node _))) (Dn3c (Hacbc Hnx)) Enode.
      by rewrite -cats1 fband_cat -(fclosed1 (fbandF a)) Hex.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ qll Hrec x a _ Hex Ha HaE; case/andP.
    move/andP=> [HneLnx HneLnxE] Hqll.
    have Hfex: ac (face (edge x)).
      case/hasP: Hex => [y Hy Hexy]; rewrite cface1 in Hexy.
      by rewrite (closed_connect HacF Hexy); apply (allP Ha).
    have Hffex: ac (face (face (edge x))) by rewrite -(fclosed1 HacF).
    have Dffex: node (qstepL (node x)) = face (face (edge x)).
      rewrite /qstepL -{1}[x]Eedge (Dn3c (Hacbc Hfex)).
      by rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc Hffex)).
    rewrite -cat_add_last {2}/qstepL; apply Hrec; auto.
    + by rewrite -cats1 fband_cat /= connect0 orbT.
    + by rewrite De2c Dffex -cats1 fband_cat -!(fclosed1 (fbandF a)) /= Hex.
    + by rewrite -cats1 all_cat Ha /= andbT.
    rewrite Dffex -{1}[face (face (edge x))]Eface De2c; apply Hq1; auto.
      by rewrite -!(fclosed1 (fbandF a)).
    by rewrite -[face (face (edge x))]De2c Eedge -Dffex.
  move=> _ qrr Hrec x a Hx _ Ha HaE; case/andP; move/andP=> [HRnx HRnxE] Hqrr.
  have Henx: ac (edge (node x)).
    case/hasP: Hx => [y Hy Hxy]; rewrite -[x]Enode -cface1 in Hxy.
    by rewrite (closed_connect HacF Hxy); apply (allP Ha).
  rewrite -cat_add_last {2}/qstepR; apply Hrec; auto.
  - by rewrite 2!(fclosed1 (fbandF _)) /qstepR !Enode -cats1 fband_cat Hx.
  - by rewrite De2c -cats1 fband_cat /= connect0 orbT.
  - by rewrite -cats1 all_cat Ha /= andbT.
  by rewrite /qstepR; apply Hq1; auto; rewrite (fclosed1 (fbandF a)) Enode.
case: Hqzc => [Hqz _ _ Dac].
have Hs: all (setI ac hc) s0c.
  apply/allP => [y Hy].
  by rewrite /setI -Dac (embedqz_central Hy) (subsetP (ring_fband _) _ Hy).
move: Hqz Dac Hs; rewrite /s0c; case: qz => [q0 q1] /=; rewrite all_cat /=.
case: q0 => //= [_ q01]; case: q1 => //= [_ q10] _ Dac; case/and3P; case/andP.
move/andP=> [Hx0F Hx0E] Hq01; move/andP=> [Hx1F Hx1E] Hq10.
pose a := cat (seq2 x0c (edge x0c)) (walkq (qstepR x0c) q01).
pose a' := cat a (walkq (qstepR (edge x0c)) q10).
have Ha': rlink_connected (setI (fband a') hc).
  rewrite /a' /qstepR; apply Hq; auto; rewrite ?De2c.
  - by apply (subsetP (ring_fband a)); rewrite /a /= /setU1 set11.
  - by apply (subsetP (ring_fband a)); rewrite /a /= /setU1 set11 /= orbT.
  - apply/allP => [x Hx]; rewrite /= in Hx.
    by do 2 case/setU1P: Hx => [<-|Hx] //; case/andP: (allP Hq01 _ Hx).
  rewrite /a /qstepR; apply Hq; auto; rewrite ?De2c /= ?connect0 ?orbT //.
    by rewrite Hx0F Hx1F.
  rewrite /seq2 -cat1s cats1 -{2}[x0c]Eface De2c; apply Hq1; auto.
  - by rewrite /= Sface fconnect1.
  - move=> x y; rewrite /setI /= !orbF; move/andP=> [Hx _]; move/andP=> [Hy _].
    by exists (Seq0 gc); rewrite //= /rlink Eface (same_cface Hx) Sface andbT.
  by rewrite -{1}[x0c]De2c Eedge.
have Dac': ac =1 fband a'.
  move=> x; rewrite -Dac /fband /= !has_cat /=; congr orb.
  by rewrite !orbA; congr orb; rewrite orbC.
move=> x y Hx Hy; rewrite /setI !Dac' in Hx Hy.
case: (Ha' _ _ Hx Hy) => [p Hp Hpa]; exists p; first done.
by apply/allP => [z Hz]; rewrite /setI Dac'; apply: (allP Hpa).
Qed.

Lemma quiz_preembedding : preembedding ac h.
Proof.
split.
- exact embedqz_face.
- exact embedqz_arity.
- case: Hqzc => [_ _ _ Dac]; apply/subsetP => x; rewrite -Dac.
  move/hasP=> [y Hy Hxy]; apply/set0Pn; exists y; rewrite /setI Hxy.
  exact: embedqz_central.
exact embedqz_rlinked.
Qed.

End QuizEmbedding.

Unset Implicit Arguments.


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

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Theory : Natural Transformations                        *)
(*                                                                           *)
(*          Amokrane Saibi May 1994                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Export Functor.
Require Export Setoid_dup2.

Set Implicit Arguments.
Unset Strict Implicit.

(* Natural Transformations *)

Section nt_def.

Variables (C D : Category) (F G : Functor C D).

Definition NT_law (T : forall a : C, F a --> G a) :=
  forall (a b : C) (f : a --> b), FMor F f o T b =_S T a o FMor G f.

Structure > NT : Type :=
  {ApNT :> forall a : C, F a --> G a; Prf_NT_law :> NT_law ApNT}.

(*** rewrite rules ***)

Lemma NatCond :
 forall (T : NT) (a b : C) (f : a --> b), FMor F f o T b =_S T a o FMor G f.
Proof.
exact Prf_NT_law.
Qed.

Lemma NatCond1 :
 forall (T : NT) (a b : C) (f : a --> b), T a o FMor G f =_S FMor F f o T b.
Proof.
intros T a b f; apply Sym; apply (Prf_NT_law T f).
Qed.

(* *)

End nt_def.

(* Natural Transformations Setoid between F and G*)

Section setoid_nt.

Variables (C D : Category) (F G : Functor C D).

Definition Equal_NT (T T' : NT F G) := forall a : C, T a =_S T' a.

Lemma Equal_NT_equiv : Equivalence Equal_NT.
Proof.
apply Build_Equivalence; unfold Equal_NT in |- *.
unfold Reflexive in |- *; intros T a; apply Refl.
apply Build_Partial_equivalence.
unfold Transitive in |- *; intros T1 T2 T3 H H0 a.
(* *) apply Trans with (ApNT T2 a); auto.
unfold Symmetric in |- *; intros T1 T2 H a.
apply Sym; apply H.
Qed.

Canonical Structure NT_setoid : Setoid'' := Equal_NT_equiv.

End setoid_nt.

Infix "=_NT" := Equal_NT (at level 70).


Require Import VerdiRaft.Raft.

Section LastAppliedCommitIndexMatching.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition lastApplied_commitIndex_match net :=
    forall h h' e,
      lastApplied (nwState net h') <= commitIndex (nwState net h) ->
      eIndex e <= lastApplied (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Definition commitIndex_lastApplied_match net :=
    forall h h' e,
      commitIndex (nwState net h') <= lastApplied (nwState net h) ->
      eIndex e <= commitIndex (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Definition lastApplied_lastApplied_match net :=
    forall h h' e,
      lastApplied (nwState net h') <= lastApplied (nwState net h) ->
      eIndex e <= lastApplied (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Class lastApplied_commitIndex_match_interface : Prop :=
    {
      lastApplied_commitIndex_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          lastApplied_commitIndex_match net;
      commitIndex_lastApplied_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          commitIndex_lastApplied_match net;
      lastApplied_lastApplied_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          lastApplied_lastApplied_match net
    }.

End LastAppliedCommitIndexMatching.