From Rela Require Import Sigma.
From Rela Require Import Loc.
From Rela Require Import Aexp.
From Rela Require Import Bexp.
From Rela Require Import Com.
From Rela Require Import Vcg.
From Rela Require Import Proc.
From Rela Require Vcg_Opt.
From Rela Require Import Hoare_Triple.
From Rela Require Import Correct.
From Rela Require Import Rela.
From Rela Require Import Vcg_Rela.
From Rela Require Import Correct_Rela.
Import Vcg.Why3_Set.
Import Vcg.Assn_b.
From Coq Require Import Lists.List.
Import ListNotations.
From Coq Require Import Program.
From Coq Require Import Eqdep_dec.
From Coq Require Import Lia.
Require Import Arith.

(** Example of arithmetic expression **)

Import AexpNotations.

Example aexp1 :
forall st : sigma,
    aeval (EAX !-> 1 ; st) [? (EAX + °EAX + &EAX) * 2 ?] = 6.
Proof.
reflexivity.
Qed.

(** Example of boolean expression **)

Import BexpNotations.

Example bexp1 :
forall st : sigma,
    beval (EAX !-> 5 ; st) [! true && ~ EAX <= 4 !] = true.
Proof.
reflexivity.
Qed.

(** Examples of commands **)

Import ComNotations.

Definition plus2 : com := <[ EAX := EAX + 2 ]>.

Example ecom3 :
forall (s : sigma),
  ceval plus2 s Psi.empty_psi (EAX !-> (s EAX) + 2 ; s).
Proof.
intros.
unfold plus2.
apply E_Ass. reflexivity.
Qed.

(** Some ltac to automatize the handling of memory states **)

Ltac mem_s s l1 l2 v :=
       generalize (set'def s l1 v l2);
       intros Heax; destruct Heax as ( Heax & _);
       rewrite Heax by lia;
       clear Heax.

Ltac mem_s_in s l1 l2 v :=
       generalize (set'def s l1 v l2);
       intros Heax; destruct Heax as ( Heax & _);
       rewrite Heax; clear Heax.

Ltac mem_d s l1 l2 v :=
       generalize (set'def s l1 v l2);
       intros Heax; destruct Heax as ( _ & Heax);
       rewrite Heax; [ | first [ lia | (intros HF; inversion HF)]];
       clear Heax.

Ltac mem_d_in s l1 l2 v:=
       generalize (set'def s l1 v l2);
       intros Heax; destruct Heax as ( _ & Heax);
       rewrite Heax; clear Heax.

(** Examples of proofs of Hoare Triples with verification condition generator **)

(* Body of procedure for multiplication *)

Definition mult: com := <[
  if 0 <= X1 && ~ X1 = 0 then
      X2 := X2 + X3;
      X1 := X1 - 1;
      call(f)
  else
    skip
  end ]>.

(* Procedure environment *)

Definition f_psi (x': Proc.t) :=
        if Proc.eqb x' f then mult else Psi.empty_psi x'.

(* Contract of pre and post condition of procedure f *)

Definition f_pre: precondition := fun s =>
   s(X2) = s(X3) * (s(X4) - s(X1)) /\
   0 <= s(X1) /\ Nat.le (s(X1)) (s(X4)).

Definition f_post: postcondition := fun s s' =>
  s(X2) = s'(X3) * s'(X4).

(* Contract environment *)

Definition f_phi (x': Proc.t) :=
        if Proc.eqb x' f then (f_pre,f_post) else Phi.empty_phi x'.

(* Program computing the multiplication of X3 and X4 and put the result in X2 *)

Definition com_mult := <[
  X1 := X4;
  X2 := 0;
  call(f)
]>.

(* Proof that command com_mult satisfies the
   postcondition f_post ( X2 = X3 * X4) *)
Example hoare_triple_mult: hoare_triple (fun _ => True) f_post com_mult f_psi.
Proof.
apply correct with (cl:=f_phi) (l:=[]).
(* Verification of proof obligation for procedures *)
* unfold f_psi, f_phi.
  apply Vcg_Opt.tc_p_same.
  intros f0.
  destruct (Proc.eqb f0 f) eqn: E.
  + split.
     (* Verification of auxilliary proof obligation for procedure f *)
    - apply Vcg_Opt.Tc'_list.tc'_list_same.
      simpl.
      destruct n.
      ** unfold Vcg_Opt.Tc'_list.continuation.
         simpl.
         intros.
         rewrite Proc.eqb_refl.
         simpl.
         unfold f_pre.
         rewrite H2.
         mem_d m'' X1 X2 (m'' X1 - 1).
         mem_d m'' X1 X3 (m'' X1 - 1).
         mem_d m'' X1 X4 (m'' X1 - 1).
         mem_s m'' X1 X1 (m'' X1 - 1).
         rewrite H1.
         mem_s m X2 X2 (m X2 + m X3).
         mem_d m X2 X3 (m X2 + m X3).
         mem_d m X2 X4 (m X2 + m X3).
         mem_d m X2 X1 (m X2 + m X3).
         simpl in H.
         unfold f_pre in H.
         destruct H.
         replace ((m X4 - (m X1 - 1))) with (S (m X4 - m X1 )) by lia.
         rewrite Loc.mul_succ_r.
         lia.
      ** destruct n; [auto | auto].
    (* Main proof obligation for procedure f : the postconditon hold*)
    - simpl.
      intros.
      destruct H0.
      ** decompose [and] H1;clear H1.
         rewrite Proc.eqb_refl in H6.
         simpl in H6.
         unfold f_post in H6.
         unfold f_post.
         rewrite  H6.
         rewrite H4.
         mem_d m'' X1 X3 (m'' X1 - 1).
         mem_d m'' X1 X4 (m'' X1 - 1).
         rewrite H2.
         mem_d m X2 X3 (m X2 + m X3).
         mem_d m X2 X4 (m X2 + m X3).
         reflexivity.
      ** rewrite H1.
         unfold f_post.
         simpl in H.
         unfold f_pre in H.
         decompose [and] H;clear H.
         lia.
  + intros. simpl in H. unfold empty_precondition in H.
    contradiction.
* unfold f_psi, f_phi.
  (* Verification of auxilliary proof obligation for command com*)
  intros. apply Vcg_Opt.tc'_same.
    apply Vcg_Opt.Tc'_list.tc'_list_same.
      simpl.
      destruct n.
      + unfold Vcg_Opt.Tc'_list.continuation.
         simpl.
         intros.
         rewrite Proc.eqb_refl.
         simpl.
         unfold f_pre.
         rewrite H1.
         mem_s m'' X2 X2 0.
         mem_d m'' X2 X3 0.
         mem_d m'' X2 X4 0.
         mem_d m'' X2 X1 0.
         rewrite H0.
         mem_d m X1 X3 (m X4).
         mem_d m X1 X4 (m X4).
         mem_s m X1 X1 (m X4).
         lia.
      + destruct n; [auto | auto].
 (* Main proof obligation for command com : the post condition hold*)
* unfold f_psi, f_phi.
    simpl.  intros.
    rewrite Proc.eqb_refl in H3.
    simpl in H3.
    unfold f_post in H3.
    unfold f_post.
    rewrite H3.
    rewrite H1.
    mem_d m' X2 X3 0.
    mem_d m' X2 X4 0.
    rewrite H0.
    mem_d m X1 X3 (m X4).
    mem_d m X1 X4 (m X4).
    reflexivity.
Qed.

(** Some ltac to automatize the extraction of proof obligation from
    the list construct in relational property verification **)

Ltac ltc2 phi ps hy hyh:=
        destruct (mk_rtc'_def _ _ (phi_call (extract phi) ps) _ _ _ _ hy hyh)
           as (hyr1  & hyr2 & HYP);
        rewrite HYP;
        clear HYP hy hyh;
        rename hyr1 into hy;
        rename hyr2 into hyh.

Ltac ltc7 phi ps hy hyh H:=
  ltc2 phi ps hy hyh;
  split; [ clear hy hyh; simpl H; apply Vcg_Opt.tc'_same
         | first [ltc7 phi ps hy hyh H | simpl;auto] ].

Ltac ltc1 phi ps hy hyh ml H :=
         destruct ml;
         [ first [ discriminate hy | first [ltc7 phi ps hy hyh H | simpl;auto] ]
         | first [ discriminate hy | ltc1 phi ps hy hyh ml H ]
         ].

Ltac ltc6 phi ps hy hyh :=
       destruct (mk_rtc_def _ _ (phi_call (extract phi) ps) _ _ _ _ hy hyh)
           as (hyr1 & hyr2 & HYP);
       rewrite HYP;
       clear HYP hy hyh;
       rename hyr1 into hy;
       rename hyr2 into hyh.

Ltac ltc3 phi ps hy hyh:=
    intro; intro; intros H1;
    tryif ltc6 phi ps hy hyh
    then
    eapply consequence_tc_suite;
    [ clear H1; ltc3 phi ps hy hyh
    | apply Vcg_Opt.tc_same; apply H1 ]
    else simpl; apply H1.

Ltac ltc5 phi ps hy hyh :=
    ltc6 phi ps hy hyh;
    eapply consequence_tc_suite;
    [ ltc3 phi ps hy hyh
    | apply Vcg_Opt.tc_same].

Ltac ltc4 ml hy hyh phi ps :=
         destruct ml;
         [ first [ discriminate hy | first [ltc5 phi ps hy hyh | simpl; auto] ]
         | first [ discriminate hy | ltc4 ml hy hyh phi ps ]
         ].

Ltac ltc0 phi l hyh := apply rcorrect
                with (rcl:=phi) (h:=l) (hyh:=hyh);
                 [
                 | intros ps;
                   split;
                   [ intros ml hy H Hr;
                     ltc1 phi ps hy hyh ml H
                   | intros ml hy H Hr;
                     ltc4 ml hy hyh phi ps;
                     clear hy hyh;
                     simpl in H
                   ]
                ].

(** Examples of proofs of Relational Properties
    with verification condition generator **)

(** Example 1: Swap **)

(* Defintion of two swap functions *)

Definition swap_1: com := <[ X3 := °X1;
                             °X1 := °X2;
                             °X2 := X3
                           ]>.

Definition swap_2: com := <[ °X1 := °X1 + °X2;
                             °X2 := °X1 - °X2;
                             °X1 := °X1 - °X2
                           ]>.

(* Defintion of relational pre and post condition *)

Definition rela_pre : r_precondition := fun l =>
  match l with
  | [m1; m2] => m1 (m1 X1) = m2 (m2 X1) /\ m1 (m1 X2) = m2 (m2 X2) /\
                         m1 X1 > 3 /\ m1 X2 > 3 /\ m2 X1 > 3 /\ m2 X2 > 3 /\
                         m1 X1 <> m1 X2 /\ m2 X1 <> m2 X2
  | _ => False
  end.

Definition rela_post : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 (m1 X1) = m2 (m2 X1) /\ m1 (m1 X2) = m2 (m2 X2)
  | _ => False
  end.

(* We proof that the swap function are equivalent *)

Example relation_swap : relational_prop
                            rela_pre rela_post
                            [swap_1; swap_2] Psi.empty_psi.
Proof.
assert (hyh :length [swap_1; swap_2] =
             length [empty_history; empty_history]).
{  simpl. reflexivity. }
ltc0 R_Phi.empty_r_phi [empty_history; empty_history] hyh.
(* Verification of proof obligation for procedure*)
+ apply rtc_p_empty_psi.
(* Verification of auxilliary proof obligation *)
+ simpl. auto.
+ simpl. auto.
(* Main proof obligation *)
+ simpl.
  intros.
  unfold X1, X2, X3 in *.
  decompose [and] H;clear H.
  decompose [and] H0;clear H0.
  decompose [and] H1;clear H1.
  split.
  * (*<1>*)
    rewrite H12.
    mem_d_in m''0 (m''0 2) 1 (m''0 3).
    mem_d_in m''0 (m''0 2) (m''0 1) (m''0 3).
    rewrite H11.
    mem_d_in m'' (m'' 1) 1 (m'' (m'' 2)).
    mem_s m'' (m'' 1) (m'' 1) (m'' (m'' 2)).
    rewrite H.
    mem_d s 3 2 (s (s 1)).
    mem_d s 3 (s 2) (s (s 1)).
    (*<2>*)
    rewrite H14.
    mem_d_in m''2 (m''2 1) 1 (m''2 (m''2 1) - m''2 (m''2 2)).
    mem_s m''2 (m''2 1) (m''2 1) (m''2 (m''2 1) - m''2 (m''2 2)).
    rewrite H13.
    mem_d_in m''1 (m''1 2) 2 (m''1 (m''1 1) - m''1 (m''1 2)).
    mem_d_in m''1 (m''1 2) 1 (m''1 (m''1 1) - m''1 (m''1 2)).
    mem_s m''1 (m''1 2) (m''1 2) (m''1 (m''1 1) - m''1 (m''1 2)).
    mem_d_in m''1 (m''1 2) (m''1 1) (m''1 (m''1 1) - m''1 (m''1 2)).
    rewrite H0.
    mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
    mem_d s0 (s0 1) (s0 2) (s0 (s0 1) + s0 (s0 2)).
    mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
    mem_s s0 (s0 1) (s0 1) (s0 (s0 1) + s0 (s0 2)).
    - lia.
    (* all the little things *)
    - rewrite H0.
      mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H13.
      mem_d_in m''1 (m''1 2) 1 (m''1 (m''1 1) - m''1 (m''1 2)).
      rewrite H0.
      mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
      lia.
      rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
    - rewrite H11.
      mem_d_in m'' (m'' 1) 1 (m'' (m'' 2)).
      mem_d_in m'' (m'' 1) 2 (m'' (m'' 2)).
      rewrite H.
      mem_d s 3 1 (s (s 1)).
      mem_d s 3 2 (s (s 1)).
      lia.
      rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
      rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
    - rewrite H11.
      mem_d_in m'' (m'' 1) 2 (m'' (m'' 2)).
      rewrite H.
      mem_d s 3 2 (s (s 1)).
      lia.
      rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
 * (*<1>*)
    rewrite H12.
    mem_d_in m''0 (m''0 2) 2 (m''0 3).
    mem_s m''0 (m''0 2) (m''0 2) (m''0 3).
    rewrite H11.
    mem_d_in m'' (m'' 1) 3 (m'' (m'' 2)).
    rewrite H.
    mem_s s 3 3 (s (s 1)).
    (*<2>*)
    rewrite H14.
    mem_d_in m''2 (m''2 1) 2 (m''2 (m''2 1) - m''2 (m''2 2)).
    mem_d_in m''2 (m''2 1) (m''2 2) (m''2 (m''2 1) - m''2 (m''2 2)).
    rewrite H13.
    mem_d_in m''1 (m''1 2) 2 (m''1 (m''1 1) - m''1 (m''1 2)).
    mem_s m''1 (m''1 2) (m''1 2)  (m''1 (m''1 1) - m''1 (m''1 2)).
    rewrite H0.
    mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
    mem_d s0 (s0 1) (s0 2) (s0 (s0 1) + s0 (s0 2)).
    mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
    mem_s s0 (s0 1) (s0 1) (s0 (s0 1) + s0 (s0 2)).
    - lia.
      (* all the little things*)
    - rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H13.
      mem_d_in m''1 (m''1 2) 1 (m''1 (m''1 1) - m''1 (m''1 2)).
      mem_d_in m''1 (m''1 2) 2 (m''1 (m''1 1) - m''1 (m''1 2)).
      rewrite H0.
      mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
      rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
      rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H13.
      mem_d_in m''1 (m''1 2) 1 (m''1 (m''1 1) - m''1 (m''1 2)).
      rewrite H0.
      mem_d s0 (s0 1) 1 (s0 (s0 1) + s0 (s0 2)).
      lia.
      rewrite H0.
      mem_d s0 (s0 1) 2 (s0 (s0 1) + s0 (s0 2)).
      lia.
    - rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
    - rewrite H11.
      mem_d_in m'' (m'' 1) 2 (m'' (m'' 2)).
      rewrite H.
      mem_d s 3 2 (s (s 1)).
      lia.
      rewrite H.
      mem_d s 3 1 (s (s 1)).
      lia.
Qed.

(** Example 2: Compare **)

(* Defintion of a comparator procedure *)

Definition comp: com :=
<[ if X1 <= X2 && ~ X1 = X2 then
      ret := 0
   else
      if X2 <= X1 && ~ X1 = X2  then
         ret := 2
      else
         ret := 1
      end
   end
]>.

(* Defintion of relational pre and post condition *)

Definition rela_pre_comp : r_precondition := fun l =>
  match l with
  | [m1; m2] => m1 X1 = m2 X2 /\ m1 X2 = m2 X1
  | _ => False
  end.

Definition rela_post_comp : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 ret + (m2 ret) = 2
  | _ => False
  end.

(* We proof anti-symmetry of the compare procedure *)

Example relation_comp : relational_prop
                            rela_pre_comp rela_post_comp
                            [comp; comp] Psi.empty_psi.
Proof.
assert (hyh :length [comp; comp] =
             length [empty_history; empty_history]).
{  simpl. reflexivity. }
ltc0 R_Phi.empty_r_phi [empty_history; empty_history] hyh.
(* Verification of proof obligation for procedure*)
+ apply rtc_p_empty_psi.
(* Verification of auxilliary proof obligation *)
+ simpl. auto.
+ simpl. auto.
(* Main proof obligation *)
+ simpl.
  intros.
  destruct H0.
  -- destruct H1.
     ** subst. lia.
     ** destruct H3.
        +++ subst.
            mem_s s ret ret 0.
            mem_s s0 ret ret 2.
            reflexivity.
        +++ subst. lia.
  -- destruct H1.
     ** destruct H2.
        +++ subst.
            mem_s s ret ret 2.
            mem_s s0 ret ret 0.
            reflexivity.
        +++ subst. lia.
     ** destruct H2.
        +++ subst. lia.
        +++ destruct H3.
           *** subst. lia.
           *** subst.
               mem_s s ret ret 1.
               mem_s s0 ret ret 1.
               reflexivity.
Qed.

(** Example 3: Monotone **)

(** Examples of proofs of relational properties using relational contract **)

(* Procedure environment *)

Definition f2_psi (x': Proc.t) :=
        if Proc.eqb x' f2 then  <[ X1 := X1 + 1 ]> else Psi.empty_psi x'.

(* Definition of relational contract for procedure f *)

Definition f2_r_pre : r_precondition := fun l =>
  match l with
  | [m1; m2] => m1 X1 < m2 X1
  | _ => False
  end.

Definition f2_r_post : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 X1 < m2 X1
  | _ => False
  end.

(* Definition of standard contract for procedure f *)

Definition f2_pre : r_precondition := fun l =>
  match l with
  | [m] => True
  | _ => False
  end.

Definition f2_post : r_postcondition := fun l _ =>
  match l with
  | [m1] => True
  | _ => False
  end.

(* Relational contract environment *)

Scheme Equality for list.

Definition f2_r_phi (x': list Proc.t) :=
        if (list_beq  Proc.t) Proc.eqb x' [f2; f2]
        then (f2_r_pre,f2_r_post)
        else
            if (list_beq  Proc.t) Proc.eqb x' [f2]
            then (f2_pre,f2_post)
            else R_Phi.empty_r_phi x'.

(* We proof monotony of procedure f2 *)

Example relation_mono : relational_prop
                  f2_r_pre f2_r_post
                  [<[ call(f2);call(f2) ]>;
                   <[ call(f2);call(f2) ]> ] f2_psi.
Proof.
assert (hyh :length [<[ call(f2);call(f2) ]>; <[ call(f2);call(f2) ]>] =
             length [empty_history; empty_history]).
{  simpl. reflexivity. }
ltc0 f2_r_phi [empty_history; empty_history] hyh.
(* Verification of proof obligation for procedure *)
+ unfold rtc_p.
  intros.
  destruct (list_beq Proc.t Proc.eqb f [f2; f2]) eqn: E1.
   (* Proof oblication for relational property {f2_r_pre} f2 ~ f2 {f2_r_post} *)
    - apply internal_list_dec_bl in E1 ;[ | apply Proc.eqb_eq ].
      subst.
      destruct m;[ discriminate hy1 | ].
      destruct m;[ discriminate hy1 | ].
      destruct m;[ | discriminate hy1 ].
      split.
       (* Verification of auxilliary proof obligation *)
       * simpl.  auto.
       (* Main proof obligation *)
       * simpl. intros.  subst.
         mem_s s X1 X1 (s X1 + 1).
         mem_s s0 X1 X1 (s0 X1 + 1).
         simpl in H.
         apply plus_lt_compat_r.
         unfold f2_r_phi in H.
         simpl in H.
         assumption.
    - destruct (list_beq Proc.t Proc.eqb f [f2]) eqn: E2.
       (* Verification of proof obligation for procedure f2*)
        * apply internal_list_dec_bl in E2 ;[ | apply Proc.eqb_eq ].
          subst.
          destruct m;[ discriminate hy1 | ].
          destruct m;[ | discriminate hy1 ].
          split.
          (* Verification of auxilliary proof obligation *)
          ** simpl. auto.
          (* Main proof obligation *)
          ** simpl. auto.
         (* Nothing to do for other procedure *)
         * unfold f2_r_phi in H.
           rewrite E1 in H.
           rewrite E2 in H.
           simpl in H.
           unfold empty_r_precondition in H.
           contradiction.
(* Proof obligation for relational property
      {f2_r_pre} <[ call(f2);call(f2) ]> ~ <[ call(f2);call(f2) ]> {f2_r_post}
*)
(* Verification of auxilliary proof obligation *)
+ simpl. auto.
+ simpl. auto.
(* Main proof obligation *)
+ simpl. intros.
  specialize (Hr [f2; f2]).
  generalize (Hr [s; s0 ] [m''; m''0]).
  intros H2.
  specialize (Hr [m''; m''0 ] [m'; m'0]).
  simpl in Hr.
  simpl in H2.
  apply Hr.
  all: try lia.
  split. apply H0.
  split. apply H1.
  auto.
  apply H2.
  all: try lia.
  split. apply H0.
  split. apply H1.
  auto.
 Qed.

(** Example 4: Nat Sum **)

(** Examples of proofs of relational properties using relational contract **)

(* Defintion of a functions that sum up all natural from 0 to X2*)

Definition f3_body: com := <[
  if X1 <= X2 && ~ X1 = X2 then
      X3 := X3 + X1;
      X1 := X1 + 1;
      call(f3)
  else
    skip
  end ]>.

(* Procedure environment *)

Definition f3_psi (x': Proc.t) :=
        if Proc.eqb x' f3 then f3_body else Psi.empty_psi x'.

(* Definition of relational contract for procedure f *)

Definition f3_r_pre : r_precondition := fun l =>
  match l with
  | [m1; m2] => m2 X1 <= m2 X2 /\ ~ (m2 X1 = m2 X2) /\
                        m1 X2 = m2 X2 /\
                        m1 X1 = m2 X1 + 1 /\
                        m1 X3 = m2 X3 + m2 X1
  | _ => False
  end.

Definition f3_r_post : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 X3 = m2 X3
  | _ => False
  end.

(* Definition of standard contract for procedure f *)

Definition f3_pre : r_precondition := fun l =>
  match l with
  | [m] => True
  | _ => False
  end.

Definition f3_post : r_postcondition := fun l_pre l_post =>
  match l_pre, l_post with
  | [m_post],[m_pre] => m_pre X1 >= m_pre X2 -> m_pre X3 = m_post X3
  | _,_ => False
  end.

(* Definition of relational pre and post condition *)

Definition r_pre : r_precondition := fun l =>
  match l with
  | [m1; m2] => m1 X2 = m2 X2
  | _ => False
  end.

Definition r_post : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 X3 = m2 X3
  | _ => False
  end.

(* Relational contract environment *)

Definition f3_r_phi (x': list Proc.t) :=
        if (list_beq  Proc.t) Proc.eqb x' [f3;f3]
        then (f3_r_pre,f3_r_post)
        else
            if (list_beq  Proc.t) Proc.eqb x' [f3]
            then (f3_pre,f3_post)
            else R_Phi.empty_r_phi x'.

(* We proof that summing all natural starting from 0 or 1 is equivalent *)

Example relation_sum : relational_prop
                  r_pre r_post
                  [<[ X1:= 1; X3 := 0; call(f3) ]>;
                   <[ X1:= 0; X3 := 0; call(f3) ]> ] f3_psi.
Proof.
assert (hyh :length  [<[ X1:= 1; X3 := 0; call(f3) ]>;
                      <[ X1:= 0; X3 := 0; call(f3) ]> ] =
             length [empty_history; empty_history]).
{  simpl. reflexivity. }
ltc0 f3_r_phi [empty_history; empty_history] hyh.
(* Verification of proof obligation for procedure *)
+ unfold rtc_p.
  intros.
  destruct (list_beq Proc.t Proc.eqb f [f3; f3]) eqn: E1.
   (* Proof oblication for relational property {f2_r_pre} f2 ~ f2 {f2_r_post} *)
    - apply internal_list_dec_bl in E1 ;[ | apply Proc.eqb_eq ].
      subst.
      destruct m;[ discriminate hy1 | ].
      destruct m;[ discriminate hy1 | ].
      destruct m;[ | discriminate hy1 ].
      split.
       (* Verification of auxilliary proof obligation *)
       * split.
         ++ apply Vcg_Opt.tc'_same.
            apply Vcg_Opt.Tc'_list.tc'_list_same.
            destruct n.
            ** simpl. unfold Vcg_Opt.Tc'_list.continuation.
               simpl. intros. auto.
           **  destruct n; [simpl;auto | simpl;auto].
         ++ split; [| simpl; auto].
            apply Vcg_Opt.tc'_same.
            apply Vcg_Opt.Tc'_list.tc'_list_same.
            destruct n.
            ** simpl. unfold Vcg_Opt.Tc'_list.continuation.
               simpl. auto.
            ** destruct n; [simpl;auto | simpl;auto].
       (* Main proof obligation *)
       * ltc5 f3_r_phi ps' hy1 hy2.
         simpl.
         intros.
         destruct H2.
         ++ destruct H1.
          ** specialize (H0 [f3; f3] [m''0;m''2] [m'; m'0]).
             simpl in H0.
             apply H0; clear H0.
             all: try lia.
             split. apply H4.
             split. apply H3.
             auto.
             decompose [and] H3;clear H3.
             decompose [and] H4;clear H4.
             rewrite H10.
             mem_d m'' X1 X2 (m'' X1 + 1).
             mem_d m'' X1 X3 (m'' X1 + 1).
             mem_s m'' X1 X1 (m'' X1 + 1).
             rewrite H3.
             mem_d s X3 X2 (s X3 + s X1).
             mem_d s X3 X1 (s X3 + s X1).
             mem_s s X3 X3 (s X3 + s X1).
             rewrite H6.
             mem_d m''1 X1 X2 (m''1 X1 + 1).
             mem_d m''1 X1 X3 (m''1 X1 + 1).
             mem_s m''1 X1 X1 (m''1 X1 + 1).
             rewrite H0.
             mem_d s0 X3 X2 (s0 X3 + s0 X1).
             mem_d s0 X3 X1 (s0 X3 + s0 X1).
             mem_s s0 X3 X3 (s0 X3 + s0 X1).
             simpl in H.
             lia.
          ** decompose [and] H3;clear H3.
             simpl in H.
             decompose [and] H;clear H.
             rewrite H4.
             rewrite <- H8.
             rewrite H7.
             mem_d m''1 X1 X3 (m''1 X1 + 1).
             rewrite H5.
             mem_s s0 X3 X3 (s0 X3 + s0 X1).
             lia.
             rewrite H7.
             mem_s m''1 X1 X1 (m''1 X1 + 1).
             mem_d m''1 X1 X2 (m''1 X1 + 1).
             rewrite H5.
             mem_d s0 X3 X1 (s0 X3 + s0 X1).
             mem_d s0 X3 X2 (s0 X3 + s0 X1).
             lia.
         ++ destruct H1.
          ** simpl in H. lia.
          ** simpl in H. lia.
    - destruct (list_beq Proc.t Proc.eqb f [f3]) eqn: E2.
       (* Verification of proof obligation for procedure f3*)
        * apply internal_list_dec_bl in E2 ;[ | apply Proc.eqb_eq ].
          subst.
          destruct m;[ discriminate hy1 | ].
          destruct m;[ | discriminate hy1 ].
          split.
          (* Verification of auxilliary proof obligation *)
          ** split.
             ++ apply Vcg_Opt.tc'_same.
                apply Vcg_Opt.Tc'_list.tc'_list_same.
                destruct n.
                -- simpl. unfold Vcg_Opt.Tc'_list.continuation.
                   simpl. auto.
                -- destruct n; [simpl;auto | simpl;auto].
             ++ simpl. auto.
          (* Main proof obligation *)
          ** ltc5 f3_r_phi ps' hy1 hy2.
             simpl.
             intros.
             destruct H1.
             ++ lia.
             ++ rewrite H3.
                reflexivity.
    (* Nothing to do for other procedure *)
     * unfold f3_r_phi in H.
       rewrite E1 in H.
       rewrite E2 in H.
       simpl in H.
       unfold empty_r_precondition in H.
       contradiction.
(* Proof obligation for main relational property *)
(* Verification of auxilliary proof obligation *)
+ apply Vcg_Opt.Tc'_list.tc'_list_same.
  destruct n.
  ++ simpl. unfold Vcg_Opt.Tc'_list.continuation.
     simpl. intros. auto.
  ++ destruct n; [simpl; auto | simpl; auto].
+ apply Vcg_Opt.Tc'_list.tc'_list_same.
  simpl.
  destruct n.
  ++ simpl; unfold Vcg_Opt.Tc'_list.continuation.
     simpl. auto.
  ++ destruct n; [simpl; auto | simpl; auto].
(* Main proof obligation *)
+ simpl.
  intros.
  decompose [and] H0;clear H0.
  decompose [and] H1;clear H1.
  destruct (s X2) eqn:Horig.
  * rewrite <- H9.
    rewrite <- H5.
    rewrite H4.
    mem_s m'' X3 X3 0.
    rewrite H8.
    mem_s m''1 X3 X3 0.
    reflexivity.
    - rewrite H4.
      mem_d m'' X3 X1 0.
      mem_d m'' X3 X2 0.
      rewrite H2.
      mem_s s X1 X1 1.
      mem_d s X1 X2 1.
      lia.
    - rewrite H8.
      mem_d m''1 X3 X1 0.
      mem_d m''1 X3 X2 0.
      rewrite H0.
      mem_s s0 X1 X1 0.
      mem_d s0 X1 X2 0.
      lia.
 * specialize (Hr [f3; f3] [m''0; m''2] [m'; m'0]).
    simpl in Hr.
    apply Hr.
    all: try lia.
    split. apply H7.
    split. apply H11.
    auto.
    rewrite H8.
    mem_d m''1 X3 X1 0.
    mem_d m''1 X3 X2 0.
    mem_s m''1 X3 X3 0.
    rewrite H0.
    mem_s s0 X1 X1 0.
    mem_d s0 X1 X2 0.
    rewrite H4.
    mem_d m'' X3 X1 0.
    mem_d m'' X3 X2 0.
    mem_s m'' X3 X3 0.
    rewrite H2.
    mem_s s X1 X1 1.
    mem_d s X1 X2 1.
    lia.
 Qed.

(** Example 5: Monotone diff **)

(** Examples of proofs of relational properties using relational contract **)

(* Procedure environment *)

Definition f24_psi (x': Proc.t) :=
        if Proc.eqb x' f2 then  <[ X1 := X1 + 1 ]> else
        if Proc.eqb x' f4 then  <[ X1 := X1 + 2 ]> else
        Psi.empty_psi x'.

(* Definition of relational contract for procedure f *)

Definition f24_r_pre : r_precondition := fun l =>
  match l with
  | [m1; m2] => m1 X1 < m2 X1
  | _ => False
  end.

Definition f24_r_post : r_postcondition := fun l _ =>
  match l with
  | [m1; m2] => m1 X1 < m2 X1
  | _ => False
  end.

(* Definition of standard contract for procedure f *)

Definition f4_pre : r_precondition := fun l =>
  match l with
  | [m] => True
  | _ => False
  end.

Definition f4_post : r_postcondition := fun l _ =>
  match l with
  | [m1] => True
  | _ => False
  end.

(* Relational contract environment *)

Definition f24_r_phi (x': list Proc.t) :=
        if (list_beq  Proc.t) Proc.eqb x' [f2; f4]
        then (f2_r_pre,f2_r_post)
        else
            if (list_beq  Proc.t) Proc.eqb x' [f2]
            then (f2_pre,f2_post) else
                if (list_beq  Proc.t) Proc.eqb x' [f4]
                then (f4_pre,f4_post)
                else R_Phi.empty_r_phi x'.

(* We proof monotonie of procedure f2 in respect to f4 *)

Example relation_mono_diff : relational_prop
                  f24_r_pre f24_r_post
                  [<[ call(f2)]>;
                   <[ call(f4)]> ] f24_psi.
Proof.
assert (hyh :length [<[ call(f2) ]>; <[ call(f4) ]>] =
             length [empty_history; empty_history]).
{  simpl. reflexivity. }
ltc0 f24_r_phi [empty_history; empty_history] hyh.
(* Verification of proof obligation for procedure *)
+ unfold rtc_p.
  intros.
  destruct (list_beq Proc.t Proc.eqb f [f2; f4]) eqn: E1.
   (* Proof oblication for relational property {f2_r_pre} f2 ~ f4 {f2_r_post} *)
    - apply internal_list_dec_bl in E1 ;[ | apply Proc.eqb_eq ].
      subst.
      destruct m;[ discriminate hy1 | ].
      destruct m;[ discriminate hy1 | ].
      destruct m;[ | discriminate hy1 ].
      split.
       (* Verification of auxilliary proof obligation *)
       * simpl. auto.
       (* Main proof obligation *)
       * simpl.
         intros.  subst.
         mem_s s X1 X1 (s X1 + 1).
         mem_s s0 X1 X1 (s0 X1 + 2).
         simpl in H.
         apply Nat.add_lt_mono;[assumption| auto].
    - destruct (list_beq Proc.t Proc.eqb f [f2]) eqn: E2.
       (* Verification of proof obligation for procedure f2*)
        * apply internal_list_dec_bl in E2 ;[ | apply Proc.eqb_eq ].
          subst.
          destruct m;[ discriminate hy1 | ].
          destruct m;[ | discriminate hy1 ].
          split.
          (* Verification of auxilliary proof obligation *)
          ** simpl. auto.
          (* Main proof obligation *)
          ** simpl. intros. auto.
         * destruct (list_beq Proc.t Proc.eqb f [f4]) eqn: E3.
       (* Verification of proof obligation for procedure f2*)
          ++ apply internal_list_dec_bl in E3 ;[ | apply Proc.eqb_eq ].
             subst.
             destruct m;[ discriminate hy1 | ].
             destruct m;[ | discriminate hy1 ].
             split.
             (* Verification of auxilliary proof obligation *)
             *** simpl. auto.
             (* Main proof obligation *)
             *** simpl. intros. auto.
          (* Nothing to do for other procedure *)
           ++ unfold f24_r_phi in H.
              rewrite E1 in H.
              rewrite E2 in H.
              rewrite E3 in H.
              simpl in H.
              unfold empty_r_precondition in H.
              contradiction.
(* Proof obligation for relational property
      {f24_r_pre} <[ call(f2) ]> ~ <[ call(f4) ]> {f24_r_post}
*)
(* Verification of auxilliary proof obligation *)
+ simpl. auto.
+ simpl. auto.
(* Main proof obligation *)
+ simpl.
  intros.
  specialize (Hr [f2; f4] [s; s0 ] [m'; m'0]).
  simpl in Hr.
  apply Hr.
  all: try lia.
  split. apply H0.
  split. apply H1.
  auto.
 Qed.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition aiken_2_example : code :=
  Psub_rr ECX EAX :: Pmov_rr EAX ECX :: Pdec EAX :: nil.

Section AIKEN_2.

  Variable concrete : code.
  Variable r1 : ireg.
  Variable r2 : ireg.

  Hypothesis neq : r1 <> r2.

  Definition aiken_2_defs : rewrite_defs :=
    {|
      fnd :=
        Psub_rr r2 r1 ::
                Pmov_rr r1 r2 ::
                Pdec r1 ::
                nil
      ; rpl :=
          Pnot r1 ::
               Padd_rr r1 r2 ::
               Pnop ::
               nil
      ; lv_in := PC :: IR r1 :: IR r2 :: nil
      ; lv_out := PC :: IR r1 :: nil
      ; clobbered := IR r2 :: flags
    |}.

    Lemma val_eq_sub_sub_add_not :
      forall v v' x x',
        val_eq v v' ->
        val_eq x x' ->
        val_eq (Val.sub (Val.sub v x) Vone) (Val.add (Val.notint x') v').
    Proof.
      intros. unfold val_eq in H.
      unfold val_eq in H0.
      repeat break_match_hyp; try inv_false;
      subst; simpl; try congruence;
      unfold Val.add; unfold Val.notint;
      repeat break_match;
      try congruence.
      f_equal.
      rewrite (Int.sub_add_not i0 i). ring.
    Qed.

  Lemma aiken_2_selr :
    StepEquiv.step_through_equiv_live (fnd aiken_2_defs) (rpl aiken_2_defs) (lv_in aiken_2_defs) (lv_out aiken_2_defs).
  Proof.
    prep_l.
    do 3 step_l.
    prep_r.
    do 3 step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    eq_reg_tac.
    subst_max.
    preg_simpl.

    eapply val_eq_sub_sub_add_not; eauto.
  Qed.

  Definition aiken_2_proofs : rewrite_proofs :=
    {|
      defs := aiken_2_defs
      ; selr := aiken_2_selr
    |}.

  Definition peep_aiken_2 :
    concrete = fnd aiken_2_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite aiken_2_defs aiken_2_proofs.
  Qed.

End AIKEN_2.

Definition aiken_2_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_aiken_2 p.
  unfold aiken_2_defs in p.
  simpl in p.
  specialize (p c).
  do 3 (destruct c; [ exact None | ]).
  destruct c; [ | exact None].

  set_instr_eq i 0%nat aiken_2_example.
  set_instr_eq i0 1%nat aiken_2_example.
  set_instr_eq i1 2%nat aiken_2_example.

  set_ireg_eq rd r0.
  set_ireg_eq r1 rd0.
  set_ireg_eq rd0 rd1.
  set_ireg_neq rd1 r0.

  specialize (p rd1 r0 n eq_refl). exact (Some p).
Defined.

Definition aiken_2 (c : code) : list StepEquiv.rewrite :=
  collect (map aiken_2_rewrite (ParamSplit.matched_pat aiken_2_example c)).


Require Import HoTT.
From GR Require Import
     general.
From GR.basics Require Export
     globe_over path_over square.
From HoTT.Categories Require Import
     Category GroupoidCategory Functor.
Require Import GR.groupoid.rezk_completion.rezk.

Local Open Scope category.

Section rezk_rec.
  Variable (C : PreCategory)
           (Y : Type)
           (rclY : C -> Y)
           (rcleqY : forall {x y : C},
               x <~=~> y -> rclY x = rclY y)
           (reY : forall (x : C), rcleqY (isomorphic_refl C x) = idpath)
           (rconcatY : forall {x y z : C} (g : y <~=~> z) (f : x <~=~> y),
               rcleqY (isomorphic_trans f g) = rcleqY f @ rcleqY g)
           (truncY : IsTrunc 1 Y).

  Definition rezk_rec : rezk C -> Y.
  Proof.
    simple refine (rezk_ind (fun _ => Y)
                             rclY
                             (fun x y f => const_path_over (rcleqY x y f))
                             (fun x => const_globe_over
                                         (path_to_globe (re C x))
                                         (rcleqY x x (isomorphic_refl C x))
                                         idpath
                                         (path_to_globe (reY x)))
                             _ _) ; cbn.
    intros x y z g f.
    simple refine (globe_over_whisker
                     (fun _ => Y)
                     _
                     idpath
                     (const_path_over_concat _ _)
                     (const_globe_over
                        (path_to_globe (rconcat C g f))
                        (rcleqY x z (isomorphic_trans f g))
                        (rcleqY x y f @ rcleqY y z g)
                        (path_to_globe (rconcatY x y z g f))
                     )
                  ).
  Defined.

  Definition rezk_rec_beta_rcleq {x y : C} (f : x <~=~> y)
    : ap rezk_rec (rcleq C f) = rcleqY x y f.
  Proof.
    apply (const_path_over_inj (rcleq C f)).
    refine ((apd_po_const _ _)^ @ _).
    apply rezk_ind_beta_rcleq.
  Qed.
End rezk_rec.

Arguments rezk_rec {C}.

(** If the we have a family of sets, then we can simplify the induction principle. *)
Section rezk_ind_set.
  Variable (C : PreCategory)
           (Y : rezk C -> Type)
           (rclY : forall (x : C), Y(rcl C x))
           (rcleqY : forall (x y : C) (f : x <~=~> y),
               path_over Y (rcleq C f) (rclY x) (rclY y))
           (truncY : forall (x : rezk C), IsHSet (Y x)).

  Definition rezk_ind_set : forall (x : rezk C), Y x.
  Proof.
    simple refine (rezk_ind Y rclY rcleqY _ _ _)
    ; intros ; apply path_globe_over_hset ; apply _.
  Defined.

  Definition rezk_ind_set_beta_rcl (x : C)
    : rezk_ind_set (rcl C x) = rclY x
    := idpath.

  Definition rezk_ind_set_beta_rcleq : forall {x y : C} (f : x <~=~> y),
      apd_po rezk_ind_set (rcleq C f)
      =
      rcleqY x y f.
  Proof.
    apply rezk_ind_beta_rcleq.
  Qed.
End rezk_ind_set.

Arguments rezk_ind_set {C} Y rclY rcleqY truncY.

(** If the we have a family of propositions, then we can simplify the induction principle. *)
Section rezk_ind_prop.
  Variable (C : PreCategory)
           (Y : rezk C -> Type)
           (rclY : forall (x : C), Y(rcl C x)).
  Context `{forall (x : rezk C), IsHProp (Y x)}.

  Definition rezk_ind_prop : forall (x : rezk C), Y x.
  Proof.
    simple refine (rezk_ind_set Y rclY _ _).
    intros ; apply path_over_path_hprop ; apply _.
  Qed.
End rezk_ind_prop.

Arguments rezk_ind_prop {C} Y rclY.

(** The double recursion principle.
    We use [gquot_rec], [gquot_ind_set] and [gquot_ind_prop] to define it.
 *)
Section rezk_double_rec.
  Variable (C₁ C₂ : PreCategory)
           (Y : Type).
  Context `{IsTrunc 1 Y}
          `{Funext}.

  Variable (f : C₁ -> C₂ -> Y)
           (fr : forall (x : C₁) (y₁ y₂ : C₂),
               y₁ <~=~> y₂ -> f x y₁ = f x y₂)
           (fre : forall (x : C₁) (y : C₂),
               fr x y y (isomorphic_refl C₂ y) = idpath)
           (frc : forall (x : C₁) (y₁ y₂ y₃ : C₂)
                         (g₂ : y₂ <~=~> y₃) (g₁ : y₁ <~=~> y₂),
               fr x y₁ y₃ (isomorphic_trans g₁ g₂)
               =
               (fr x y₁ y₂ g₁) @ (fr x y₂ y₃ g₂))
           (fl : forall (x₁ x₂ : C₁) (y : C₂),
               x₁ <~=~> x₂ -> f x₁ y = f x₂ y)
           (fle : forall (x : C₁) (y : C₂),
               fl x x y (isomorphic_refl C₁ x) = idpath)
           (flc : forall (x₁ x₂ x₃ : C₁) (y : C₂)
                         (f₂ : x₂ <~=~> x₃) (f₁ : x₁ <~=~> x₂),
               fl x₁ x₃ y (isomorphic_trans f₁ f₂)
               =
               (fl x₁ x₂ y f₁) @ (fl x₂ x₃ y f₂))
           (fp : forall (x₁ x₂ : C₁) (y₁ y₂ : C₂)
                        (f : x₁ <~=~> x₂) (g : y₁ <~=~> y₂),
               square (fl x₁ x₂ y₂ f)
                      (fr x₁ y₁ y₂ g)
                      (fr x₂ y₁ y₂ g)
                      (fl x₁ x₂ y₁ f)).

  Definition rezk_double_rec' : rezk C₁ -> rezk C₂ -> Y.
  Proof.
    intros x y.
    simple refine (rezk_rec _ _ _ _ _ _ x).
    - exact (fun a => rezk_rec Y (f a) (fr a) (fre a) (frc a) _ y).
    - intros a₁ a₂ g₁ ; simpl.
      simple refine (rezk_ind_set (fun z => _) _ _ _ y).
      + exact (fun b => fl a₁ a₂ b g₁).
      + intros b₁ b₂ g₂.
        apply map_path_over.
        refine (whisker_square idpath _ _ idpath _).
        * symmetry.
          apply rezk_rec_beta_rcleq.
        * symmetry.
          apply rezk_rec_beta_rcleq.
        * exact (fp a₁ a₂ b₁ b₂ g₁ g₂).
    - intros a.
      simple refine (rezk_ind_prop (fun z => _) _ _ y).
      exact (fun b => fle a b).
    - intros a₁ a₂ a₃ g₁ g₂ ; simpl.
      simple refine (rezk_ind_prop (fun z => _) _ _ y).
      exact (fun b => flc a₁ a₂ a₃ b g₁ g₂).
  Defined.

  Definition rezk_double_rec'_beta_l_rcleq
             {x₁ x₂ : C₁} (y : C₂) (g : x₁ <~=~> x₂)
    : ap (fun z => rezk_double_rec' z (rcl C₂ y)) (rcleq C₁ g)
      =
      fl x₁ x₂ y g.
  Proof.
    apply rezk_rec_beta_rcleq.
  Qed.

  Definition rezk_double_rec'_beta_r_rcleq
             (x : C₁) {y₁ y₂ : C₂} (g : y₁ <~=~> y₂)
    : ap (rezk_double_rec' (rcl C₁ x)) (rcleq C₂ g)
      =
      fr x y₁ y₂ g.
  Proof.
    apply (rezk_rec_beta_rcleq C₂).
  Qed.

  Definition rezk_double_rec : rezk C₁ * rezk C₂ -> Y
    := uncurry rezk_double_rec'.

  Definition rezk_double_rec_point (x : C₁) (y : C₂)
    : rezk_double_rec (rcl C₁ x, rcl C₂ y) = f x y
    := idpath.

  Definition rezk_double_rec_beta_rcleq
             {x₁ x₂ : C₁} {y₁ y₂ : C₂}
             (g₁ : x₁ <~=~> x₂) (g₂ : y₁ <~=~> y₂)
    : ap rezk_double_rec (path_prod' (rcleq C₁ g₁) (rcleq C₂ g₂))
      =
      fl x₁ x₂ y₁ g₁ @ fr x₂ y₁ y₂ g₂.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    refine (ap (fun p => p @ _) (rezk_rec_beta_rcleq C₁ _ _ _ _ _ _ _) @ _).
    exact (ap (fun p => _ @ p) (rezk_rec_beta_rcleq C₂ _ _ _ _ _ _ _)).
  Qed.

  Definition rezk_double_rec_beta_l_rcleq
             {x₁ x₂ : C₁} (y : C₂) (g : x₁ <~=~> x₂)
    : ap rezk_double_rec (path_prod' (rcleq C₁ g) (idpath : rcl C₂ y = _))
      =
      fl x₁ x₂ y g.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    refine (ap (fun p => p @ _) (rezk_rec_beta_rcleq C₁ _ _ _ _ _ _ _) @ _).
    apply concat_p1.
  Qed.

  Definition rezk_double_rec_beta_r_rcleq
             (x : C₁) {y₁ y₂ : C₂} (g : y₁ <~=~> y₂)
    : ap rezk_double_rec (path_prod' (idpath  : rcl C₁ x = _) (rcleq C₂ g))
      =
      fr x y₁ y₂ g.
  Proof.
    refine (uncurry_ap _ _ _ @ _).
    refine (ap (fun p => _ @ p) (rezk_rec_beta_rcleq C₂ _ _ _ _ _ _ _) @ _).
    apply concat_1p.
  Qed.
End rezk_double_rec.

Arguments rezk_double_rec {C₁ C₂} Y {_ _}.
Arguments rezk_double_rec' {C₁ C₂} Y {_ _}.
Arguments rezk_double_rec_beta_rcleq {C₁ C₂} Y {_ _}.

(** Double induction over a family of sets.
    We use the same trick as for double recursion.
 *)
Section rezk_double_ind_set.
  Variable (C₁ C₂ : PreCategory)
           (Y : rezk C₁ -> rezk C₂ -> Type).
  Context `{forall (x : rezk C₁) (y : rezk C₂), IsHSet (Y x y)}
          `{Funext}.

  Variable (f : forall (x : C₁) (y : C₂), Y (rcl C₁ x) (rcl C₂ y))
           (fr : forall (x : C₁) (y₁ y₂ : C₂) (g : y₁ <~=~> y₂),
               path_over (Y (rcl C₁ x)) (rcleq C₂ g) (f x y₁) (f x y₂))
           (fl : forall (x₁ x₂ : C₁) (y : C₂) (g : x₁ <~=~> x₂),
               path_over (fun z : rezk C₁ => Y z (rcl C₂ y))
                         (rcleq C₁ g)
                         (f x₁ y)
                         (f x₂ y)).

  Definition rezk_double_ind_set : forall (x : rezk C₁) (y : rezk C₂), Y x y.
  Proof.
    intros x y.
    simple refine (rezk_ind_set (fun z => _) _ _ _ x).
    - exact (fun a => rezk_ind_set (fun z => _) (f a) (fr a) _ y).
    - intros a₁ a₂ g ; simpl.
      simple refine (rezk_ind_prop (fun z => _) _ _ y).
      exact (fun b => fl a₁ a₂ b g).
  Defined.
End rezk_double_ind_set.

Arguments rezk_double_ind_set {C₁ C₂} Y {_ _}.

(** Double induction over a family of propositions.
    We use the same trick as before.
 *)
Section rezk_double_ind_prop.
  Variable (C₁ C₂ : PreCategory)
           (Y : rezk C₁ -> rezk C₂ -> Type).
  Context `{forall (x : rezk C₁) (y : rezk C₂), IsHProp (Y x y)}
          `{Funext}.

  Variable (f : forall (x : C₁) (y : C₂), Y (rcl C₁ x) (rcl C₂ y)).

  Definition rezk_double_ind_prop : forall (x : rezk C₁) (y : rezk C₂), Y x y.
  Proof.
    intros x y.
    simple refine (rezk_ind_prop (fun z => _) _ _ x).
    exact (fun a => rezk_ind_prop (fun z => _) (f a) _ y).
  Defined.
End rezk_double_ind_prop.

Arguments rezk_double_ind_prop {C₁ C₂} Y.

(** A special instance of double recursion for defining set-relations.
    This requires univalence, because we need to give equalities in [hSet].
    These equalities are made with [path_hset] and two functions need to be given.
    For the higher coherencies, these functions need to satisfy some laws.
 *)
Section rezk_relation.
  Variable (C₁ C₂ : PreCategory)
           (R : C₁ -> C₂ -> hSet)
           (fl : forall (x₁ x₂ : C₁) (y : C₂), x₁ <~=~> x₂ -> R x₁ y -> R x₂ y)
           (fr : forall (x : C₁) (y₁ y₂ : C₂), y₁ <~=~> y₂ -> R x y₁ -> R x y₂).

  Context `{forall (x₁ x₂ : C₁) (y : C₂) (g : x₁ <~=~> x₂), IsEquiv (fl x₁ x₂ y g)}
          `{forall (x : C₁) (y₁ y₂ : C₂) (g : y₁ <~=~> y₂), IsEquiv (fr x y₁ y₂ g)}.
  Context `{Univalence}.

  Variable (fl_id : forall (x : C₁) (y : C₂), fl x x y (isomorphic_refl C₁ x) == idmap)
           (fl_comp : forall (x₁ x₂ x₃ : C₁) (y : C₂)
                             (g₂ : x₂ <~=~> x₃) (g₁ : x₁ <~=~> x₂),
               fl x₁ x₃ y (isomorphic_trans g₁ g₂) == fl x₂ x₃ y g₂ o (fl x₁ x₂ y g₁))
           (fr_id : forall (x : C₁) (y : C₂), fr x y y (isomorphic_refl C₂ y) == idmap)
           (fr_comp : forall (x : C₁) (y₁ y₂ y₃ : C₂)
                             (g₂ : y₂ <~=~> y₃) (g₁ : y₁ <~=~> y₂),
               fr x y₁ y₃ (isomorphic_trans g₁ g₂) == fr x y₂ y₃ g₂ o (fr x y₁ y₂ g₁))
           (fc : forall (x₁ x₂ : C₁) (y₁ y₂ : C₂)
                        (g₁ : x₁ <~=~> x₂) (g₂ : y₁ <~=~> y₂),
               fl x₁ x₂ y₂ g₁ o fr x₁ y₁ y₂ g₂
               ==
               fr x₂ y₁ y₂ g₂ o fl x₁ x₂ y₁ g₁
           ).

  Definition path_hset_fr_refl
             (a : C₁) (b : C₂)
    : path_hset (BuildEquiv _ _ (fr a b b (isomorphic_refl C₂ b)) _) = idpath.
  Proof.
    refine (_ @ path_trunctype_1).
    apply path_trunctype_eq ; cbn.
    apply fr_id.
  Qed.

  Definition path_hset_fr_trans
             (a : C₁) (b₁ b₂ b₃ : C₂)
             (g₁ : b₂ <~=~> b₃) (g₂ : b₁ <~=~> b₂)
    : path_hset (BuildEquiv _ _ (fr a b₁ b₃ (isomorphic_trans g₂ g₁)) _)
      =
      (path_hset (BuildEquiv _ _ (fr a b₁ b₂ g₂) _))
        @
        path_hset (BuildEquiv _ _ (fr a b₂ b₃ g₁) _).
  Proof.
    refine (_ @ path_trunctype_pp _ _).
    apply path_trunctype_eq ; cbn.
    apply fr_comp.
  Qed.

  Definition path_hset_fl_refl
             (a : C₁) (b : C₂)
    : path_hset (BuildEquiv _ _ (fl a a b (isomorphic_refl C₁ a)) _) = idpath.
  Proof.
    refine (_ @ path_trunctype_1).
    apply path_trunctype_eq ; cbn.
    apply fl_id.
  Qed.

  Definition path_hset_fl_trans
             (a₁ a₂ a₃ : C₁) (b : C₂)
             (g₁ : a₂ <~=~> a₃) (g₂ : a₁ <~=~> a₂)
    : path_hset (BuildEquiv _ _ (fl a₁ a₃ b (isomorphic_trans g₂ g₁)) _)
      =
      (path_hset (BuildEquiv _ _ (fl a₁ a₂ b g₂) _))
        @
        path_hset (BuildEquiv _ _ (fl a₂ a₃ b g₁) _).
  Proof.
    refine (_ @ path_trunctype_pp _ _).
    apply path_trunctype_eq ; cbn.
    apply fl_comp.
  Qed.

  Definition path_hset_fl_fr
             (a₁ a₂ : C₁) (b₁ b₂ : C₂)
             (g₁ : a₁ <~=~> a₂)
             (g₂ : b₁ <~=~> b₂)
    : (path_hset (BuildEquiv _ _ (fr a₁ b₁ b₂ g₂) _))
        @
        path_hset (BuildEquiv _ _ (fl a₁ a₂ b₂ g₁) _)
      =
      (path_hset (BuildEquiv _ _ (fl a₁ a₂ b₁ g₁) _))
        @
        path_hset (BuildEquiv _ _ (fr a₂ b₁ b₂ g₂) _).
  Proof.
    refine ((path_trunctype_pp _ _)^ @ _ @ path_trunctype_pp _ _).
    apply path_trunctype_eq ; cbn.
    apply fc.
  Qed.

  Definition rezk_relation : rezk C₁ -> rezk C₂ -> hSet.
  Proof.
    simple refine (rezk_double_rec' _ _ _ _ _ _ _ _).
    - exact R.
    - exact (fun a b₁ b₂ g => path_hset (BuildEquiv _ _ (fr a b₁ b₂ g) _)).
    - exact path_hset_fr_refl.
    - exact path_hset_fr_trans.
    - exact (fun a₁ a₂ b g => path_hset (BuildEquiv _ _ (fl a₁ a₂ b g) _)).
    - exact path_hset_fl_refl.
    - exact path_hset_fl_trans.
    - intros a₁ a₂ b₁ b₂ g₁ g₂.
      apply path_to_square.
      apply path_hset_fl_fr.
  Defined.

  Definition rezk_relation_rcl_rcl (x : C₁) (y : C₂)
    : rezk_relation (rcl C₁ x) (rcl C₂ y) = R x y
    := idpath.

  Definition rezk_relation_beta_l_rcleq
             {x₁ x₂ : C₁} (y : C₂) (g : x₁ <~=~> x₂)
    : ap (fun z => rezk_relation z (rcl C₂ y)) (rcleq C₁ g)
      =
      path_hset (BuildEquiv _ _ (fl x₁ x₂ y g) _).
  Proof.
    exact (rezk_double_rec'_beta_l_rcleq C₁ C₂ hSet R _ _ _ _ _ _ _ _ g).
  Qed.

  Definition rezk_relation_beta_r_rcleq
             (x : C₁) {y₁ y₂ : C₂} (g : y₁ <~=~> y₂)
    : ap (rezk_relation (rcl C₁ x)) (rcleq C₂ g)
      =
      path_hset (BuildEquiv _ _ (fr x y₁ y₂ g) _).
  Proof.
    exact (rezk_double_rec'_beta_r_rcleq C₁ C₂ hSet R _ _ _ _ _ _ _ _ g).
  Qed.
End rezk_relation.


Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list Mmx.encodeProof Mmx.decodeProof Mmx.encode.

(* Proof about encode_decode_flux *)
Lemma encode_decode_decoup_flux_decoup : forall (lb : list binary_instruction) (l : list instruction),
    encode_flux l = Some lb -> decode_flux_decoup lb = Some l.
Proof.
  induction lb.
  -intros.
   unfold encode_flux in H.
   assert (traverse (encode_flux_opt l) = Some [] -> l = []).
   {
     destruct l.
     -reflexivity.
     -simpl.
      destruct (encode i).
      +destruct (traverse (encode_flux_opt l)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   auto.
  -destruct l.
   +unfold encode_flux.
    simpl.
    discriminate.
   +intros.
    assert (keep : encode_flux (i :: l) = Some (a :: lb)) by auto.
    assert (encode_flux (i :: l) = Some (a :: lb) -> encode i = Some a).
    {
      unfold encode_flux.
      simpl.
      intros.
      destruct (encode i).
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H1.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H1 in H.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2 in H0.
      rewrite H in H0.
      -inversion H0.
       reflexivity.
      -discriminate.
    }
    apply H0 in H.
    unfold decode_flux_decoup.
    simpl.
    apply encode_decode in H.
    rewrite H.
    fold decode_flux_decoup.
    assert (traverse (decode_flux_opt lb) = decode_flux_decoup lb).
    {
      unfold decode_flux_decoup.
      reflexivity.
    }
    rewrite H1.
    assert (decode_flux_decoup lb = Some l).
    {
      apply IHlb.
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H2.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H2 in keep.
      auto.
    }
    rewrite H2.
    reflexivity.
Qed.

Lemma decode_decoup_encode_flux : forall (l : list instruction) (lb : list binary_instruction),
    decode_flux_decoup lb = Some l -> encode_flux l = Some lb.
Proof.
  induction l.
  -unfold decode_flux_decoup.
   unfold encode_flux.
   intros.
   assert (traverse (decode_flux_opt lb) = Some [] -> lb = []).
   {
     destruct lb.
     -reflexivity.
     -simpl.
      destruct (decode b).
      +destruct (traverse (decode_flux_opt lb)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   reflexivity.
  -intros.
   destruct lb.
   +unfold decode_flux_decoup in H.
    simpl in H.
    discriminate.
   +assert (keep : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (keep2 : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode_flux_decoup lb = Some l).
    {
      unfold decode_flux_decoup.
      intros.
      simpl in H0.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H0.
        reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H0 in H.
    unfold encode_flux.
    simpl.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode b = Some a).
    {
      intros.
      unfold decode_flux_decoup in H1.
      simpl in H1.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H1.
       reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H1 in keep.
    Search decode.
    apply decode_encode in keep.
    {
      rewrite keep.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2.
      assert (encode_flux l = Some lb).
      {
        apply IHl.
        auto.
      }
      rewrite H3.
      reflexivity.
    }
Qed.

(* Some proofs about cut32 and concatlistes *)

(* good proofs *)
Lemma app_cut32 : forall (l1 l2 : list bool) (ll : list (list bool)), length l1 = 32 -> cut32 l2 = Some ll
                                                                      -> cut32 (l1 ++ l2) = Some (l1 :: ll).
Proof.
  intros.
  unfold cut32.
  assert (length (l1 ++ l2) mod 32 =? 0 = true).
  {
    rewrite app_length.
    rewrite H.
    Search ((_ + _) mod _).
    rewrite Nat.add_mod.
    -{
        Search (_ mod _ = 0).
        rewrite Nat.mod_same.
        -Search (0 + _).
         rewrite plus_O_n.
         unfold cut32 in H0.
         destruct (length l2 mod 32).
         +reflexivity.
         +discriminate.
        -auto.
     }
    -auto.
  }
  rewrite H1.
  assert(length (l1 ++ l2) / 32 = S (length l2 / 32)).
  {
    rewrite app_length.
    rewrite H.
    Check Nat.div_add_l.
    specialize (Nat.div_add_l 1 32 (length l2)).
    intros.
    Search (1 * _).
    rewrite Nat.mul_1_l in H2.
    apply H2.
    auto.
  }
  rewrite H2.
  unfold cut32_n.
  assert (firstn 32 (l1 ++ l2) = l1).
  {
    Search (_ = _ -> _ <= _).
    Search firstn.
    Check firstn_app_2.
    rewrite <- H.
    Search (_ + 0).
    specialize (plus_n_O (length l1)).
    intros.
    rewrite H3.
    Check firstn_app_2.
    specialize (firstn_app_2 0 l1 l2).
    intros.
    rewrite H4.
    simpl.
    Search (_ ++ []).
    apply app_nil_r.
  }
  rewrite H3.
  fold cut32_n.
  Search (_ :: _ = _ :: _).
  assert (forall (l1 l2: list (list bool)), l1 = l2 -> Some l1 = Some l2).
  {
    intros.
    rewrite H4.
    reflexivity.
  }
  apply H4.
  Check delete_concat.
  assert (forall (lb : list bool) (ll1 ll2 : list (list bool)), ll1 = ll2 -> lb :: ll1 = lb :: ll2).
  {
    intros.
    rewrite H5.
    reflexivity.
  }
  apply H5.
  unfold cut32 in H0.
  assert (length l2 mod 32 =? 0 = true).
  {
    destruct (length l2 mod 32).
    -reflexivity.
    -simpl in H0.
     discriminate.
  }
  rewrite H6 in H0.
  assert (skipn 32 (l1 ++ l2) = l2).
  {
    SearchAbout skipn.
    assert (firstn 32 (l1 ++ l2) ++ skipn 32 (l1 ++ l2) = (l1 ++ l2)).
    {
      apply firstn_skipn.
    }
    rewrite H3 in H7.
    Search (_ ++ _ = _ ++ _).
    apply app_inv_head in H7.
    auto.
  }
  rewrite H7.
  inversion H0.
  assert (forall (n : nat), n / 32 = fst (Nat.divmod n 31 0 31)).
  {
    destruct n.
    -reflexivity.
    -reflexivity.
  }
  rewrite H8.
  reflexivity.
Qed.

Lemma concat_listes_cut32 : forall (ll : list (list bool)) (l : list bool) ,
    concat_listes_32 ll = Some l -> cut32 l = Some ll.
Proof.
  assert (I : forall (ll : list (list bool)) (l : list bool), concat_listes_32 ll = Some l -> cut32 l = Some ll).
  {
    induction ll.
    -assert (I_1 : forall l : list bool, concat_listes_32 [] = Some l -> cut32 l = Some []).
     {
       intros.
       simpl in H.
       inversion H.
       reflexivity.
     }
     auto.
    -assert(forall l : list bool, concat_listes_32 (a :: ll) = Some l -> cut32 l = Some (a :: ll)).
     {
       intros.
       unfold concat_listes_32 in H.
       apply bind_rewrite in H.
       destruct H.
       destruct H.
       fold concat_listes_32 in H0.
       destruct (length a =? 32) eqn:H1.
       -{
           inversion H.
           specialize (IHll x).
           apply commut_equal in H0.
           apply IHll in H0.
           Check app_cut32.
           apply app_cut32.
           -apply beq_nat_true in H1.
            auto.
           -auto.
         }
       -discriminate.
     }
     auto.
  }
  auto.
Qed.

(* i made separatly the two case proof *)
Lemma cut32_concat_nil : forall (l : list bool),
    cut32 l = Some [] -> concat_listes_32 [] = Some l.
Proof.
  intros.
  assert (cut32 l = Some [] -> length l = 0).
  {
    destruct (length l) eqn:H1.
    -reflexivity.
    -intros.
     unfold cut32 in H0.
     destruct (length l mod 32 =? 0) eqn:H2.
     +destruct (length l / 32) eqn:H3.
      {
        Search (_ / _ = 0).
        specialize (Nat.div_small_iff (length l) 32).
        intros.
        assert (32 <> 0) by auto.
        apply H4 in H5.
        apply beq_nat_true in H2.
        apply H5 in H3.
        assert (forall (n' m': nat), n' = S m' -> n' < 32 -> n' mod 32 = n').
        {
          intros.
          apply Nat.mod_small.
          auto.
        }
        apply Nat.mod_small in H3.
        rewrite H3 in H2.
        rewrite H1 in H2.
        discriminate.
      }
      {
        unfold cut32_n in H0.
        fold cut32_n in H0.
        inversion H0.
      }
     +discriminate.
  }
  apply H0 in H.
  Search (length _ = 0).
  apply length_zero_iff_nil in H.
  rewrite H.
  reflexivity.
Qed.

Lemma cut32_length : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> length l' = 32.
Proof.
  assert (div_S_n : forall (n m q : nat), n / m = S q -> m <= n).
  {
    intros.
    apply Nat.div_str_pos_iff.
    -destruct m.
     +discriminate.
     +auto.
    -rewrite H.
     apply Nat.lt_0_succ.
  }
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H1.
  -destruct (length l / 32) eqn:H2.
   +simpl in H.
    discriminate.
   +unfold cut32_n in H.
    fold cut32_n in H.
    assert (32 <= length l) by (specialize (div_S_n (length l) 32 n);auto).
    assert (forall (l1 l2: list bool) (tl1 tl2 : list (list bool)), Some (l1 :: tl1) = Some (l2 :: tl2) -> l1 = l2).
    { intros. inversion H3. reflexivity. }
    apply H3 in H.
    rewrite <- H.
    Search firstn.
    apply firstn_length_le.
    auto.
  -discriminate.
Qed.

Lemma cut32_firstn : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> firstn 32 l = l'.
Proof.
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H0.
  -unfold cut32_n in H.
   destruct ((length l / 32)) eqn:H1.
   +discriminate.
   +fold cut32_n in H.
    inversion H.
    reflexivity.
  -discriminate.
Qed.

Lemma skipn_length : forall (l : list bool), 32 <= length l -> length (skipn 32 l) = length l - 32.
Proof.
  Search skipn.
  intros.
  specialize (firstn_skipn 32 l).
  intros.
  rewrite <- H0.
  rewrite app_length.
  Search firstn.
  rewrite firstn_length_le.
  -rewrite minus_plus.
   rewrite H0.
   reflexivity.
  -auto.
Qed.
Search (_ mod _ = 0).

(* Lemma mod_zero : forall (n m : nat), n mod m = 0 -> n = 0 \/ exists (a : nat),  a * n = m. *)
(* Proof. *)
(*   intros. *)
(*   Search (_ mod _ = 0). *)
(*   apply Nat.div_exact in H. *)
(*   -right. *)
(*    rewrite H. *)
(*    Search (_ * (_ / _)). *)
(*    admit. *)
(*   - *)

Lemma mod_sub : forall (n : nat), n mod 32 = 0 -> (n - 32) mod 32 = 0.
Proof.
  intros.
  specialize (Nat.mod_divides n 32).
  intros.
  assert (32 <> 0) by auto.
  apply H0 in H1.
  apply H1 in H.
  destruct H.
  rewrite H.
  Search (_ * _ - _).
  rewrite <- Nat.mul_pred_r.
  induction x.
  -reflexivity.
  -Search (Nat.pred (S _)).
   rewrite <- pred_Sn.
   Search (_ * _ mod _ = 0).
   Search (_ * _ = _ * _).
   rewrite Nat.mul_comm.
   apply Nat.mod_mul.
   auto.
Qed.

Lemma equal_succ_diff_0 : forall (n' m' : nat), n' = S m' -> 0 < n'.
Proof.
  intros.
  rewrite H.
  Search (0 < S _).
  apply Nat.lt_0_succ.
Qed.

(* XXX: clean up *)
Lemma div_sub : forall (n m k : nat), m <> 0 -> n / m = S k -> (n - m) / m = k.
Proof.
intros.
assert (n = m * (S k) + n mod m).
rewrite <- H0.
apply Nat.div_mod; auto.
rewrite H1.
rewrite Nat.mul_succ_r.
replace (m * k + m + n mod m - m) with (m * k + n mod m).
rewrite Nat.mul_comm.
rewrite Nat.div_add_l; auto.
rewrite Nat.div_small.
now rewrite plus_n_O.
apply Nat.mod_upper_bound; auto.

replace (m * k + m + n mod m - m) with (m * k + (m + n mod m - m)).
now rewrite -> Nat.add_cancel_l, minus_plus.
rewrite Nat.add_sub_assoc, plus_assoc. reflexivity.
apply le_plus_l.
Qed.

Lemma diff_zero : forall (n : nat), 32 <= n -> n <> 0.
Proof.
  destruct n.
  -Search (_ <= 0).
   intros.
   apply Nat.nle_succ_0 in H.
   inversion H.
  -auto.
Qed.

Lemma cut32_concat_listes : forall (ll : list (list bool)) (l : list bool),
    cut32 l = Some ll -> concat_listes_32 ll = Some l.
Proof.
  induction ll.
  -apply cut32_concat_nil.
  -intros.
   assert (cut32 (skipn 32 l) = Some ll).
   {
     unfold cut32 in H.
     destruct (length l mod 32 =? 0) eqn:H0.
     -destruct (length l / 32) eqn:H1.
      +simpl in H.
       discriminate.
      +unfold cut32_n in H.
       fold cut32_n in H.
       assert (forall (a b : list bool) (l1 l2 : list (list bool)), Some (a :: l1) = Some (b :: l2) -> Some l1 = Some l2).
       {
         intros.
         inversion H2.
         reflexivity.
       }
       apply H2 in H.
       assert (forall (ll1 ll2 : list (list bool)), Some ll1 = Some ll2 -> ll1 = ll2).
       {
         intros. inversion H3. reflexivity.
       }
       apply H3 in H.
       unfold cut32.
       assert (32 <= length l).
       {
         Search (_ / _).
         Check Nat.div_str_pos_iff.
         specialize (Nat.div_str_pos_iff (length l) 32).
         intros.
         assert (32 <> 0) by auto.
         apply H4 in H5.
         apply equal_succ_diff_0 in H1.
         apply H5 in H1.
         auto.
       }
       assert (length (skipn 32 l) mod 32 =? 0 = true).
       {
         assert (length (skipn 32 l) = length l - 32).
         {
           Check skipn_length.
           apply skipn_length.
           auto.
         }
         rewrite H5.
         auto.
         Check mod_sub.
         specialize (mod_sub (length l)).
         intros.
         apply beq_nat_true in H0.
         apply mod_sub in H0.
         rewrite H0.
         reflexivity.
       }
       rewrite H5.
       assert ((length (skipn 32 l) / 32) = n).
       {
         Check skipn_length.
         rewrite skipn_length.
         -apply div_sub in H1.
          auto.
          assert (length l <> 0).
          {
            apply diff_zero in H4.
            auto.
          }
          auto.
         -auto.
       }
       rewrite H6.
       rewrite H.
       reflexivity.
     -discriminate.
   }
   simpl.
   specialize (IHll (skipn 32 l)).
   rewrite IHll.
   +assert (length a =? 32 = true).
    {
      Check cut32_length.
      apply cut32_length in H.
      rewrite H.
      reflexivity.
    }
    rewrite H1.
    assert (l = firstn 32 l ++ skipn 32 l).
    {
      rewrite firstn_skipn.
      reflexivity.
    }
    assert (a = firstn 32 l).
    {
      apply cut32_firstn in H.
      apply commut_equal.
      auto.
    }
    rewrite H3.
    unfold bind.
    rewrite <- H2.
    reflexivity.
   +auto.
Qed.

(* Finals goal of this file, proofs about encode_flux_b and decode_flux_b *)
(*=encode_decode_flux_decoup *)
Lemma encode_decode_flux_decoup : forall (lb : list bool) (l : list instruction),
    encode_flux_b l = Some lb -> decode_flux lb = Some l.
(*=End *)
Proof.
  intros.
  unfold encode_flux_b in H.
  destruct encode_flux eqn:H1.
  -Search (encode_flux).
   apply encode_decode_decoup_flux_decoup in H1.
   unfold decode_flux.
   Search concat_listes_32.
   apply concat_listes_cut32 in H.
   rewrite H.
   auto.
  -discriminate.
Qed.

(*=decode_flux_decoup_encode *)
Lemma decode_flux_decoup_encode : forall (lb : list bool) (l : list instruction),
    decode_flux lb = Some l -> encode_flux_b l = Some lb.
(*=End *)
Proof.
  intros.
  unfold decode_flux in H.
  unfold encode_flux_b.
  destruct (cut32 lb) eqn:H1.
  -simpl in H. Search (decode_flux_decoup).
   apply decode_decoup_encode_flux in H.
   rewrite H.
   Search cut32.
   apply cut32_concat_listes in H1.
   rewrite H1.
   reflexivity.
  -simpl in H.
   discriminate.
Qed.


(********* Integrating the point wise consistency into the numerical scheme ****************)

Require Import Reals Psatz.
Require Import Coquelicot.Rbar.
Require Import Top.linear_map.
Require Import Top.continuous_linear_map.
Require Import Omega Init.Nat Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import lax_equivalence.
Require Import pointwise_consistency.

(* Instantiation begins here *)

Notation Xh:= lax_equivalence.Xh.
Notation X:= lax_equivalence.X.
Notation Y:= lax_equivalence.Y.
Notation Yh:= lax_equivalence.Yh.
Notation E:= lax_equivalence.E.
Notation F:= lax_equivalence.F.
Notation Aop:= lax_equivalence.Aop.
Notation Ah_op:= lax_equivalence.Ah_op.

Variable N:nat.
Variable x:nat ->R.

(* u is a real valued function defined in the pointwise_consistency module *)
Notation u:= pointwise_consistency.u.

(* D is a differential opertor defined in the pointwise_consistency module *)
Notation D:= pointwise_consistency.D.

(* Imposing boundary conditions *)
Hypothesis u_0 : (D 0 (x 0))= 0.
Hypothesis u_N: (D 0 (x N)) =0.
Hypothesis u_2x: forall i:nat, (D 2 (x i)) =1.

Definition equiv_f (N:nat):= (fun h:R => Rabs (( D 0 (x 0)) */ (h*h)) + sum_n_m(fun i:nat => Rabs (( D 0 (x i -h) - 2* (D 0 (x i)) + D 0 (x i +h))*/(h^2) -1)) 1%nat (pred N)
                                  + Rabs ( (D 0 (x N))*/ (h *h))).

Hypothesis norm_eq :
  forall (u:X) (f:Y) (h:R) (uh: Xh h) (rh: forall (h:R), X -> (Xh h)) (sh: forall (h:R), Y->(Yh h))
 (E: Y->X) (Eh:forall (h:R), (Yh h)->(Xh h)),
  norm (minus (Ah_op h (rh h u)) (sh h (Aop u)))= equiv_f N h.

Hypothesis interval_1: forall i:nat, Oab (x i).
Hypothesis interval_2: forall (i:nat) (h:R), Oab (x i+h).
Hypothesis interval_3: forall (i:nat)(h:R), Oab (x i-h).

(* Defining explicitly interval for x in the domain of length (ub-lb) where lb and ub are lower and upper bounds of the interval *)
Hypothesis x_limits:
    forall (i N:nat) (lb ub y:R), (0<i<N)%nat -> (lb < (x i) < ub) /\  (y= (ub-lb)/INR (N+1)).

(*** This is where we integrate pointwise consistency with the consistency statement in the Lax equivalence theorem *******)
Lemma lim_sum:
   is_lim (fun h:R => sum_n_m (fun i:nat => Rabs (( D 0 (x i -h) - 2* (D 0 (x i)) + D 0 (x i +h))*/(h^2) -1)) 1%nat (pred N)) 0 0.
Proof.
induction N.
+ simpl.
  apply (is_lim_ext (fun h:R => 0) (fun h : R =>sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) */ (h * (h * 1)) - 1)) 1 0)).
    * intros. symmetry.
      apply (sum_n_m_zero (fun i : nat => Rabs ((D 0 (x i - y) - 2 * D 0 (x i) + D 0 (x i + y)) */ (y * (y * 1)) - 1)) 1%nat 0%nat). omega.
    * apply is_lim_const.
+ assert ( n = 0%nat \/ (0<n)%nat). { omega. }
  destruct H.
  - rewrite H. simpl.
    apply (is_lim_ext (fun h:R => 0) (fun h : R =>sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) */ (h * (h * 1)) - 1)) 1 0)).
    * intros. symmetry.
      apply (sum_n_m_zero (fun i : nat => Rabs ((D 0 (x i - y) - 2 * D 0 (x i) + D 0 (x i + y)) */ (y * (y * 1)) - 1)) 1%nat 0%nat). omega.
    * apply is_lim_const.
  - simpl.
    assert ( n = S (pred n)). { omega. }
    rewrite H0.
    apply (is_lim_ext (fun h:R =>  sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) */ h ^ 2 - 1)) 1 (Init.Nat.pred n)+
                                Rabs ((D 0 (x (S (pred n))- h) - 2 * D 0 (x (S (pred n))) + D 0 (x (S (pred n))+h))*/(h^2)-1))
                          (fun h : R =>sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) */ (h * (h * 1)) - 1)) 1 (S (Init.Nat.pred n)))).
    * intros. symmetry.
      assert (sum_n_m (fun i : nat => Rabs((D 0 (x i - y) - 2 * D 0 (x i) + D 0 (x i + y)) */ (y * (y * 1)) - 1)) (S (pred n)) (S (pred n))=
                          Rabs ((D 0 (x (S (pred n))- y) - 2 * D 0 (x (S (pred n))) + D 0 (x (S (pred n))+y))*/(y^2)-1)).
      { apply (sum_n_n (fun i : nat => Rabs((D 0 (x i - y) - 2 * D 0 (x i) + D 0 (x i + y)) */ (y * (y * 1)) - 1)) (S (pred n))). }
      rewrite <- H1.
      apply (sum_n_m_Chasles (fun i : nat => Rabs((D 0 (x i - y) - 2 * D 0 (x i) + D 0 (x i + y)) */ (y * (y * 1)) - 1)) 1%nat (pred n) (S (pred n))). omega. omega.
    * rewrite <- H0.
      apply (is_lim_plus (fun h : R => sum_n_m (fun i : nat =>  Rabs((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) */ h ^ 2 - 1)) 1 (Init.Nat.pred n))
                (fun h:R => Rabs((D 0 (x n - h) - 2 * D 0 (x n) + D 0 (x n + h)) */ h ^ 2 - 1)) 0 0 0 0).
      { apply IHn. }
      { cut(Oab (x n)-> exists gamma:R, gamma >0 /\ exists G:R, G>0/\ forall dx:R, dx>0 -> Oab ((x n)+dx) -> Oab ((x n)-dx)->(dx< gamma -> Rabs( (D 0 ((x n)+dx) - 2* (D 0 (x n)) +D 0 ((x n)-dx)) * / (dx * dx) - D 2 (x n))<= G*(dx^2))).
        + intros.
          assert ( Oab (x n)). { apply (interval_1 n). } specialize (H1 H2). destruct H1 as [L H1]. destruct H1 as [H1 H3]. destruct H3 as [p H3]. destruct H3.
          apply (is_lim_le_le_loc (fun _ => 0) (fun h:R => p * (h^2))
                   (fun h : R => Rabs((D 0 (x n - h) - 2 * D 0 (x n) + D 0 (x n + h)) * / h ^ 2 - 1)) 0 0).
         * unfold Rbar_locally'. unfold locally'. unfold within. unfold locally. exists (mkposreal 2 two_zero). intros.
           split.
          { apply Rabs_pos. }
          { specialize (H4 y).
            assert( y>0). {
              assert (y= L/ INR(S n+1)). {
                assert (forall (i N:nat) (lb ub y:R), (0<i<N)%nat -> (lb < (x i) < ub) /\  (y= (ub-lb)/INR (N+1))).
                { apply x_limits. }
                specialize (H7 n (S n) 0 L y).
                assert ((0 < n < S n)%nat). { omega. } specialize (H7 H8).
                destruct H7 as [H7 H9]. assert (L-0=L). { nra. } rewrite <-H10. apply H9.
                } rewrite H7.
              assert (L / INR (S n + 1)= L * (/ INR (S n +1))). { nra. } rewrite H8. apply Rmult_gt_0_compat.
              apply H1. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
            }
            specialize (H4 H7).
            assert ( Oab (x n+ y)). { apply (interval_2 n). } specialize (H4 H8).
            assert( Oab (x n -y)). { apply (interval_3 n). } specialize (H4 H9).
            assert ( y < L). {
            assert (y= L/ INR(S n+1)). {
                assert (forall (i N:nat) (lb ub y:R), (0<i<N)%nat -> (lb < (x i) < ub) /\  (y= (ub-lb)/INR (N+1))).
                { apply x_limits. }
                specialize (H10 n (S n) 0 L y).
                assert ((0 < n < S n)%nat). { omega. } specialize (H10 H11).
                destruct H10 as [H10 H12]. assert (L-0=L). { nra. } rewrite <-H13. apply H12.
                } rewrite H10.
                assert ( L = L* 1). { nra. } rewrite H11.
               assert (L * 1 / INR (S n + 1) = L * (/ INR (S n + 1))). { nra. } rewrite H12.
               apply Rmult_lt_compat_l. apply H1.
               assert ( INR (S n + 1) * (/ INR (S n + 1))=1). { apply Rinv_r. apply not_0_INR. omega. } rewrite <-H13.
               assert (/ INR (S n + 1) =1 * (/ INR (S n + 1))). { nra. } rewrite H14.
               assert (INR (S n + 1) * (1 * / INR (S n + 1))=INR (S n + 1) * (/ INR (S n + 1))). { nra. } rewrite H15.
               apply Rmult_lt_compat_r. apply Rinv_0_lt_compat. apply lt_0_INR. omega.
               apply lt_1_INR. omega.
           }
            specialize (H4 H10).
            assert ( D 0 (x n - y) - 2* (D 0 (x n)) + D 0 (x n +y)= D 0 (x n  +y)- 2* (D 0 (x n))+ D 0 (x n - y)). { nra. }
            rewrite H11.
            assert (D 2 (x n) =1). { apply (u_2x n). }
            rewrite H12 in H4. assert ( y*y= y^2). { nra. } rewrite H13 in H4. apply H4.
           }
         * apply is_lim_const.
         * assert (Rbar_mult p 0=0). { apply (Rbar_mult_0_r p). } rewrite <-H5.
          apply (is_lim_scal_l (fun h:R => h^2) p (Rbar_mult p 0) 0). rewrite H5.
          apply (is_lim_ext (fun h:R=> h * h) (fun h:R => h^2)).
          { intros. nra. }
          { assert ( Rbar_mult 0 0 = 0). { apply (Rbar_mult_0_l 0). } rewrite <- H6.
            apply (is_lim_mult (fun h:R => h) (fun h:R => h) (Rbar_mult 0 0) 0 0).
            + rewrite H6. apply (is_lim_id 0).
            + rewrite H6. apply (is_lim_id 0).
            + apply Rbar_mult_correct' with 0. unfold is_Rbar_mult. unfold Rbar_mult'. assert (0 * 0 =0). { nra. } rewrite H7. reflexivity.
          }
      + apply (taylor_FD (x n)).
     }
     { unfold is_Rbar_plus. unfold Rbar_plus'. assert (0+0=0). { nra. } rewrite H1. reflexivity. }
Qed.

Theorem consistency_inst:
  forall (U:X) (f:Y) (h:R) (uh: Xh h) (rh: forall (h:R), X -> (Xh h)) (sh: forall (h:R), Y->(Yh h))
 (E: Y->X) (Eh:forall (h:R), (Yh h)->(Xh h)),
  is_lim (fun h:R => norm (minus (Ah_op h (rh h U)) (sh h (Aop U)))) 0 0.
Proof.
intros.
apply (is_lim_ext (equiv_f N) (fun h:R => norm (minus (Ah_op h (rh h U)) (sh h (Aop U))))
          0 0).
+ intros. symmetry. apply norm_eq. now auto. apply rh. auto. apply E. apply Eh.
+ unfold equiv_f.
  apply (is_lim_ext (fun h : R => Rabs (D 0 (x 0) * / (h * h)) + (sum_n_m (fun i : nat =>
                          Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) * / h ^ 2 - 1)) 1
                              (Init.Nat.pred N) + Rabs (D 0 (x N) * / (h * h))))
                    (fun h : R => Rabs (D 0 (x 0) * / (h * h)) + sum_n_m (fun i : nat =>
                          Rabs ((D 0 (x i - h) - 2 * D 0 (x i) + D 0 (x i + h)) * / h ^ 2 - 1)) 1
                              (Init.Nat.pred N) + Rabs (D 0 (x N) * / (h * h)))).
  - intros. nra.
  - apply (is_lim_plus (fun h: R => Rabs (D 0 (x 0) * / (h * h)))
                    (fun h:R => sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) +  D 0 (x i + h)) * / h ^ 2 - 1)) 1 (Init.Nat.pred N)
                                +  Rabs (D 0 (x N) * / (h * h))) 0 0 0 0).
    * apply (is_lim_ext (fun h:R =>0) (fun h0 : R => Rabs (D 0 (x 0) * / (h0 * h0))) 0 0).
      { intros. assert (D 0 (x 0%nat) =0). { apply u_0. } rewrite H. symmetry.
      assert(0 * / (y * y)=0). { nra. } rewrite H0. apply Rabs_R0.
      }
      { apply is_lim_const. }
    * apply (is_lim_plus (fun h:R =>sum_n_m (fun i : nat => Rabs ((D 0 (x i - h) - 2 * D 0 (x i) +  D 0 (x i + h)) * / h ^ 2 - 1)) 1 (Init.Nat.pred N))
                          (fun h:R => Rabs (D 0 (x N) * / (h * h))) 0 0 0 0).
      { apply lim_sum. }
      { apply (is_lim_ext (fun h:R => 0) (fun h0 : R => Rabs (D 0 (x N) * / (h0 * h0))) 0 0).
        + intros. symmetry.
          assert ( D 0 (x N)=0). { apply u_N. } rewrite H.
          assert ( 0 * / (y * y)=0). { nra. } rewrite H0. apply Rabs_R0.
        + apply is_lim_const.
      }
      { unfold is_Rbar_plus. unfold Rbar_plus'.
        cut(0+0=0).
        { intros. rewrite H. reflexivity. }
        { nra. }
      }
    * unfold is_Rbar_plus. unfold Rbar_plus'.
      cut(0+0=0).
      { intros. rewrite H. reflexivity. }
      { nra. }
Qed.