From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
From FY Require Export Utils.
From FY Require Export Syntax.
From FY Require Export Semantics.
From FY Require Export Assertion.
From FY Require Export Logic.

Definition X : string := "X".
Definition Y0 : string := "Y0".
Definition Y1 : string := "Y1".
Definition K : string := "K".

Lemma kron_I_1: kron (I 2) (I 1) == I 2.
Proof.
  lma.
Qed.

Definition GROVER : com :=
  <{
    new_qubit;
    new_qubit;
    q 0 *= GH;
    q 1 *= GH;
    (*Oracle - start*)
    q 0 *= GH;
    q 1 *= GH;
    q 0 *= GZ;
    q 1 *= GZ;
    (*Oracle - end*)
    K := (2 % nat); (* 3 ~ sqrt(8) *)
    X := (0 % nat);
    while X <= K do
      q 0 1 *= GCNOT;
      X := (X + 1%nat)
    end;
    Y0 :=meas 0;
    Y1 :=meas 1
  }>.

Print GROVER.

Theorem final_state: ceval 0%nat 3%nat GROVER [(( _ !-> 0%nat), I 1)]
[(( X !-> 2%nat ; K !-> 2%nat ;
    Y0 !-> 0%nat ;
    Y1 !-> 0%nat ; _ !-> 0%nat), ∣0⟩⟨0∣ )] .
Proof.
  eapply E_Seq.
  apply E_Init.
  eapply E_Seq.
  apply E_Init.
  eapply E_Seq.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_AppOne.
  eapply E_Seq.
  simpl.
  apply E_Ass.
  eapply E_Seq.
  simpl.
  apply E_Ass.
  eapply E_Seq.
  simpl.
  eapply E_WhileTrue.
  (* there is a problem *)
Admitted.


Require Import Modal.
Require Import SecOrder.
Require Import p_is_pos.
Require Import p_occurs_in.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Arith.EqNat.
Require Import List_machinery_impl my_bool.
Require Import Unary_Predless nList_egs pos_SO2.
(*
  Uniform_Mod_Defns
  Uniform_Mod_Lemmas8a
*)

(* ---------------------------------------------------------  *)

Fixpoint replace_FOv (alpha : SecOrder) (x y: FOvariable) : SecOrder :=
  match x with
  | Var xn =>
  match alpha with
    predSO (Pred n) (Var m) =>
          if EqNat.beq_nat xn m then predSO (Pred n) y else alpha
  | relatSO (Var n) (Var m) =>
          if EqNat.beq_nat xn n then if EqNat.beq_nat xn m
                                        then relatSO y y
                                        else relatSO y (Var m)
                                 else if EqNat.beq_nat xn m
                                         then relatSO (Var n) y
                                         else alpha
  | eqFO (Var n) (Var m) =>
          if EqNat.beq_nat xn n then if EqNat.beq_nat xn m
                                        then eqFO y y
                                        else eqFO y (Var m)
                                else if EqNat.beq_nat xn m
                                        then eqFO (Var n) y
                                        else alpha
  | allFO (Var n) beta =>
          if beq_nat xn n then allFO y (replace_FOv beta x y)
                          else allFO (Var n) (replace_FOv beta x y)
  | exFO (Var n) beta =>
          if beq_nat xn n then exFO y (replace_FOv beta x y)
                          else exFO (Var n) (replace_FOv beta x y)
  | negSO beta => negSO (replace_FOv beta x y)
  | conjSO beta1 beta2 => conjSO (replace_FOv beta1 x y) (replace_FOv beta2 x y)
  | disjSO beta1 beta2 => disjSO (replace_FOv beta1 x y) (replace_FOv beta2 x y)
  | implSO beta1 beta2 => implSO (replace_FOv beta1 x y) (replace_FOv beta2 x y)
  | allSO (Pred n) beta => allSO (Pred n) (replace_FOv beta x y)
  | exSO (Pred n) beta => exSO (Pred n) (replace_FOv beta x y)
  end
  end.

(* Replaces all occurrences of P in alpha with a SecOrder condition.
Think of it like:

  Takes in:
     alpha = ...Px... ;
     {u | Ruy -> y=x}
  Spits out:
     alpha' = ...(Rxy -> y=x)...

So, it takes in an alpha and a set where membership is determined by a SecOrder (ideally FO) fml.  *)

Fixpoint replace_pred (alpha : SecOrder) (P : predicate)
                      (x : FOvariable) (cond : SecOrder) : SecOrder :=
  match P with
  | Pred Pn =>
  match alpha with
    predSO (Pred n) (Var m) => if EqNat.beq_nat Pn n then (replace_FOv cond x (Var m)) else alpha
  | relatSO (Var n) (Var m) => alpha
  | eqFO (Var n) (Var m) => alpha
  | allFO (Var n) beta => allFO (Var n) (replace_pred beta P x cond)
  | exFO (Var n) beta => exFO (Var n) (replace_pred beta P x cond)
  | negSO beta => negSO (replace_pred beta P x cond)
  | conjSO beta1 beta2 => conjSO (replace_pred beta1 P x cond) (replace_pred beta2 P x cond)
  | disjSO beta1 beta2 => disjSO (replace_pred beta1 P x cond) (replace_pred beta2 P x cond)
  | implSO beta1 beta2 => implSO (replace_pred beta1 P x cond) (replace_pred beta2 P x cond)
  | allSO (Pred n) beta =>
           if beq_nat Pn n then (replace_pred beta P x cond)
                           else allSO (Pred n) (replace_pred beta P x cond)
  | exSO (Pred n) beta =>
           if beq_nat Pn n then (replace_pred beta P x cond)
                           else exSO (Pred n) (replace_pred beta P x cond)
  end
  end.

Fixpoint replace_pred_l (alpha : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder)
                        : SecOrder :=
  match lP, lx, lcond with
  | cons P lP', cons x lx', cons cond lcond' =>
      replace_pred (replace_pred_l alpha lP' lx' lcond') P x cond
  | _, _, _ => alpha
  end.

(* -------------------------------------------------------------------- *)

Lemma rep_pred_eqFO : forall (x y z : FOvariable) (Q : predicate)
                             (cond : SecOrder),
  (replace_pred (eqFO x y) Q z cond) = (eqFO x y).
Proof.
  intros.
  destruct Q as [Qm]; destruct x as [xn]; destruct y.
  reflexivity.
Qed.

Lemma rep_pred_allFO : forall (alpha cond : SecOrder) (x y : FOvariable)
                              (Q : predicate),
  (replace_pred (allFO x alpha) Q y cond) =
    (allFO x (replace_pred alpha Q y cond)).
Proof.
  intros.
  simpl replace_pred.
  destruct Q as [Qm]; destruct x as [xn].
  reflexivity.
Qed.

Lemma rep_pred_exFO : forall (alpha cond : SecOrder) (x y : FOvariable)
                              (Q : predicate),
  (replace_pred (exFO x alpha) Q y cond) =
    (exFO x (replace_pred alpha Q y cond)).
Proof.
  intros.
  simpl replace_pred.
  destruct Q as [Qm]; destruct x as [xn].
  reflexivity.
Qed.

Lemma rep_pred_negSO : forall (alpha cond : SecOrder) (y : FOvariable)
                              (Q : predicate),
  (replace_pred (negSO alpha) Q y cond) =
    (negSO (replace_pred alpha Q y cond)).
Proof.
  intros.
  simpl replace_pred.
  destruct Q; destruct y.
  reflexivity.
Qed.

Lemma rep_pred_conjSO : forall (alpha1 alpha2 cond : SecOrder) (y : FOvariable)
                              (Q : predicate),
  (replace_pred (conjSO alpha1 alpha2) Q y cond) =
    (conjSO (replace_pred alpha1 Q y cond) (replace_pred alpha2 Q y cond)).
Proof.
  intros.
  simpl.
  destruct Q.
  reflexivity.
Qed.

Lemma rep_pred_disjSO : forall (alpha1 alpha2 cond : SecOrder) (y : FOvariable)
                              (Q : predicate),
  (replace_pred (disjSO alpha1 alpha2) Q y cond) =
    (disjSO (replace_pred alpha1 Q y cond) (replace_pred alpha2 Q y cond)).
Proof.
  intros.
  simpl.
  destruct Q.
  reflexivity.
Qed.

Lemma rep_pred_implSO : forall (alpha1 alpha2 cond : SecOrder) (y : FOvariable)
                              (Q : predicate),
  (replace_pred (implSO alpha1 alpha2) Q y cond) =
    (implSO (replace_pred alpha1 Q y cond) (replace_pred alpha2 Q y cond)).
Proof.
  intros.
  simpl.
  destruct Q.
  reflexivity.
Qed.

Lemma rep_pred_relatSO : forall (cond : SecOrder) (x1 x2 y : FOvariable)
                              (Q : predicate),
  (replace_pred (relatSO x1 x2) Q y cond) = relatSO x1 x2.
Proof.
  intros.
  simpl.
  destruct Q; destruct x1; destruct x2.
  reflexivity.
Qed.

Lemma rep_pred_allSO : forall (alpha cond : SecOrder) (y : FOvariable)
                              (P Q : predicate),
  (replace_pred (allSO P alpha) Q y cond) =
    match P, Q with
    | Pred Pn, Pred Qm =>
    if beq_nat Pn Qm then (replace_pred alpha P y cond)
                 else allSO P (replace_pred alpha Q y cond)
    end.
Proof.
  intros.
  simpl.
  destruct Q; destruct y; destruct P.
  case_eq (beq_nat n n1); intros Hbeq.
    rewrite (beq_nat_true n n1 Hbeq).
    rewrite <- (beq_nat_refl n1).
    reflexivity.

    case_eq (beq_nat n1 n); intros Hbeq2.
      rewrite (beq_nat_true n1 n Hbeq2) in Hbeq.
      rewrite <- (beq_nat_refl n) in Hbeq; discriminate.

      reflexivity.
Qed.

Lemma rep_pred_exSO : forall (alpha cond : SecOrder) (y : FOvariable)
                              (P Q : predicate),
  (replace_pred (exSO P alpha) Q y cond) =
    match P, Q with
    | Pred Pn, Pred Qm =>
    if beq_nat Pn Qm then (replace_pred alpha P y cond)
                 else exSO P (replace_pred alpha Q y cond)
    end.
Proof.
  intros.
  simpl.
  destruct Q; destruct y; destruct P.
  case_eq (beq_nat n n1); intros Hbeq.
    rewrite (beq_nat_true n n1 Hbeq).
    rewrite <- (beq_nat_refl n1).
    reflexivity.

    case_eq (beq_nat n1 n); intros Hbeq2.
      rewrite (beq_nat_true n1 n Hbeq2) in Hbeq.
      rewrite <- (beq_nat_refl n) in Hbeq; discriminate.

      reflexivity.
Qed.

(* -------------------------------------------------------------------- *)

Lemma rep_pred_l_negSO : forall (alpha : SecOrder) (lP : list predicate)
                                (lx : list FOvariable)
                                (lcond : list SecOrder),
  replace_pred_l (negSO alpha) lP lx lcond =
    (negSO (replace_pred_l alpha lP lx lcond)).
Proof.
  intros alpha.
  induction lP.
    simpl; reflexivity.

    induction lx.
      simpl; reflexivity.

      induction lcond.
        simpl; reflexivity.

        simpl.
        rewrite IHlP.
        rewrite rep_pred_negSO.
        reflexivity.
Qed.

Lemma rep_pred_l_allFO : forall (alpha : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder)
                        (x : FOvariable) ,
  replace_pred_l (allFO x alpha) lP lx lcond =
    allFO x (replace_pred_l alpha lP lx lcond).
Proof.
  intros alpha lP.
  induction lP.
    intros.
    simpl.
    reflexivity.

    intros.
    case_eq lx.
      intros Hlx.
      simpl.
      reflexivity.

      intros y lx' Hly.
      case_eq lcond.
        intros Hlcond.
        simpl.
        reflexivity.

        intros cond lcond' Hlcond.
        simpl.
        rewrite IHlP.
        rewrite rep_pred_allFO.
        reflexivity.
Qed.

Lemma rep_pred_l_exFO : forall (alpha : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder)
                        (x : FOvariable) ,
  replace_pred_l (exFO x alpha) lP lx lcond =
    exFO x (replace_pred_l alpha lP lx lcond).
Proof.
  intros alpha lP.
  induction lP.
    intros.
    simpl.
    reflexivity.

    intros.
    case_eq lx.
      intros Hlx.
      simpl.
      reflexivity.

      intros y lx' Hly.
      case_eq lcond.
        intros Hlcond.
        simpl.
        reflexivity.

        intros cond lcond' Hlcond.
        simpl.
        rewrite IHlP.
        rewrite rep_pred_exFO.
        reflexivity.
Qed.

Lemma rep_pred_l_eqFO : forall (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder)
                        (x y : FOvariable) ,
  replace_pred_l (eqFO x y) lP lx lcond = (eqFO x y).
Proof.
  intros lP.
  induction lP.
    intros.
    simpl.
    reflexivity.

    intros.
    case_eq lx.
      intros Hlx.
      simpl.
      reflexivity.

      intros z lx' Hly.
      case_eq lcond.
        intros Hlcond.
        simpl.
        reflexivity.

        intros cond lcond' Hlcond.
        simpl.
        rewrite IHlP.
        rewrite rep_pred_eqFO.
        reflexivity.
Qed.

Lemma rep_pred_l_conjSO : forall (alpha1 alpha2 : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder),
  replace_pred_l (conjSO alpha1 alpha2) lP lx lcond =
    conjSO (replace_pred_l alpha1 lP lx lcond)
           (replace_pred_l alpha2 lP lx lcond).
Proof.
  intros alpha1 alpha2 lP.
  induction lP.
    simpl; reflexivity.

    induction lx.
      simpl; reflexivity.

      induction lcond.
        simpl; reflexivity.

        simpl.
        rewrite IHlP.
        rewrite rep_pred_conjSO.
        reflexivity.
Qed.

Lemma rep_pred_l_disjSO : forall (alpha1 alpha2 : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder),
  replace_pred_l (disjSO alpha1 alpha2) lP lx lcond =
    disjSO (replace_pred_l alpha1 lP lx lcond)
           (replace_pred_l alpha2 lP lx lcond).
Proof.
  intros alpha1 alpha2 lP.
  induction lP.
    simpl; reflexivity.

    induction lx.
      simpl; reflexivity.

      induction lcond.
        simpl; reflexivity.

        simpl.
        rewrite IHlP.
        rewrite rep_pred_disjSO.
        reflexivity.
Qed.

Lemma rep_pred_l_implSO : forall (alpha1 alpha2 : SecOrder) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder),
  replace_pred_l (implSO alpha1 alpha2) lP lx lcond =
    implSO (replace_pred_l alpha1 lP lx lcond)
           (replace_pred_l alpha2 lP lx lcond).
Proof.
  intros alpha1 alpha2 lP.
  induction lP.
    simpl; reflexivity.

    induction lx.
      simpl; reflexivity.

      induction lcond.
        simpl; reflexivity.

        simpl.
        rewrite IHlP.
        rewrite rep_pred_implSO.
        reflexivity.
Qed.

Lemma rep_pred_l_relatSO : forall (x y : FOvariable) (lP : list predicate)
                        (lx : list FOvariable) (lcond : list SecOrder),
  replace_pred_l (relatSO x y) lP lx lcond = relatSO x y.
Proof.
  intros x y lP.
  induction lP.
    simpl; reflexivity.

    induction lx.
          simpl; reflexivity.

      induction lcond.
            simpl; reflexivity.

        simpl.
        rewrite IHlP.
        destruct a; destruct x; destruct y.
        simpl.
        reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)

Lemma rep_pred_is_unary_predless : forall (alpha : SecOrder) (P : predicate)
                              (x : FOvariable) (cond : SecOrder),
  is_unary_predless alpha = true ->
    replace_pred alpha P x cond = alpha.
Proof.
  intros.
  destruct P as [Pn].
  induction alpha;
    try (simpl in *; destruct p; destruct f; discriminate);
    try (destruct f; destruct f0; reflexivity);
    try (simpl; destruct f;
         rewrite IHalpha; [reflexivity | assumption]);
    try (simpl; rewrite IHalpha;
          [reflexivity | assumption]);
    try (simpl in *;
      assert (is_unary_predless alpha1 = true) as H1;
        try (case_eq (is_unary_predless alpha1); intros H1';
        rewrite H1' in *; [reflexivity | discriminate]);
      rewrite H1 in H; rewrite IHalpha1; try assumption;
      rewrite IHalpha2; [reflexivity | assumption]);
    try (destruct p; simpl in *; discriminate).
Qed.

Lemma rep_FOv_is_unary_predless : forall (cond : SecOrder) (x y :FOvariable),
  is_unary_predless cond = true ->
    is_unary_predless (replace_FOv cond x y) = true.
Proof.
  intros cond x y FO.
  induction cond;
    try (simpl; destruct x; destruct f;
    case (beq_nat n n0);
      destruct y; simpl;
      rewrite IHcond;
      try reflexivity;
      try assumption);
    try (simpl in *; destruct p; destruct f; discriminate);
    try (simpl in *; destruct f0; destruct f; discriminate);
    try ( simpl; destruct x; destruct f; destruct f0;
    case (beq_nat n n0);
      case (beq_nat n n1);
        simpl; destruct y; reflexivity);
    try (destruct x; simpl; apply IHcond; assumption);
    try (simpl in FO;
    assert (is_unary_predless cond1 = true);
      [case_eq (is_unary_predless cond1); intros Hbeq1 ;
        rewrite Hbeq1 in FO; [reflexivity |
        discriminate]|] ;
    rewrite H in FO;
    destruct x; simpl; rewrite IHcond1;
      [rewrite IHcond2; [reflexivity |] |];
      assumption);
    try (simpl in *; destruct x; destruct p;
      discriminate).
Qed.

(* ----------------------------------------------------------------------- *)

Lemma rep_pred_switch : forall (alpha : SecOrder) (x y : FOvariable)
                               (cond1 cond2 : SecOrder)
                                (P Q : predicate),
  is_unary_predless cond1 = true -> is_unary_predless cond2 = true ->
    match P, Q with
    | Pred Pn, Pred Qm =>
      ~(Pn = Qm) ->
       replace_pred (replace_pred alpha P x cond1) Q y cond2 =
          replace_pred (replace_pred alpha Q y cond2) P x cond1
    end.
Proof.
  intros alpha x y cond1 cond2 P Q FO1 FO2.
  destruct P as [Pn]; destruct Q as [Qm].
  intros Hneq.
  case_eq (beq_nat Pn Qm); intros Hbeq.
    specialize (Hneq (beq_nat_true Pn Qm Hbeq));
    contradiction.

    induction alpha;
      try (destruct f; destruct f0; simpl; reflexivity);
      try (destruct f; simpl; rewrite IHalpha; reflexivity);
      try (simpl; rewrite IHalpha; reflexivity);
      try (simpl; rewrite IHalpha1; rewrite IHalpha2; reflexivity).

      simpl.
      destruct p; destruct f.
      case_eq (beq_nat Pn n); intros Hbeq1.
        case_eq (beq_nat Qm n); intros Hbeq2.
          rewrite (beq_nat_true Pn n Hbeq1) in Hbeq.
          rewrite (beq_nat_true Qm n Hbeq2) in Hbeq.
          rewrite <- beq_nat_refl in Hbeq; discriminate.

          simpl.
          rewrite Hbeq1.
          rewrite rep_pred_is_unary_predless.
            reflexivity.

            apply rep_FOv_is_unary_predless.
            assumption.

        case_eq (beq_nat Qm n); intros Hbeq2.
          simpl.
          rewrite Hbeq2.
          rewrite rep_pred_is_unary_predless.
            reflexivity.

            apply rep_FOv_is_unary_predless.
            assumption.

          simpl.
          rewrite Hbeq1.
          rewrite Hbeq2.
          reflexivity.

      simpl.
      destruct p.
      case_eq (beq_nat Pn n); intros Hbeq1.
        case_eq (beq_nat Qm n); intros Hbeq2.
          rewrite (beq_nat_true Pn n Hbeq1) in Hbeq.
          rewrite (beq_nat_true Qm n Hbeq2) in Hbeq.
          rewrite <- beq_nat_refl in Hbeq; discriminate.

          simpl.
          rewrite Hbeq1.
          assumption.

        case_eq (beq_nat Qm n); intros Hbeq2.
          simpl.
          rewrite Hbeq2.
          assumption.

          simpl.
          rewrite Hbeq1; rewrite Hbeq2.
          rewrite IHalpha.
          reflexivity.

      simpl.
      destruct p.
      case_eq (beq_nat Pn n); intros Hbeq1.
        case_eq (beq_nat Qm n); intros Hbeq2.
          rewrite (beq_nat_true Pn n Hbeq1) in Hbeq.
          rewrite (beq_nat_true Qm n Hbeq2) in Hbeq.
          rewrite <- beq_nat_refl in Hbeq; discriminate.

          simpl.
          rewrite Hbeq1.
          assumption.

        case_eq (beq_nat Qm n); intros Hbeq2.
          simpl.
          rewrite Hbeq2.
          assumption.

          simpl.
          rewrite Hbeq1; rewrite Hbeq2.
          rewrite IHalpha.
          reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)

Lemma rep_pred_l_is_unary_predless : forall (alpha : SecOrder) (lP : list predicate)
                                (lx : list FOvariable) (lcond : list SecOrder),
  is_unary_predless alpha = true ->
    is_unary_predless (replace_pred_l alpha lP lx lcond) = true.
Proof.
  intros.
  induction alpha;
    try destruct p;
    try destruct f;
    try destruct f0;
    try rewrite rep_pred_l_relatSO;
    try rewrite rep_pred_l_eqFO;
    try rewrite rep_pred_l_allFO;
    try rewrite rep_pred_l_exFO;
    try rewrite rep_pred_l_negSO;
    try rewrite rep_pred_l_conjSO;
    try rewrite rep_pred_l_disjSO;
    try rewrite rep_pred_l_implSO;
    try assumption;
    try (simpl; apply IHalpha; apply H);
    try (simpl; rewrite IHalpha1;
      [rewrite IHalpha2;
          [reflexivity |
           try exact (is_unary_predless_conjSO_r _ _ H);
           try exact (is_unary_predless_disjSO_r _ _ H);
           try exact (is_unary_predless_implSO_r _ _ H);
           assumption] |
       try exact (is_unary_predless_conjSO_l _ _ H);
       try exact (is_unary_predless_disjSO_l _ _ H);
       try exact (is_unary_predless_implSO_l _ _ H)]);
    try (simpl in *; discriminate).
Qed.

Lemma rep_pred_l_app : forall (alpha : SecOrder)
                              (l1 l2 : list predicate),
  replace_pred_l alpha (app l1 l2)
      (nlist_list (length (app l1 l2))
                  (nlist_Var1 (length (app l1 l2))))
      (nlist_list (length (app l1 l2))
                  (nlist_empty (length (app l1 l2)))) =
  replace_pred_l (replace_pred_l alpha l2
                      (nlist_list (length l2)
                                  (nlist_Var1 (length l2)))
                      (nlist_list (length l2)
                                  (nlist_empty (length l2)))) l1
      (nlist_list (length l1)
                  (nlist_Var1 (length l1)))
      (nlist_list (length l1)
                  (nlist_empty (length l1))).
Proof.
  intros.
  induction l1.
    simpl.
    reflexivity.

    simpl.
    rewrite IHl1.
    reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)

Lemma rep_pred__l_switch_empty : forall (alpha : SecOrder) (P : predicate)
                                  (l : list predicate),
replace_pred_l
      (replace_pred alpha P (Var 1) (negSO (eqFO (Var 1) (Var 1))))
      l
      (nlist_list (length l) (nlist_Var1 (length l)))
      (nlist_list (length l) (nlist_empty (length l))) =
replace_pred
    (replace_pred_l alpha l
      (nlist_list (length l) (nlist_Var1 (length l)))
      (nlist_list (length l) (nlist_empty (length l))))
    P (Var 1) (negSO (eqFO (Var 1) (Var 1))).
Proof.
  intros.
  induction l.
    simpl; reflexivity.

    simpl.
    rewrite IHl.
    destruct P as [Pn]; destruct a as [Qm].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true Pn Qm Hbeq).
      reflexivity.

      rewrite (rep_pred_switch _ (Var 1) _ _
                _ (Pred Pn) (Pred Qm));
        simpl; try reflexivity.

        exact (beq_nat_false Pn Qm Hbeq).
Qed.

Lemma rep_pred_l_switch : forall (alpha : SecOrder)
                                 (l1 l2 : list predicate),
replace_pred_l
(replace_pred_l alpha l1
      (nlist_list (length l1)
          (nlist_Var1 (length l1)))
      (nlist_list (length l1)
          (nlist_empty (length l1)))) l2
    (nlist_list (length l2)
        (nlist_Var1 (length l2)))
    (nlist_list (length l2)
        (nlist_empty (length l2))) =
replace_pred_l
(replace_pred_l alpha l2
      (nlist_list (length l2)
          (nlist_Var1 (length l2)))
      (nlist_list (length l2)
          (nlist_empty (length l2)))) l1
    (nlist_list (length l1)
        (nlist_Var1 (length l1)))
    (nlist_list (length l1)
        (nlist_empty (length l1))).
Proof.
  intros.
  induction l1.
    simpl.
    reflexivity.

    simpl.
    rewrite <- IHl1.
    rewrite rep_pred__l_switch_empty.
    reflexivity.
Qed.

Lemma rep_pred__l_switch_t : forall (alpha : SecOrder) (P : predicate)
                                  (l : list predicate),
replace_pred_l
      (replace_pred alpha P (Var 1) (eqFO (Var 1) (Var 1)))
      l
      (nlist_list (length l) (nlist_Var1 (length l)))
      (nlist_list (length l) (nlist_full (length l))) =
replace_pred
    (replace_pred_l alpha l
      (nlist_list (length l) (nlist_Var1 (length l)))
      (nlist_list (length l) (nlist_full (length l))))
    P (Var 1) (eqFO (Var 1) (Var 1)).
Proof.
  intros.
  induction l.
    simpl; reflexivity.

    simpl.
    rewrite IHl.
    destruct P as [Pn]; destruct a as [Qm].
    case_eq (beq_nat Pn Qm); intros Hbeq.
      rewrite (beq_nat_true Pn Qm Hbeq).
      reflexivity.

      rewrite (rep_pred_switch _ (Var 1) _ _
                _ (Pred Pn) (Pred Qm));
        simpl; try reflexivity.

        exact (beq_nat_false Pn Qm Hbeq).
Qed.

Lemma rep_pred_l_switch_t : forall (alpha : SecOrder)
                                 (l1 l2 : list predicate),
replace_pred_l
(replace_pred_l alpha l1
      (nlist_list (length l1)
          (nlist_Var1 (length l1)))
      (nlist_list (length l1)
          (nlist_full (length l1)))) l2
    (nlist_list (length l2)
        (nlist_Var1 (length l2)))
    (nlist_list (length l2)
        (nlist_full (length l2))) =
replace_pred_l
(replace_pred_l alpha l2
      (nlist_list (length l2)
          (nlist_Var1 (length l2)))
      (nlist_list (length l2)
          (nlist_full (length l2)))) l1
    (nlist_list (length l1)
        (nlist_Var1 (length l1)))
    (nlist_list (length l1)
        (nlist_full (length l1))).
Proof.
  intros.
  induction l1.
    simpl.
    reflexivity.

    simpl.
    rewrite <- IHl1.
    rewrite rep_pred__l_switch_t.
    reflexivity.
Qed.

(* ----------------------------------------------------------------------- *)

Lemma preds_in_rep_FOv : forall (cond : SecOrder) (x y : FOvariable),
  (preds_in (replace_FOv cond x y)) = preds_in cond.
Proof.
  intros.
  induction cond;
    try (destruct p; destruct f as [zn]; destruct x as [xn]; destruct y as [ym];
    simpl preds_in;
    case (beq_nat xn zn);
    simpl; reflexivity);
    try (destruct f as [x1]; destruct f0 as [x2];
    destruct x as [x3]; destruct y as [x4];
    simpl;
    case (beq_nat x3 x1); case (beq_nat x3 x2); simpl; reflexivity);
    try ( destruct f as [x1]; destruct x as [x2]; destruct y as [x3];
    simpl; case (beq_nat x2 x1); assumption);
    try (destruct x as [xn]; simpl; assumption);
    try (destruct x as [xn]; simpl; rewrite IHcond1; rewrite IHcond2;
          reflexivity);
    try (destruct x as [xn]; destruct p as [Pn]; simpl;
    rewrite IHcond; reflexivity).
Qed.

(* ----------------------------------------------------------------------- *)

Lemma SOt_alt_SOQFree : forall (alpha : SecOrder) (W : Set)
                      (Iv : FOvariable -> W) (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)  (Q : predicate),
  SOQFree alpha = true ->
    (SOturnst W Iv (alt_Ip Ip pa_f Q) Ir alpha <->
      SOturnst W Iv Ip Ir (replace_pred alpha Q (Var 1)
       (negSO (eqFO (Var 1) (Var 1))))).
Proof.
  induction alpha; intros W Iv Ip Ir Q HallSO.
    unfold pa_f.
    simpl in *.
    destruct p as [Pn]; destruct f as [xn]; destruct Q as [Qm].
    case_eq (beq_nat Qm Pn); intros Hbeq.
      rewrite (beq_nat_true Qm Pn Hbeq).
      simpl.
      rewrite <- beq_nat_refl.
      split; intros H.
        contradiction.

        unfold not in *.
        specialize (H eq_refl).
        contradiction.

      simpl.
      rewrite Hbeq in *.
      apply iff_refl.

    simpl in *.
    destruct f as [xn]; destruct f0 as [xm].
    destruct Q as [Qm].
    simpl.
    apply iff_refl.

    destruct f as [xn]; destruct f0 as [xm].
    destruct Q as [Qm].
    simpl.
    apply iff_refl.

    rewrite rep_pred_allFO.
    do 2 rewrite SOturnst_allFO.
    pose proof (SOQFree_allFO alpha f HallSO) as HallSO'.
    split; intros H d;
      (apply IHalpha; [assumption | apply H]).

    rewrite rep_pred_exFO.
    do 2 rewrite SOturnst_exFO.
    pose proof (SOQFree_exFO alpha f HallSO) as HallSO'.
    split; intros H; destruct H as [d H]; exists d;
      (apply IHalpha; [assumption | apply H]).

    rewrite rep_pred_negSO.
    do 2 rewrite SOturnst_negSO.
    split; intros H;
      unfold not; intros H2;
      apply H;
      apply IHalpha;
      assumption.

    rewrite rep_pred_conjSO.
    do 2 rewrite SOturnst_conjSO.
    pose proof (SOQFree_conjSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_conjSO_r alpha1 alpha2 HallSO) as H2.
    simpl in HallSO.
    split; intros H; apply conj;
      try (apply IHalpha1; [assumption | apply H]);
      try (apply IHalpha2; [assumption | apply H]).

    rewrite rep_pred_disjSO.
    do 2 rewrite SOturnst_disjSO.
    pose proof (SOQFree_disjSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_disjSO_r alpha1 alpha2 HallSO) as H2.
    split; intros H;
      (destruct H as [H | H];
      [left; apply IHalpha1 |
      right; apply IHalpha2]; assumption;
      apply H).

    rewrite rep_pred_implSO.
    do 2 rewrite SOturnst_implSO.
    pose proof (SOQFree_implSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_implSO_r alpha1 alpha2 HallSO) as H2.
    split; intros H H3;
      apply IHalpha2; [assumption | apply H | assumption | apply H];
      apply IHalpha1; assumption.

    simpl in HallSO.
    destruct p; discriminate.

    simpl in HallSO.
    destruct p; discriminate.
Qed.

Lemma SOt_alt_SOQFree_t : forall (alpha : SecOrder) (W : Set)
                      (Iv : FOvariable -> W) (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)  (Q : predicate),
  SOQFree alpha = true ->
    (SOturnst W Iv (alt_Ip Ip pa_t Q) Ir alpha <->
      SOturnst W Iv Ip Ir (replace_pred alpha Q (Var 1)
       (eqFO (Var 1) (Var 1)))).
Proof.
  induction alpha; intros W Iv Ip Ir Q HallSO.
    unfold pa_f.
    simpl in *.
    destruct p as [Pn]; destruct f as [xn]; destruct Q as [Qm].
    case_eq (beq_nat Qm Pn); intros Hbeq.
      rewrite (beq_nat_true Qm Pn Hbeq).
      simpl.
      rewrite <- beq_nat_refl.
      unfold pa_t.
      split; reflexivity.

      simpl.
      rewrite Hbeq in *.
      apply iff_refl.

    simpl in *.
    destruct f as [xn]; destruct f0 as [xm].
    destruct Q as [Qm].
    simpl.
    apply iff_refl.

    destruct f as [xn]; destruct f0 as [xm].
    destruct Q as [Qm].
    simpl.
    apply iff_refl.

    rewrite rep_pred_allFO.
    do 2 rewrite SOturnst_allFO.
    pose proof (SOQFree_allFO alpha f HallSO) as HallSO'.
    split; intros H d;
      (apply IHalpha; [assumption | apply H]).

    rewrite rep_pred_exFO.
    do 2 rewrite SOturnst_exFO.
    pose proof (SOQFree_exFO alpha f HallSO) as HallSO'.
    split; intros H; destruct H as [d H]; exists d;
      (apply IHalpha; [assumption | apply H]).

    rewrite rep_pred_negSO.
    do 2 rewrite SOturnst_negSO.
    split; intros H;
      unfold not; intros H2;
      apply H;
      apply IHalpha;
      assumption.

    rewrite rep_pred_conjSO.
    do 2 rewrite SOturnst_conjSO.
    pose proof (SOQFree_conjSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_conjSO_r alpha1 alpha2 HallSO) as H2.
    simpl in HallSO.
    split; intros H; apply conj;
      try (apply IHalpha1; [assumption | apply H]);
      try (apply IHalpha2; [assumption | apply H]).

    rewrite rep_pred_disjSO.
    do 2 rewrite SOturnst_disjSO.
    pose proof (SOQFree_disjSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_disjSO_r alpha1 alpha2 HallSO) as H2.
    split; intros H;
      (destruct H as [H | H];
      [left; apply IHalpha1 |
      right; apply IHalpha2]; assumption;
      apply H).

    rewrite rep_pred_implSO.
    do 2 rewrite SOturnst_implSO.
    pose proof (SOQFree_implSO_l alpha1 alpha2 HallSO) as H1.
    pose proof (SOQFree_implSO_r alpha1 alpha2 HallSO) as H2.
    split; intros H H3;
      apply IHalpha2; [assumption | apply H | assumption | apply H];
      apply IHalpha1; assumption.

    simpl in HallSO.
    destruct p; discriminate.

    simpl in HallSO.
    destruct p; discriminate.
Qed.

Lemma SOQFree_rep_FOv : forall alpha x y,
  SOQFree alpha = true ->
  SOQFree (replace_FOv alpha x y) = true.
Proof.
  induction alpha; intros [xn] [ym] H.
    destruct p; destruct f as [zn].
    simpl. case_eq (beq_nat xn zn);
      intros Hbeq; reflexivity.

    destruct f as [z1]; destruct f0 as [z2]. simpl.
      case_eq (beq_nat xn z1); intros Hbeq;
        case_eq (beq_nat xn z2); intros Hbeq2;
          reflexivity.

    destruct f as [z1]; destruct f0 as [z2]. simpl.
      case_eq (beq_nat xn z1); intros Hbeq;
        case_eq (beq_nat xn z2); intros Hbeq2;
          reflexivity.

    destruct f as [z1]. simpl.
      case_eq (beq_nat xn z1); intros Hbeq;
        simpl; apply IHalpha; apply H.

    destruct f as [z1]. simpl.
      case_eq (beq_nat xn z1); intros Hbeq;
        simpl; apply IHalpha; apply H.

    simpl in *. apply IHalpha. assumption.

    pose proof (SOQFree_conjSO_r _ _ H) as H3.
    apply SOQFree_conjSO_l in H.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    pose proof (SOQFree_conjSO_r _ _ H) as H3.
    apply SOQFree_conjSO_l in H.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    pose proof (SOQFree_conjSO_r _ _ H) as H3.
    apply SOQFree_conjSO_l in H.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    destruct p. simpl in *.
    discriminate.
    destruct p. simpl in *.
    discriminate.
Qed.

Lemma SOQFree_rep_pred : forall alpha cond P x,
  SOQFree alpha = true ->
  SOQFree cond = true ->
  SOQFree (replace_pred alpha P x cond) = true.
Proof.
  induction alpha; intros cond [Pn] [xn] H1 H2.
    destruct p as [Qm]; destruct f.
    simpl in *.
    case_eq (beq_nat Pn Qm); intros Hbeq.
      apply SOQFree_rep_FOv.
      assumption.

      simpl. reflexivity.

    destruct f. destruct f0. reflexivity.

    destruct f. destruct f0. reflexivity.

    destruct f. simpl in *. apply IHalpha;
    assumption.

    destruct f. simpl in *. apply IHalpha;
    assumption.

    simpl in *. apply IHalpha;
    assumption.

    pose proof (SOQFree_conjSO_r _ _ H1) as H3.
    apply SOQFree_conjSO_l in H1.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    pose proof (SOQFree_conjSO_r _ _ H1) as H3.
    apply SOQFree_conjSO_l in H1.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    pose proof (SOQFree_conjSO_r _ _ H1) as H3.
    apply SOQFree_conjSO_l in H1.
    simpl. rewrite IHalpha1.
    apply IHalpha2. all : try assumption.

    destruct p as [Qm].
    simpl in *. discriminate.

    destruct p as [Qm].
    simpl in *. discriminate.
Qed.

Lemma SOQFree_rep_pred_empty : forall (alpha : SecOrder) (Q : predicate),
  SOQFree alpha = true ->
    SOQFree (replace_pred alpha Q (Var 1)
      (negSO (eqFO (Var 1) (Var 1)))) = true.
Proof.
  induction alpha.
    intros Q HSO.
    destruct p as [Pn]; destruct f as [xn]; destruct Q as [Qm].
    simpl.
    case_eq (beq_nat Qm Pn); intros Hbeq.
      simpl; reflexivity.

      assumption.

    intros Q HSO.
    destruct f as [xn]; destruct f0 as [xm]; destruct Q as [Qm].
    simpl; reflexivity.

    intros Q HSO.
    destruct f as [xn]; destruct f0 as [xm]; destruct Q as [Qm].
    simpl; reflexivity.

    intros Q HSO.
    destruct Q as [Qm]; destruct f as [xn].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    destruct Q as [Qm]; destruct f as [xn].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_conjSO_l _ _ HSO) as H1.
    pose proof (SOQFree_conjSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_disjSO_l _ _ HSO) as H1.
    pose proof (SOQFree_disjSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_implSO_l _ _ HSO) as H1.
    pose proof (SOQFree_implSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl in HSO.
    destruct p; discriminate.

    intros Q HSO.
    simpl in HSO.
    destruct p; discriminate.
Qed.

Lemma SOQFree_rep_pred_t : forall (alpha : SecOrder) (Q : predicate),
  SOQFree alpha = true ->
    SOQFree (replace_pred alpha Q (Var 1)
      (eqFO (Var 1) (Var 1))) = true.
Proof.
  induction alpha.
    intros Q HSO.
    destruct p as [Pn]; destruct f as [xn]; destruct Q as [Qm].
    simpl.
    case_eq (beq_nat Qm Pn); intros Hbeq.
      simpl; reflexivity.

      assumption.

    intros Q HSO.
    destruct f as [xn]; destruct f0 as [xm]; destruct Q as [Qm].
    simpl; reflexivity.

    intros Q HSO.
    destruct f as [xn]; destruct f0 as [xm]; destruct Q as [Qm].
    simpl; reflexivity.

    intros Q HSO.
    destruct Q as [Qm]; destruct f as [xn].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    destruct Q as [Qm]; destruct f as [xn].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    apply IHalpha.
    assumption.

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_conjSO_l _ _ HSO) as H1.
    pose proof (SOQFree_conjSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_disjSO_l _ _ HSO) as H1.
    pose proof (SOQFree_disjSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl.
    destruct Q as [Qm].
    simpl.
    pose proof (SOQFree_implSO_l _ _ HSO) as H1.
    pose proof (SOQFree_implSO_r _ _ HSO) as H2.
    rewrite IHalpha1;
      [rewrite IHalpha2 | assumption];
      [reflexivity | assumption].

    intros Q HSO.
    simpl in HSO.
    destruct p; discriminate.

    intros Q HSO.
    simpl in HSO.
    destruct p; discriminate.
Qed.

Lemma SOQFree_rep_pred_l : forall lP lx lcond alpha,
  SOQFree_l lcond = true ->
  SOQFree alpha = true ->
  SOQFree (replace_pred_l alpha lP lx lcond) = true.
Proof.
  induction lP; intros lx lcond alpha H1 H2.
    simpl. assumption.

    simpl. destruct lx. assumption.
    destruct lcond. assumption.
    simpl in H1. case_eq (SOQFree s);
      intros Hs; rewrite Hs in *.
    apply SOQFree_rep_pred. apply IHlP.
    all : try assumption.
      discriminate.
Qed.

Lemma SOQFree_rep_pred_l_nlist : forall (l : list predicate) (alpha : SecOrder) ,
 SOQFree alpha = true ->
    SOQFree
  (replace_pred_l alpha l (nlist_list (length l) (nlist_Var1 (length l)))
     (nlist_list (length l) (nlist_empty (length l)))) = true.
Proof.
  induction l; intros alpha HSO.
    simpl.
    assumption.

    simpl.
    apply SOQFree_rep_pred_empty.
    apply IHl.
    assumption.
Qed.

Lemma SOQFree_rep_pred_l_t : forall (l : list predicate) (alpha : SecOrder) ,
 SOQFree alpha = true ->
    SOQFree
  (replace_pred_l alpha l (nlist_list (length l) (nlist_Var1 (length l)))
     (nlist_list (length l) (nlist_full (length l)))) = true.
Proof.
  induction l; intros alpha HSO.
    simpl.
    assumption.

    simpl.
    apply SOQFree_rep_pred_t.
    apply IHl.
    assumption.
Qed.

Lemma SOt_list_closed_SOQFree : forall (l : list predicate) (W : Set) (Iv : FOvariable -> W) (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop) (alpha : SecOrder) ,
  SOQFree alpha = true ->
    SOturnst W Iv Ip Ir (list_closed_SO alpha l) ->
      SOturnst W Iv Ip Ir (replace_pred_l alpha l
                          (nlist_list _ (nlist_Var1 (length l)))
                          (nlist_list _ (nlist_empty (length l)))).
Proof.
  induction l.
    intros W Iv Ip Ir alpha Hquant HSOt.
    simpl in *.
    assumption.

    intros W Iv Ip Ir alpha Hquant HSOt.
    simpl.
    apply SOt_alt_SOQFree.
      apply SOQFree_rep_pred_l_nlist.
      assumption.

      apply IHl.
        assumption.

        simpl list_closed_SO in HSOt.
        rewrite SOturnst_allSO in HSOt.
        apply HSOt.
Qed.

Lemma instant_uni_closed : forall (phi : Modal) (D : Set) (Iv:FOvariable -> D)
                               (Ip: predicate -> D -> Prop) (Ir: D -> D -> Prop)
                               (x : FOvariable),
  (SOturnst D Iv Ip Ir (uni_closed_SO (allFO x (ST phi x))) ->
    (SOturnst D Iv Ip Ir (replace_pred_l (allFO x (ST phi x))
          (preds_in (allFO x (ST phi x)))
          (nlist_list _ (nlist_Var1 (length (preds_in (ST phi x)))))
          (nlist_list _ (nlist_empty (length (preds_in (ST phi x)))) )))).
Proof.
  intros.
  unfold uni_closed_SO in H.
  assert (SOQFree (allFO x (ST phi x)) = true) as H2.
    simpl SOQFree.
    destruct x.
    apply SOQFree_ST.
  apply SOt_list_closed_SOQFree in H;  assumption.
Qed.

Lemma SOt_list_closed_SOQFree_t : forall (l : list predicate) (W : Set) (Iv : FOvariable -> W) (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop) (alpha : SecOrder) ,
  SOQFree alpha = true ->
    SOturnst W Iv Ip Ir (list_closed_SO alpha l) ->
      SOturnst W Iv Ip Ir (replace_pred_l alpha l
                          (nlist_list _ (nlist_Var1 (length l)))
                          (nlist_list _ (nlist_full (length l)))).
Proof.
  induction l.
    intros W Iv Ip Ir alpha Hquant HSOt.
    simpl in *.
    assumption.

    intros W Iv Ip Ir alpha Hquant HSOt.
    simpl.
    apply SOt_alt_SOQFree_t.
      apply SOQFree_rep_pred_l_t.
      assumption.

      apply IHl.
        assumption.

        simpl list_closed_SO in HSOt.
        rewrite SOturnst_allSO in HSOt.
        apply HSOt.
Qed.

Lemma instant_uni_closed_t : forall (phi : Modal) (D : Set) (Iv:FOvariable -> D)
                               (Ip: predicate -> D -> Prop) (Ir: D -> D -> Prop)
                               (x : FOvariable),
  (SOturnst D Iv Ip Ir (uni_closed_SO (allFO x (ST phi x))) ->
    (SOturnst D Iv Ip Ir (replace_pred_l (allFO x (ST phi x))
          (preds_in (allFO x (ST phi x)))
          (nlist_list _ (nlist_Var1 (length (preds_in (ST phi x)))))
          (nlist_list _ (nlist_full (length (preds_in (ST phi x)))) )))).
Proof.
  intros.
  unfold uni_closed_SO in H.
  assert (SOQFree (allFO x (ST phi x)) = true) as H2.
    simpl SOQFree.
    destruct x.
    apply SOQFree_ST.
  apply SOt_list_closed_SOQFree_t in H; assumption.
Qed.

Lemma rep_pred_false_pa_t : forall (alpha : SecOrder)  (W : Set) (Iv : FOvariable -> W)
                    (Ip : predicate -> W -> Prop)
                    (Ir : W -> W -> Prop)
                    (P : predicate),
  SOQFree alpha = true ->
  SOturnst W Iv Ip Ir (replace_pred alpha P (Var 1)
                          (eqFO (Var 1) (Var 1))) <->
  SOturnst W Iv (alt_Ip Ip pa_t P) Ir alpha.
Proof.
  induction alpha; intros W Iv Ip Ir P noSO;
    try destruct P as [Pn]; try destruct p as [Qm];
    try destruct f; try destruct f0.

    simpl; unfold pa_t.
    case_eq (beq_nat Pn Qm); intros Hbeq.
      simpl; split; intros H; reflexivity.
      simpl.
      apply iff_refl.

    simpl; apply iff_refl.
    simpl; apply iff_refl.

    rewrite rep_pred_allFO.
    do 2 rewrite SOturnst_allFO.
    simpl in noSO.
    split; (intros H d;
      apply IHalpha; [assumption | apply H]).

    rewrite rep_pred_exFO.
    do 2 rewrite SOturnst_exFO.
    split; intros H; destruct H as [d H];
      exists d; apply IHalpha;
      assumption.

    rewrite rep_pred_negSO.
    do 2 rewrite SOturnst_negSO.
    unfold not.
    split; intros H1 H2;
      apply H1; apply IHalpha;
      assumption.

    rewrite rep_pred_conjSO.
    do 2 rewrite SOturnst_conjSO.
    pose proof (SOQFree_conjSO_l _ _ noSO) as H1.
    pose proof (SOQFree_conjSO_r _ _ noSO) as H2.
    split; (intros H; apply conj;
      [apply IHalpha1 | apply IHalpha2]);
      try assumption; apply H.

    rewrite rep_pred_disjSO.
    pose proof (SOQFree_conjSO_l _ _ noSO) as H1.
    pose proof (SOQFree_conjSO_r _ _ noSO) as H2.
    do 2 rewrite SOturnst_disjSO.
    split; (intros H; destruct H;
      [left; apply IHalpha1 |
        right; apply IHalpha2]);
      assumption.

    rewrite rep_pred_implSO.
    do 2 rewrite SOturnst_implSO.
    pose proof (SOQFree_conjSO_l _ _ noSO) as Hl.
    pose proof (SOQFree_conjSO_r _ _ noSO) as Hr.
    split; intros H1 H2; apply IHalpha2; try assumption;
      apply H1; apply IHalpha1; assumption.

    simpl in noSO; discriminate.
    simpl in noSO; discriminate.
Qed.

(* ----------------------------------------------------------- *)

Lemma P_occ_rep_pred_f : forall (alpha cond : SecOrder) (P : predicate)
                              (x : FOvariable),
  P_occurs_in_alpha alpha P = false ->
    replace_pred alpha P x cond = alpha.
Proof.
  intros.
  induction alpha;
    try destruct P as [Pn];
    try destruct Q as [Qm];
    try destruct p as [Sn];
    try destruct f as [xn];
    try destruct f0 as [xm];
    try (unfold P_occurs_in_alpha in H;
      simpl in *;
      case_eq (beq_nat Pn Sn); intros Hbeq; rewrite Hbeq in *;
        [discriminate | reflexivity]);
    try (simpl in *; reflexivity);
    try (simpl in *;
      rewrite IHalpha;
        [reflexivity |
        unfold P_occurs_in_alpha; simpl in *; assumption]);
    try (unfold P_occurs_in_alpha in H;
      simpl in *;
      pose proof (P_occurs_in_l_app (preds_in alpha1)
                                    (preds_in alpha2)
                                    (Pred Pn)) as H2;
      apply contrapos_bool_or in H2;
      apply H2 in H;
      rewrite IHalpha1;
        [rewrite IHalpha2|]; try reflexivity; apply H);
    try ( unfold P_occurs_in_alpha in H;
      simpl in *;
      case_eq (beq_nat Pn Sn); intros Hbeq; rewrite Hbeq in *;
        [discriminate | ];
        rewrite IHalpha; [reflexivity | assumption]).
Qed.

Lemma P_occ_rep_pred_f2 : forall (alpha cond : SecOrder) (P Q : predicate)
                                  (x : FOvariable),
  P_occurs_in_alpha cond P = false ->
    P_occurs_in_alpha alpha P = false ->
      P_occurs_in_alpha (replace_pred alpha Q x cond) P = false.
Proof.
  intros alpha cond P Q x Hcond Halpha.
  induction alpha;
    try destruct P as [Pn];
    try destruct Q as [Qm];
    try destruct p as [Sn];
    try destruct f as [xn];
    try destruct f0 as [xm];
    try (unfold P_occurs_in_alpha;
      simpl in *; reflexivity);
    try (unfold P_occurs_in_alpha; simpl in *;
      apply IHalpha;
      assumption);
    try ( simpl in *;
      unfold P_occurs_in_alpha;
      case_eq (beq_nat Qm Sn); intros Hbeq;
        [rewrite preds_in_rep_FOv|  simpl];
        assumption);
    try ( simpl;
      pose proof (P_occurs_in_alpha_conjSO
                    (replace_pred alpha1 (Pred Qm) x cond)
                    (replace_pred alpha2 (Pred Qm) x cond) (Pred Pn)) as H;
      apply contrapos_bool_or in H;
      apply H;
      pose proof (P_occurs_in_alpha_conjSO alpha1 alpha2 (Pred Pn)) as H2;
      apply contrapos_bool_or in H2;
      apply H2 in Halpha;
      apply conj; [apply IHalpha1 | apply IHalpha2]; apply Halpha);
    try ( unfold P_occurs_in_alpha in *;
      simpl in *;
        case_eq (beq_nat Pn Sn); intros Hbeq2; rewrite Hbeq2 in *;
          [discriminate | ];
          case_eq (beq_nat Qm Sn); intros Hbeq;
            [ | simpl; rewrite Hbeq2]; apply IHalpha; assumption).
Qed.

Lemma P_occ_rep_pred_l_empty : forall (l : list predicate) (alpha : SecOrder)
                                (P : predicate),
  P_occurs_in_alpha alpha P = false ->
    P_occurs_in_alpha (replace_pred_l alpha l
                        (nlist_list (length l) (nlist_Var1 (length l)))
                        (nlist_list (length l) (nlist_empty (length l)))) P
          = false.
Proof.
  induction l; intros alpha P HPocc.
    simpl.
    assumption.

    simpl.
    rewrite <- rep_pred__l_switch_empty.
    apply IHl.
    rewrite P_occ_rep_pred_f2.
      reflexivity.

      unfold P_occurs_in_alpha; simpl; reflexivity.

      assumption.
Qed.


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import String Lists.List.
Import ListNotations.
Open Scope string.
Open Scope list.
From Utils Require Import Utils.
From Pyrosome.Theory Require Import Substable.

Section WithVar.
  Context {V : Type}.

  Notation named_list := (named_list V).
  Notation named_map := (@named_map V).

  Notation Substable0 := (Substable0 V).
  Notation Substable := (Substable (V:=V)).

  Section WithModelArgs.
    Context {term sort : Type}.

    (* TODO: put this class in a separate module for better imports?
       TODO: separate into two classes, implement first in Term
             to avoid duplicating ctx?
     *)
    Class PreModel :=
      {
        term_substable :> Substable0 term;
        sort_substable :> Substable term sort;
      }.

    Local Notation ctx := (named_list sort).
    Local Notation subst := (named_list term).

      Class Model :=
        {
          premodel :> PreModel;
          eq_sort : ctx -> sort -> sort -> Prop;
          eq_term : ctx -> sort -> term -> term -> Prop;
          wf_sort : ctx -> sort -> Prop;
          wf_term : ctx -> term -> sort -> Prop;
        }.

      Section WithPreModel.
      Context {PreModel : PreModel}.

      Fixpoint ws_ctx (c : ctx) : Prop :=
        match c with
        | [] => True
        | (n,t) :: c' => fresh n c' /\ well_scoped (map fst c') t /\ ws_ctx c'
        end.
      Arguments ws_ctx !c/.

      Lemma ws_all_fresh_ctx c
        : ws_ctx c -> all_fresh c.
      Proof using .
        induction c; basic_goal_prep; basic_utils_crush.
      Qed.
      End WithPreModel.

      Section WithModel.
        Context {Model : Model}.

      Inductive eq_subst
        : ctx -> ctx -> subst -> subst -> Prop :=
        eq_subst_nil : forall c : ctx, eq_subst c [] [] []
      | eq_subst_cons : forall (c c' : ctx) (s1 s2 : subst),
          eq_subst c c' s1 s2 ->
          forall (name : V) (t : sort) (e1 e2 : term),
            eq_term c t [/s2 /] e1 e2 ->
            eq_subst c ((name, t) :: c') ((name, e1) :: s1) ((name, e2) :: s2).

      Inductive wf_args : ctx -> list term -> ctx -> Prop :=
      | wf_args_nil : forall c, wf_args c [] []
      | wf_args_cons : forall c s c' name e t,
          wf_term c e t[/with_names_from c' s/] ->
          (* these arguments are last so that proof search unifies existentials
       from the other arguments first*)
          wf_args c s c' ->
          wf_args c (e::s) ((name,t)::c').

      Inductive wf_ctx : ctx -> Prop :=
      | wf_ctx_nil : wf_ctx []
      | wf_ctx_cons : forall name c v,
          fresh name c ->
          wf_ctx c ->
          wf_sort c v ->
          wf_ctx ((name,v)::c).

      Inductive eq_args : ctx -> ctx -> list term -> list term -> Prop :=
      | eq_args_nil : forall c, eq_args c [] [] []
      | eq_args_cons : forall c c' es1 es2,
          eq_args c c' es1 es2 ->
          forall name t e1 e2,
            (* assumed because the output ctx is wf: fresh name c' ->*)
            eq_term c t[/with_names_from c' es2/] e1 e2 ->
            eq_args c ((name, t)::c') (e1::es1) (e2::es2).

      Inductive wf_subst c : subst -> ctx -> Prop :=
      | wf_subst_nil : wf_subst c [] []
      | wf_subst_cons : forall s c' name e t,
          (* assumed because the output ctx is wf: fresh name c' ->*)
          wf_subst c s c' ->
          wf_term c e t[/s/] ->
          wf_subst c ((name,e)::s) ((name,t)::c').

      Lemma wf_subst_from_wf_args c s c'
        : wf_args c s c' ->
          wf_subst c (with_names_from c' s) c'.
      Proof.
        induction 1; basic_goal_prep; constructor; eauto.
      Qed.

      (* TODO: put this class in a separate module for better imports? *)
      Class Model_ok :=
        {
          term_substable_ok :> Substable0_ok term;
          sort_substable_ok :> Substable_ok term sort;

          (* Syntactic constructors *)
          eq_sort_subst : forall c s1 s2 c' t1' t2',
            (* Need to assert wf_ctx c here to satisfy
               assumptions' presuppositions
             *)
            wf_ctx c' ->
            eq_subst c c' s1 s2 ->
            eq_sort c' t1' t2' ->
            eq_sort c t1'[/s1/] t2'[/s2/];
          eq_sort_refl : forall c t,
            wf_sort c t ->
            eq_sort c t t;
          eq_sort_trans : forall c t1 t12 t2,
            eq_sort c t1 t12 ->
            eq_sort c t12 t2 ->
            eq_sort c t1 t2;
          eq_sort_sym : forall c t1 t2, eq_sort c t1 t2 -> eq_sort c t2 t1;

          eq_term_subst : forall c s1 s2 c' t e1 e2,
            (* Need to assert wf_ctx c' here to satisfy
               assumptions' presuppositions
             *)
            wf_ctx c' ->
            eq_subst c c' s1 s2 ->
            eq_term c' t e1 e2 ->
            eq_term c t[/s2/] e1[/s1/] e2[/s2/];
          eq_term_refl : forall c e t,
            wf_term c e t ->
            eq_term c t e e;
          eq_term_trans : forall c t e1 e12 e2,
            eq_term c t e1 e12 ->
            eq_term c t e12 e2 ->
            eq_term c t e1 e2;
          eq_term_sym : forall c t e1 e2, eq_term c t e1 e2 -> eq_term c t e2 e1;
          (* Conversion:
             c |- e1 = e2 : t
                            ||
             c |- e1 = e2 : t'
           *)
          eq_term_conv : forall c t t',
            eq_sort c t t' ->
            forall e1 e2,
              eq_term c t e1 e2 ->
              eq_term c t' e1 e2;

          wf_term_conv : forall c e t t',
            wf_term c e t ->
            eq_sort c t t' ->
            wf_term c e t';
          wf_term_var : forall c n t,
            In (n, t) c ->
            wf_term c (inj_var n) t;

          (* Syntactic Lemmas *)
          wf_sort_subst_monotonicity
          : forall (c : ctx) (t : sort),
              wf_sort c t ->
              wf_ctx c ->
              forall (c'' : ctx) (s : subst), wf_subst c'' s c -> wf_sort c'' t [/s /];
          wf_term_subst_monotonicity
          : forall (c : ctx) (e : term) (t : sort),
            wf_term c e t ->
            wf_ctx c ->
            forall (c'' : ctx) (s : subst),
              wf_subst c'' s c -> wf_term c'' e [/s /] t [/s /];
          wf_sort_implies_ws
          : forall c t, wf_sort c t -> well_scoped (map fst c) t;
          wf_term_implies_ws
          : forall c e t, wf_term c e t -> well_scoped (map fst c) e;
        }.

    End WithModel.

  End WithModelArgs.

End WithVar.

Arguments PreModel (V term sort)%type_scope.
Arguments Model {V term sort}%type_scope.
Arguments Model_ok {V term sort}%type_scope Model : rename.

Arguments ws_ctx {V term sort}%type_scope {PreModel} !c/.

Create HintDb model discriminated.

Lemma wf_ctx_all_fresh {V term sort} {Model : @Model V term sort} c
  : wf_ctx (Model:=Model) c -> all_fresh c.
Proof.
  induction 1; basic_goal_prep; basic_utils_crush.
Qed.
#[export] Hint Resolve wf_ctx_all_fresh : model.

Lemma invert_wf_ctx_nil V term sort (Model : @Model V term sort)
  : wf_ctx [] <-> True.
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_ctx_nil using solve[typeclasses eauto] : model.

Lemma invert_wf_ctx_cons V term sort (Model : @Model V term sort) c n t
  : wf_ctx ((n,t)::c) <-> fresh n c /\ wf_ctx c /\ wf_sort c t.
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_ctx_cons using solve[typeclasses eauto] : model.

Lemma invert_wf_subst_nil V term sort (Model : @Model V term sort) c c'
  : wf_subst c [] c' <-> c' = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_subst_nil using solve[typeclasses eauto] : model.

Lemma invert_wf_subst_ctx_nil V term sort (Model : @Model V term sort) c s
  : wf_subst c s [] <-> s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_subst_ctx_nil using solve[typeclasses eauto] : model.

(*TODO: write a version that destructs c' w/ existentials? *)
Lemma invert_wf_subst_cons V term sort (Model : @Model V term sort) c s c' n n' e t
  : wf_subst c ((n,e)::s) ((n',t)::c') <-> n = n' /\ wf_subst c s c' /\ wf_term c e t [/s /].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_subst_cons using solve[typeclasses eauto] : model.

Lemma invert_wf_args_nil V term sort (Model : @Model V term sort) c c'
  : wf_args c [] c' <-> c' = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_args_nil using solve[typeclasses eauto] : model.

Lemma invert_wf_args_ctx_nil V term sort (Model : @Model V term sort) c s
  : wf_args c s [] <-> s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_args_ctx_nil using solve[typeclasses eauto] : model.

(*TODO: write a version that destructs c' w/ existentials? *)
Lemma invert_wf_args_cons V term sort (Model : @Model V term sort) c s c' n e t
  : wf_args c (e::s) ((n,t)::c') <-> wf_args c s c' /\ wf_term c e t [/with_names_from c' s /].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_wf_args_cons using solve[typeclasses eauto] : model.

Lemma invert_eq_subst_nil_l V term sort (Model : @Model V term sort) c s c'
  : eq_subst c [] s c' <-> c' = [] /\ s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_subst_nil_l using solve[typeclasses eauto] : model.

Lemma invert_eq_subst_nil_r V term sort (Model : @Model V term sort) c s c'
  : eq_subst c s [] c' <-> c' = [] /\ s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_subst_nil_r using solve[typeclasses eauto] : model.

Lemma invert_eq_subst_ctx_nil V term sort (Model : @Model V term sort) c s1 s2
  : eq_subst c s1 s2 [] <-> s1 = [] /\ s2 = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_subst_ctx_nil using solve[typeclasses eauto] : model.

(*TODO: write a version that destructs c' w/ existentials? *)
Lemma invert_eq_subst_cons V term sort (Model : @Model V term sort) c s1 s2 c' n' n1 n2 e1 e2 t
  : eq_subst c ((n',t)::c') ((n1,e1)::s1) ((n2,e2)::s2)
    <-> n' = n1 /\ n1 = n2 /\ eq_subst c c' s1 s2 /\ eq_term c t [/s2 /] e1 e2.
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_subst_cons using solve[typeclasses eauto] : model.

Lemma invert_eq_args_nil_l V term sort (Model : @Model V term sort) c s c'
  : eq_args c [] s c' <-> c' = [] /\ s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_args_nil_l using solve[typeclasses eauto] : model.

Lemma invert_eq_args_nil_r V term sort (Model : @Model V term sort) c s c'
  : eq_args c s [] c' <-> c' = [] /\ s = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_args_nil_r using solve[typeclasses eauto] : model.

Lemma invert_eq_args_ctx_nil V term sort (Model : @Model V term sort) c s1 s2
  : eq_args c s1 s2 [] <-> s1 = [] /\ s2 = [].
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_args_ctx_nil using solve[typeclasses eauto] : model.

(*TODO: write a version that destructs c' w/ existentials? *)
Lemma invert_eq_args_cons V term sort (Model : @Model V term sort) c s1 s2 c' n e1 e2 t
  : eq_args c ((n,t)::c') (e1::s1) (e2::s2)
    <-> eq_args c c' s1 s2 /\ eq_term c t [/with_names_from c' s2 /] e1 e2.
Proof. solve_invert_constr_eq_lemma. Qed.
#[export] Hint Rewrite invert_eq_args_cons using solve[typeclasses eauto] : model.

#[export] Hint Resolve wf_ctx_all_fresh : model.

#[export] Hint Resolve wf_subst_from_wf_args : model.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Section soundness.

Existing Instance unit_kMD.

Context {P: ProgrammingLanguage}
        {MD: Model}
        {BSS: BigStepSemantics P model}
        {J: Join model}
        {R: Relation model}
        {po_R: PreOrder Krelation}
        {SA_BSS: SABigStepSemantics P model BSS}.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD tt SM}
        {fsepconSM: FlatSemantics.SepconSemantics L MD tt SM}.

Lemma hoare_frame_partial_sound: forall c P Q F,
  triple_partial_valid P c Q ->
  triple_partial_valid (P * F) c (Q * F).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros m' _n' ? ?.
  rewrite FlatSemantics.sat_sepcon in H0.
  destruct H0 as [m [mf [? [? ?]]]].
  assert (SAFE: safe m c) by exact (H m Error H2).
  destruct (frame_property _ _ _ _ _ H0 H1) as [_n [nf [? [? ?]]]].
  destruct _n' as [| | n'].
  + inversion H5; subst.
    revert H6; apply SAFE.
  + auto.
  + rewrite FlatSemantics.sat_sepcon.
    inversion H5; subst.
    - exfalso; revert H6; apply SAFE.
    - rename x into n.
      exists n, nf.
      split; [| split]; auto.
      * apply (H m _ H2 H6).
      * eapply sat_mono; eauto.
Qed.

Lemma hoare_frame_total_sound: forall c P Q F,
  triple_total_valid P c Q ->
  triple_total_valid (P * F) c (Q * F).
Proof.
  intros.
  unfold triple_partial_valid in *.
  intros m' _n' ? ?.
  rewrite FlatSemantics.sat_sepcon in H0.
  destruct H0 as [m [mf [? [? ?]]]].
  assert (SAFE: safe m c) by exact (H m Error H2).
  assert (TERM: term_norm m c) by exact (conj (H m Error H2) (H m NonTerminating H2)).
  destruct (frame_property _ _ _ _ _ H0 H1) as [_n [nf [? [? ?]]]].
  destruct _n' as [| | n'].
  + inversion H5; subst.
    revert H6; apply SAFE.
  + inversion H5; subst.
    - revert H6; apply SAFE.
    - revert H6; apply TERM.
  + rewrite FlatSemantics.sat_sepcon.
    inversion H5; subst.
    - exfalso; revert H6; apply SAFE.
    - rename x into n.
      exists n, nf.
      split; [| split]; auto.
      * apply (H m _ H2 H6).
      * eapply sat_mono; eauto.
Qed.

End soundness.


(*
Require Import Coq.Bool.Bool.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import ILogic ILEmbed.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Recur.Relation.
Require Import ExtLib.Tactics.Cases.
Require Import ExtLib.Tactics.Injection.
Require Import ExtLib.Tactics.EqDep.
Require Import ExtLib.Tactics.Consider.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.ExprI.
Require Import MirrorCharge.ILogicFunc.

Set Implicit Arguments.
Set Strict Implicit.

Section Tauto.
  Context (funcs : fun_map ts) (gs : logic_ops ts) (es : embed_ops ts).
  Context (H : logic_opsOk gs).
  Context (Hembed : embed_opsOk gs es).

  Local Notation "P //\\ Q" := (App (App (Inj (ilf_and _)) P) Q).

  Theorem ILogic_from t z (pf : gs t = Some z) : @ILogic _ z.
    specialize (H t). rewrite pf in *.
    assumption.
  Qed.

  Ltac get_logic t :=
    match goal with
      | Hgs : gs ?X = Some t
      |- _ =>
        exact (@ILogic_from _ _ Hgs)
    end.

  Local Instance RSym_ilfunc : SymI.RSym (typD ts) ilfunc := @RSym_ilfunc ts funcs gs es.
  Local Hint Extern 0 (@ILogic _ ?X) => get_logic X : typeclass_instances.
  Local Existing Instance lentailsPre.
  Local Hint Extern 1 (ILogic _) => eassumption : typeclass_instances.
  Local Hint Extern 1 (@Embed _ _ _ _ _) => eassumption : typeclass_instances.

  Inductive Facts : Type :=
  | Inconsistent
  | Knows : list (expr ilfunc) -> Facts.

  (** Facts Denotation **)
  Section factsD.
    Variables (us vs : env (typD ts)).
    Variables (t : typ) (ILO : ILogicOps (typD ts nil t)).
    Hypothesis (Hgs : gs t = Some ILO).

    Fixpoint eval_env (env : list (expr ilfunc))
    : option (typD ts nil t) :=
      match env with
        | nil => Some (@ltrue _ ILO)
        | p :: env => match exprD us vs p t, eval_env env with
  		        | Some p, Some q => Some (@land _ ILO q p)
  		        | _, _ => None
  		      end
      end.

    Definition FactsD (f : Facts) : option (typD ts nil t) :=
      match f with
        | Inconsistent => Some (@lfalse _ ILO)
        | Knows fs => eval_env fs
      end.
  End factsD.

  (** Learning **)
  Section learning.
    Fixpoint known_learn (e : expr ilfunc) (f : list (expr ilfunc)) : Facts :=
      match e with
        | Inj (ilf_true _) => Knows f
        | Inj (ilf_false _) => Inconsistent
        | P //\\ Q =>
          match known_learn Q f with
            | Inconsistent => Inconsistent
            | Knows f => known_learn P f
          end
        | _ => Knows (e :: f)
      end.

    Definition learn e f : Facts :=
      match f with
        | Inconsistent => Inconsistent
        | Knows fs => known_learn e fs
      end.

    Variables (us vs : env (typD ts)).
    Variables (t : typ) (ILO : ILogicOps (typD ts nil t)).
    Hypothesis (Hgs : gs t = Some ILO).

    Lemma FactsD_known_cons
    : forall (f : list (expr ilfunc))
             (v : typD ts nil t)
             (P : typD ts nil t)
             (e : expr ilfunc),
        eval_env us vs t _ f = Some P ->
        exprD us vs e t = Some v ->
        exists Q : typD ts nil t,
          FactsD us vs t _ (Knows (e :: f)) = Some Q /\ land P v |-- Q.
    Proof.
      simpl; intuition.
      rewrite H1. rewrite H0.
      eexists; split; eauto.
      reflexivity.
    Qed.

    Lemma FactsD_known_learn : forall e f f' v P,
      exprD us vs e t = Some v ->
      eval_env us vs t _ f = Some P ->
      known_learn e f = f' ->
      exists Q,
        FactsD us vs t _ f' = Some Q /\
        land P v |-- Q.
    Proof.
      refine (@expr_strong_ind _ _ _); intros.
      destruct e; subst; eauto using FactsD_known_cons.
      { simpl. destruct i; eauto using FactsD_known_cons.
        { red_exprD. simpl in *.
          forward; inv_all; subst.
          rewrite H2. eexists; split; eauto.
          apply landL1. reflexivity. }
        { red_exprD; simpl in *.
          forward; inv_all; subst.
          eexists; split; eauto.
          rewrite H1 in *. inv_all; subst.
          eapply landL2. reflexivity. } }
      { simpl.
        destruct e1; eauto using FactsD_known_cons.
        destruct e1_1; eauto using FactsD_known_cons.
        destruct i; eauto using FactsD_known_cons.
        repeat (red_exprD; Cases.rewrite_all_goal; forward;
                simpl in *; inv_all; try subst).
        destruct (H0 e2 _ f _ _ _ H5 H2 eq_refl) as [ ? [ ? ? ] ].
        consider (known_learn e2 f); intros.
        { simpl in *.
          inv_all; subst.
          eexists; split; try reflexivity.
          rewrite <- H4.
          apply landR.
          - apply landL1. reflexivity.
          - apply landL2.
            rewrite H1 in *. inv_all; subst.
            apply landL2. reflexivity. }
        { destruct (H0 e1_2 _ l _ _ _ H7 H6 eq_refl) as [ ? [ ? ? ] ].
          eexists; split. eassumption.
          rewrite H1 in *. inv_all; subst.
          rewrite <- H9.
          apply landR.
          - etransitivity; [ | eapply H4 ].
            apply landR.
            + apply landL1. reflexivity.
            + apply landL2. apply landL2. reflexivity.
          - apply landL2. apply landL1. reflexivity. } }
    Qed.

    Lemma FactsD_learn : forall f f' e v P,
      exprD us vs e t = Some v ->
      FactsD us vs t _ f = Some P ->
      learn e f = f' ->
      exists Q,
        FactsD us vs t _ f' = Some Q /\
        land P v |-- Q.
    Proof.
      destruct f; simpl; intros; inv_all; subst.
      { exists lfalse. intuition.
        specialize (H t). rewrite Hgs in *.
        eapply landL1. reflexivity. }
      { eapply FactsD_known_learn; eauto. }
    Qed.

  End learning.

  Variable floor : expr ilfunc -> typ -> typ -> option (expr ilfunc).

  Definition floor_spec e e' from to : Prop :=
    forall us vs P ILT ILU eTU,
      gs from = Some ILT ->
      gs to = Some ILU ->
      es from to = Some eTU ->
      exprD us vs e to = Some P ->
      exists Q,
        exprD us vs e' from = Some Q /\
        @lentails _ _ P (embed Q).

  Hypothesis Hfloor : forall e e' from to,
                        floor e from to = Some e' ->
                        floor_spec e e' from to.

  (** Lowering **)
  Section lowering.
    Variables from to : typ.

    Fixpoint known_lower_to (ls : list (expr ilfunc)) : list (expr ilfunc) :=
      match ls with
        | nil => nil
        | l :: ls =>
          match floor l from to with
            | None => known_lower_to ls
            | Some x => x :: known_lower_to ls
          end
      end.

    Definition lower_to (f : Facts) : Facts :=
      match f with
        | Inconsistent => Inconsistent
        | Knows fs => Knows (known_lower_to fs)
      end.

    Variables (us vs : env (typD ts)).
    Context {ILF} `{Hgs_from : gs from = Some ILF}.
    Context {ILT} `{Hgs_to : gs to = Some ILT}.
    Context {eFT} `{Hes_from_to : es from to = Some eFT}.

    Lemma known_lower_to_sound : forall ls P ls',
      known_lower_to ls = ls' ->
      eval_env us vs to _ ls = Some P ->
      exists Q,
        eval_env us vs from _ ls' = Some Q /\
        lentails P (embed Q).
    Proof.
      induction ls; simpl; intros; subst; inv_all; subst.
      { simpl in *. eexists; split; eauto.
        assert (Embed (typD ts nil from) (typD ts nil to)).
        { specialize (Hembed from to).
          rewrite Hgs_to in *. rewrite Hgs_from in *.
          rewrite Hes_from_to in *. assumption. }
        eapply embedltrue. }
      { forward; inv_all; subst.
        specialize (IHls _ _ eq_refl eq_refl).
        destruct IHls; intuition.
        consider (floor a from to); intros.
        { simpl. rewrite H3.
          specialize (Hfloor H2). red in Hfloor.
          specialize (@Hfloor us vs _ _ _ _ Hgs_from Hgs_to Hes_from_to H0).
          destruct Hfloor; clear Hfloor. intuition.
          rewrite H6. eexists; split; eauto.
          specialize (Hembed from to).
          generalize (H from).
          generalize (H to).
          rewrite Hgs_from in *. rewrite Hgs_to in *.
          rewrite Hes_from_to in *.
          rewrite H4. rewrite H7.
          intros. eapply embedland.  }
        { eexists; split; eauto.
          rewrite H4. apply landL1. reflexivity. } }
    Qed.

    Theorem lower_to_sound : forall ls P ls',
      lower_to ls = ls' ->
      FactsD us vs to _ ls = Some P ->
      exists Q,
        FactsD us vs from _ ls' = Some Q /\
        lentails P (embed Q).
    Proof.
      destruct ls; simpl; intros; subst; inv_all; subst; simpl.
      { eexists; split; eauto. }
      { eapply known_lower_to_sound in H1; eauto. }
    Qed.

  End lowering.

  Fixpoint known_assumption (env : list (expr ilfunc)) (p : expr ilfunc) :=
    match env with
      | nil => false
      | q :: env' =>
        if p ?[eq] q then
  	  true
  	else
  	  known_assumption env' p
    end.

  Definition assumption (f : Facts) (p : expr ilfunc) : bool :=
    match f with
      | Inconsistent => true
      | Knows fs => known_assumption fs p
    end.

  Section assumption.
    Variables (us vs : env (typD ts)).
    Variables (t : typ) (ILO : ILogicOps (typD ts nil t)).
    Hypothesis (Hgs : gs t = Some ILO).

    Lemma known_assumption_sound
    : forall (env : _) (p : expr ilfunc) x v
	     (_ : exprD us vs p t = Some v)
	     (_ : eval_env us vs t _ env = Some x),
        known_assumption env p = true ->
        @lentails (typD ts nil t) ILO x v.
    Proof.
      induction env; simpl; intros; try congruence.
      forward; inv_all; subst.
      consider (p ?[ eq ] a); intros; subst.
      { rewrite H0 in *. inv_all; subst.
        eapply landL2. reflexivity. }
      { specialize (IHenv _ _ _ H0 eq_refl H4).
        eapply landL1. assumption. }
    Qed.

    Lemma assumption_sound : forall (env : Facts) (p : expr ilfunc) x v
	                            (_ : exprD us vs p t = Some v)
	                            (_ : FactsD us vs t _ env = Some x)
                                    (_ : gs t = Some ILO),
                               assumption env p = true ->
                               @lentails (typD ts nil t) ILO x v.
    Proof.
      destruct env; simpl; intros; inv_all; subst.
      { specialize (H t). rewrite H2 in *.
        eapply lfalseL. }
      { eapply known_assumption_sound; eauto. }
    Qed.
  End assumption.

  Fixpoint tauto (env : Facts) (p : expr ilfunc) : bool :=
    match p with
      | Inj (ilf_true _) => true
      | App (App (Inj (ilf_and _)) p) q => andb (tauto env p) (tauto (learn p env) q)
      | App (App (Inj (ilf_or _)) p) q => orb (tauto env p) (tauto env q)
      | App (App (Inj (ilf_impl _)) p) q => tauto (learn p env) q
      | App (Inj (ilf_embed from to)) p' =>
        match gs from with
          | None => assumption env p
          | Some _ => tauto (lower_to from to env) p'
        end
      | _ =>
        (** TODO: This is the source of incompleteness **)
        assumption env p
    end.

  Lemma tauto_sound : forall (p : expr ilfunc) (t : typ) env us vs x v
    (_ : exprD us vs p t = Some v)
    (ILO : ILogicOps (typD ts nil t))
    (_ : gs t = Some ILO)
    (_ : FactsD us vs t ILO env = Some x),
    tauto env p = true ->
    @lentails (typD ts nil t) ILO x v.
  Proof.
    refine (@expr_strong_ind _ _ _); intros.
    destruct e; simpl in *; eauto using assumption_sound.
    { destruct i; eauto using assumption_sound.
      red_exprD. simpl in *.
      forward; inv_all; subst.
      specialize (H t).
      rewrite H1 in *. inv_all; subst.
      eapply ltrueR. }
    { destruct e1; eauto using assumption_sound.
      { destruct i; eauto using assumption_sound.
        consider (gs from); eauto using assumption_sound; intros.
        repeat (red_exprD; forward; inv_all; simpl in *; try subst).
        uip_all'.
        eapply lower_to_sound in H3. 4: eassumption.
        3: eauto. 2: eauto. 2: reflexivity.
        destruct H3. intuition.
        eapply H0 in H6.
        5: eassumption. 4: eauto. 3: eauto. 2: eauto with typeclass_instances.
        rewrite H7.
        specialize (Hembed t1 t).
        rewrite H2 in *. rewrite H4 in *. rewrite H1 in *.
        eapply embed_sound. eassumption. }
      { destruct e1_1; eauto using assumption_sound.
        destruct i; eauto using assumption_sound.
        { eapply andb_true_iff in H4. destruct H4.
          repeat (red_exprD; forward; inv_all; subst).
          simpl in *. forward; inv_all; subst.
          subst. subst.
          simpl in *. forward. inv_all; subst. clear H11 H12.
          uip_all'.
          rewrite H2 in *; inv_all; subst.
          eapply landR.
          { eapply H0; eauto.
            eauto with typeclass_instances. }
          { destruct (@FactsD_learn us vs _ _ H2 env (learn e1_2 env) e1_2 _ x H10 H3 eq_refl).
            destruct H1.
            eapply H0 in H5. 5: eassumption. 4: eauto. 3: eauto. 2: eauto with typeclass_instances.
            etransitivity; [ | eassumption ].
            etransitivity; [ | eassumption ].
            eapply landR; eauto.
            { eapply H0; eauto. eauto with typeclass_instances. } } }
        { eapply orb_true_iff in H4.
          repeat (red_exprD; forward; inv_all; simpl in *; try subst).
          revert x0. uip_all'.
          rewrite H1 in *. inv_all; subst.
          destruct H4.
          { eapply lorR1. eapply H0; eauto. eauto with typeclass_instances. }
          { eapply lorR2. eapply H0; eauto. eauto with typeclass_instances. } }
        { repeat (red_exprD; forward; inv_all; simpl in *; try subst).
          uip_all'.
          rewrite H1 in *; inv_all; subst.
          eapply limplAdj.
          destruct (@FactsD_learn us vs _ _ H1 env _ _ _ _ H9 H3 eq_refl).
          destruct H2.
          etransitivity.
          2: eapply H0. 6: eassumption. 5: eassumption. 4: eauto. 3: eauto. 2: eauto with typeclass_instances.
          eauto. } } }
  Qed.

End Tauto.

(**
  Definition test_floor (e : expr ilfunc) (from to : typ) : option (expr ilfunc) :=
    match e with
      | App (Inj (ilf_embed from' to')) e' =>
        if from ?[ eq ] from'
        then Some e'
        else None
      | _ => None
    end.

  Theorem test_floor_sound : forall e t t' e',
                               test_floor e t t' = Some e' ->
                               floor_sound e e' t t'.
  Proof.
    red.
    destruct e; simpl; intuition; try congruence.
    forward. subst.
    inv_all; subst.
    red_exprD.
    forward. inv_all; subst.
    red_exprD. simpl in *.
    Cases.rewrite_all.
    rewrite H4 in *.
    rewrite typ_cast_typ_refl in *.
    inv_all; subst.
    eexists; split; eauto.
    reflexivity.
  Qed.
**)

*)


Require Import HoTT FunextAxiom UnivalenceAxiom.

Require Import basics syntax quotient minus1Trunc.

Module Dedekind.
Import Distributive.
Export Field_pr OrderedRing OrderedMagma_pr.

Section VarSec.

Context {T : Type}.
Variable L : PreringFull T.
Context {Hdec : @Decidable T paths} {HpropLt : RelationProp (<)}
 {Hfield : IsDecField L}
 {Hfo : FullPseudoSemiringOrder L} {Htri : Trichotomic (<)}.

Let Hset : IsHSet T := hset_decidable Hdec.

Class IsCut (L U : T -> Type) := BuildIsCut {
cut_prop_l :> forall x, IsHProp (L x);
cut_prop_u :> forall x, IsHProp (U x);
cut_inhab_l : minus1Trunc (sigT L);
cut_inhab_u : minus1Trunc (sigT U);
cut_round_l : forall q, L q <-> minus1Trunc (exists r, q < r /\ L r);
cut_round_u : forall r, U r <-> minus1Trunc (exists q, q < r /\ U q);
cut_disjoint : forall q, L q -> U q -> Empty;
cut_locat : forall q r, q < r -> minus1Trunc (L q \/ U r)
}.

Record Real := BuildReal {
real_l : T -> Type;
real_u : T -> Type;
real_cut : IsCut real_l real_u
}.

Existing Instance real_cut.
Coercion real_cut : Real >-> IsCut.

Global Instance IsCut_is_prop : forall L U, IsHProp (IsCut L U).
Admitted.

Global Instance Real_is_set : IsHSet Real.
Admitted.

Lemma cut_order : forall L U, IsCut L U ->
forall a b, L a -> U b -> a < b.
Proof.
intros.
destruct (Htri a b). assumption.
destruct s. destruct p.
edestruct cut_disjoint. apply X0. apply X1.
edestruct cut_disjoint. apply X0.
apply cut_round_u. apply min1.
exists b. split. assumption. assumption.
Defined.

Instance lt_compat : IsCompat (+ <).
Proof.
apply invariant_compat.
apply (@fullpseudo_is_fullposet _ L);try apply _.
split; apply Hfo.
apply linvariant_invariant. apply _.
red;apply _.
Defined.

Let Hfullpo : FullPoset L.
Proof.
apply fullpseudo_is_fullposet.
apply HpropLt. split.
apply Hfo. apply Hfo.
Defined.
Existing Instance Hfullpo.

Instance leq_compat : IsCompat (+ <=).
Proof.
admit. (** fuck it **)
Defined.

Lemma lt_plus_leq : forall a b : T, a < b -> forall c d : T, c <= d ->
a + c < b + d.
Proof.
intros.
apply (@lt_iff_le_apart _ _ Hfullpo).
split. apply leq_compat;unfold rrel;simpl.
apply (@lt_iff_le_apart T L _) in X. apply X.
assumption.
admit. (**arghwhy**)
Defined.

Lemma embed_justify : forall t : T, IsCut (fun t' => t' < t) (lt t).
Proof.
split.
- intros;apply HpropLt.
- apply HpropLt.

- apply min1. exists (t + roppV OneV).
  apply transport with (t + ZeroV).
  apply Zero.
  apply Hfo. unfold rrel.
  admit. (** roppV OneV < ZeroV **)

- apply min1. exists (t + OneV).
  change ((fun t' => t' < t + OneV) t). apply transport with (t + ZeroV).
  apply Zero.
  apply Hfo. unfold rrel.
  admit. (** ZeroV < OneV **)

- split.
  intros H.
  admit. (** q < t -> (q+t)/2 between q and t **)
  apply minus1Trunc_rect_nondep;[|apply HpropLt].
  intros [r [Hr Hr']].
  apply @transitivity with r;try assumption.
  admit. (** fullpseudo -> < trans, already proven **)

- split.
  admit. (** q < t -> (q+t)/2 between q and t **)
  apply minus1Trunc_rect_nondep;[|apply HpropLt].
  intros [q [Hq Hq']].
  apply @transitivity with q;try assumption.
  admit. (** fullpseudo -> < trans, already proven **)

- intro. apply Hfo.

- intros.
  admit. (** q < t -> (q+t)/2 between q and t **)
Qed.

Definition embed (t : T) : Real.
Proof.
apply (BuildReal (fun t' => t' < t) (lt t)).
apply embed_justify.
Defined.

Lemma rplus_justify : forall X Y : Real,
IsCut (fun q => minus1Trunc
     (exists r s : T, real_l X r /\ real_l Y s /\ r+s = q))
      (fun q => minus1Trunc
     (exists r s : T, real_u X r /\ real_u Y s /\ r+s = q)).
Proof.
split;try apply _.

- generalize (@cut_inhab_l (real_l X) _ _).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros Hx.
  generalize (@cut_inhab_l (real_l Y) _ _).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros Hy.
  apply min1.
  exists (Hx.1 + Hy.1).
  apply min1. exists (Hx.1). exists (Hy.1).
  split. apply (Hx.2).
  split. apply (Hy.2).
  reflexivity.

- generalize (@cut_inhab_u (real_l X) _ _).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros Hx.
  generalize (@cut_inhab_u (real_l Y) _ _).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros Hy.
  apply min1.
  exists (Hx.1 + Hy.1).
  apply min1. exists (Hx.1). exists (Hy.1).
  split. apply (Hx.2).
  split. apply (Hy.2).
  reflexivity.

- split. apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros H.
  destruct H as [r [s [H [H' H'']]]]. destruct H''.
  apply cut_round_l in H. revert H.
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros [r' Hr'].
  apply cut_round_l in H'. revert H'.
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros [s' Hs'].
  apply min1. exists (r' + s'). destruct Hr',Hs'.
  split.
  apply lt_compat; assumption.
  apply min1. exists r';exists s'.
  repeat (split;auto).

  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros [r [Hr Hr']]. revert Hr'.
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros [r' [s [Hr' [Hs He]]]]. destruct He.
  (* q < r'+s, r' < X, s < Y -> exists r s', r < X, s' < Y, r + s' = q *)
  (* let r := r', s' := q-r' < s < Y *)
  apply min1. exists r'. exists (q + (roppV r')). split. assumption.
  split. apply cut_round_l. apply min1. exists s.
  split;[|assumption].
  apply transport with ((r'+s)+(roppV r')).
  path_via (s + ZeroV).
  path_via (s + (r' + roppV r')).
  ssrapply (@ast_use T (+) _). reflexivity.
  apply ap. apply ropp_r.
  apply Zero.
  apply lt_plus_leq. assumption.
  apply Hfullpo.
  path_via (q + (r' + roppV r')).
  ssrapply (@ast_use T (+) _). reflexivity.
  apply roppP.

- admit. (* basically same as above *)

- intros q H. apply minus1Trunc_rect_nondep;[|intros []].
  intro H'. revert H. apply minus1Trunc_rect_nondep;[|intros []].
  intro H.
  destruct H as [r [s [Hr [Hs He]]]].
  destruct H' as [r' [s' [Hr' [Hs' He']]]].
  destruct He'.
  (* r' > X, s' > Y, r < X, s < Y, r+s = r'+s' -> Empty *)
  (* r = r'+s'-s < X *)
  (* r'+s'-s > X -> absurd *)
  admit.

- intros.
  (* goal: forall q < r, q < X+Y or X+Y < r *)
  admit. (* dunno how to prove *)
Qed.

Definition rPlus : Plus Real.
Proof.
intros X Y.
apply (BuildReal
 (fun q => minus1Trunc (exists r s : T, real_l X r /\ real_l Y s /\ r+s = q))
 (fun q => minus1Trunc (exists r s : T, real_u X r /\ real_u Y s /\ r+s = q))).
apply rplus_justify.
Defined.

(*
forall q X, q < -X <-> X < -q and -X < q <-> -q < X
*)
Lemma ropp_justify : forall X : Real, IsCut
(fun q => real_u X (roppV q))
(fun q => real_l X (roppV q)).
Proof.
intros.
split;try apply _.
- generalize (@cut_inhab_u _ _ X).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros H.
  apply min1. destruct H as [x Hx].
  exists (roppV x).
  eapply transport;[|apply Hx].
  apply inverse;apply gopp_gopp.

- generalize (@cut_inhab_l _ _ X).
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros H.
  apply min1. destruct H as [x Hx].
  exists (roppV x).
  eapply transport;[|apply Hx].
  apply inverse;apply gopp_gopp.

- intros. eapply iff_trans.
  apply cut_round_u.
  split;(apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop]);
  intros H;apply min1;
  destruct H as [r [Hr Hr']];
  exists (roppV r); (split;[admit|]). (* forall a < b -> -b < -a *)
  eapply transport;[|apply Hr'].
  apply inverse;apply gopp_gopp.
  assumption.

- intros. eapply iff_trans.
  apply cut_round_l.
  split;(apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop]);
  intros H;apply min1;
  destruct H as [q [Hq Hq']];
  exists (roppV q); (split;[admit|]). (* forall a < b -> -b < -a *)
  eapply transport;[|apply Hq'].
  apply inverse;apply gopp_gopp.
  assumption.

- intros q H H';revert H;revert H'. apply cut_disjoint.

- intros.
  assert (H:roppV r < roppV q). admit. clear X0.
  apply (@cut_locat _ _ X) in H. revert H.
  apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
  intros H;apply min1;destruct H as [H|H];[right|left];assumption.
Qed.

Definition rOpp : forall X : Real, Real.
Proof.
intros. econstructor.
apply (ropp_justify X).
Defined.

Definition r0 : Real := embed ZeroV.

Definition mult_lower (X Y : Real) : T -> Type
 := fun q => minus1Trunc (exists a b c d : T, real_l X a /\ real_u X b
   /\ real_l Y c /\ real_u Y d /\ q < a°c /\ q < a°d /\ q < b°c /\ q < b°d).

Definition mult_upper (X Y : Real) : T -> Type
 := fun q => minus1Trunc (exists a b c d : T, real_l X a /\ real_u X b
   /\ real_l Y c /\ real_u Y d /\ a°c < q /\ a°d < q /\ b°c < q /\ b°d < q).

Lemma mult_justify : forall X Y : Real, IsCut (mult_lower X Y) (mult_upper X Y).
Proof.
intros;split;try apply _;
admit. (* later *)
Qed.

Definition rMult : Mult Real.
Proof.
intros X Y. econstructor.
exact (mult_justify X Y).
Defined.

Definition r1 : Real := embed OneV.

Definition rLeq : Leq Real := fun X Y =>
forall q : T, real_l X q -> real_l Y q.
Definition rLt : Lt Real := fun X Y =>
minus1Trunc (exists q : T, real_u X q /\ real_l Y q).
Definition rApart : Apart Real := fun X Y =>
rLt X Y \/ rLt Y X.

Instance rFull : PreringFull Real
 := BuildLLRRR_Class Real rPlus rMult rApart rLeq rLt.

Lemma real_eq : forall X Y : Real,
(forall q, real_l X q <-> real_l Y q) ->
(forall q, real_u X q <-> real_u Y q) ->
X=Y.
Proof.
admit. (* etc *)
Defined.

Instance rplus_comm : @Commutative Real (+).
Proof.
red;unfold gop.
assert (Hl : forall X Y : Real, forall q, real_l (X+Y) q -> real_l (Y+X) q).
simpl. intros X Y q.
apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
intro H;apply min1;destruct H as [r [s [H [H0 H1]]]].
exists s;exists r;repeat (split;try assumption).
path_via (r+s).
apply commutative. apply Hfield.

assert (Hu : forall X Y : Real, forall q, real_u (X+Y) q -> real_u (Y+X) q).
simpl. intros X Y q.
apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
intro H;apply min1;destruct H as [r [s [H [H0 H1]]]].
exists s;exists r;repeat (split;try assumption).
path_via (r+s).
apply commutative. apply Hfield.

intros. apply real_eq;
intros;split;auto.
Defined.

Instance rplus_assoc : @Associative Real (+).
Proof.
red;unfold gop.
intros X Y Z.
apply real_eq;simpl;intros q;(split;
(apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop]);intro H;
[destruct H as [r [s [H [H' H0]]]]|destruct H as [r[s[H' [H H0]]]]]);
revert H';(apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop]);
intro H';destruct H' as [r'[s' [H1 [H2 H3]]]];apply min1;
destruct H0;destruct H3;repeat first
   [econstructor | apply min1 | apply H1 | apply H2 | apply H];
first [apply associative | apply inverse;apply associative];apply Hfield.
Defined.

Instance rplus_sg : @IsSemigroup Real (+). split;apply _. Defined.

Instance r0_is_id : IsId (+) r0.
Proof.
apply left_id_id.
red. unfold gop.
intro X.
unfold r0. apply real_eq; simpl;
(split;[apply minus1Trunc_rect_nondep;[|
    first [apply cut_prop_l | apply cut_prop_u]];
        intros H;destruct H as [r [s [H [H0 H1]]]];destruct H1 |]).

apply cut_round_l. apply min1. exists s. split;auto.
apply transport with (ZeroV + s). apply Zero.
admit. (* plus_lt_leq_lt *)

intros H.
apply cut_round_l in H. revert H.
apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
intros H;apply min1. destruct H as [r [H H']].
exists (q + roppV r). exists r.
split. admit. (* q < r -> q - r < 0 *)
split. assumption. path_via (q + (roppV r + r)).
apply inverse;apply associative;apply Hfield.
apply (roppP r). (* bit slow, change for other? *)

apply cut_round_u. apply min1. exists s. split;auto.
change ((fun k => k < r + s) s). apply transport with (ZeroV + s).
apply Zero.
admit. (* plus_lt_leq_lt *)

intros H. apply cut_round_u in H. revert H.
apply minus1Trunc_rect_nondep;[|apply minus1Trunc_is_prop].
intros H;apply min1. destruct H as [r [H H']].
exists (q + roppV r). exists r.
split. admit. (* r < q -> 0 < q - r *)
split. assumption. path_via (q + (roppV r + r)).
apply inverse;apply associative;apply Hfield.
apply (roppP r). (* bit slow, change for other? *)
Defined.

Instance rplus_monoid : @IsMonoid Real (+).
Proof. split;try apply _;econstructor;apply _. Defined.

Instance rLeq_poset : @Poset Real (<=).
Proof.
split.
- red. unfold leq. simpl. unfold rLeq.
  intros;eauto.

- intro. hnf. auto.

- hnf. intros. hnf in X,X0.
  apply real_eq. split;auto.

  split;intro H.
  pose (H' := H);clearbody H'.
  apply cut_round_u in H'.
  revert H';apply minus1Trunc_rect_nondep;[|apply cut_prop_u].
  intros H'. destruct H' as [q' [H' Hq']].
  apply (@cut_locat _ _ y) in H'. revert H'.
  apply minus1Trunc_rect_nondep;[|apply cut_prop_u].
  intros H'. destruct H' as [H'|H'];try assumption.
  apply X0 in H'.
  destruct (@cut_disjoint _ _ x _ H' Hq').

  pose (H' := H);clearbody H'.
  apply cut_round_u in H'.
  revert H';apply minus1Trunc_rect_nondep;[|apply cut_prop_u].
  intros H'. destruct H' as [q' [H' Hq']].
  apply (@cut_locat _ _ x) in H'. revert H'.
  apply minus1Trunc_rect_nondep;[|apply cut_prop_u].
  intros H'. destruct H' as [H'|H'];try assumption.
  apply X in H'.
  destruct (@cut_disjoint _ _ y _ H' Hq').
Defined.

Lemma rlt_embed_l : forall X q, real_l X q <-> embed q < X.
Proof.
intros X. apply cut_round_l.
Defined.

Lemma prod_comm_rw : prod = fun A B => B*A.
Proof.
repeat (apply funext_axiom;intro).
apply univalence_axiom.
apply equiv_prod_symm.
Defined.

Lemma rlt_embed_u : forall X q, real_u X q <-> X < embed q.
Proof.
intros X.
unfold lt;simpl;unfold rLt. simpl.
rewrite prod_comm_rw. apply cut_round_u.
Qed. (* because lel *)

Instance embed_plus_morph : Magma.IsMorphism (+) (+) embed.
Proof.
red. unfold gop.
intros X Y.
apply rLeq_poset;hnf;simpl.
- admit.

- intros q.

 apply minus1Trunc_rect_nondep
Defined.

Instance ropp_inverse : forall X : Real, IsInverse (+) X (rOpp X).
Proof.
intros. apply linverse_inverse.
red. unfold gop. apply transport with r0;[|apply _].
unfold r0. apply real_eq;simpl;intros q;(split;[intros H|
  apply minus1Trunc_rect_nondep;[|apply HpropLt];intros [r [s [H [H0 H1]]]]]).

- (* needs archimedean ?? *)
Defined.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.

Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Lemma HMAC_DRBG_generate_helper_Z_any_prop_fst:
  forall (P: list byte -> Prop) HMAC key v z,
    0 <= z ->
    P v ->
    (forall x y, P (HMAC x y)) ->
    P (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)).
Proof.
  intros P HMAC key v z Hz Hv H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); omega).
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    rewrite (Z_div_mod_eq z 32); try omega.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    rewrite <- Heqn.
    change (Z.of_nat 0) with 0.
    change (32 * 0 + z mod 32) with (z mod 32).
    change (Z.of_nat 32) with 32.
    remember (0 >=? z mod 32) as zero_geb_z; destruct zero_geb_z.
    auto.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    remember (0 >=? z mod 32 - 32) as zero_geb_z_minus_32; destruct zero_geb_z_minus_32.
    apply H.
    {
      rewrite Z.geb_leb in Heqzero_geb_z_minus_32.
      symmetry in Heqzero_geb_z_minus_32; apply Z.leb_gt in Heqzero_geb_z_minus_32.
      pose proof (Z_mod_lt z 32); omega.
    }
  }
  {
    rewrite (Z_div_mod_eq z 32); try omega.
    rewrite <- Heqn.
    assert (Hn: 32 * Z.of_nat (S n0) + z mod 32 = 32 * Z.of_nat n0 + z mod 32 + 32).
    {
      rewrite Nat2Z.inj_succ.
      rewrite <- Zmult_succ_r_reverse.
      omega.
    }
    rewrite Hn.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    destruct (0 >=? 32 * Z.of_nat n0 + z mod 32 + 32); auto.
    change (Z.of_nat 32) with 32.
    replace (32 * Z.of_nat n0 + z mod 32 + 32 - 32) with (32 * Z.of_nat n0 + z mod 32) by omega.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (32 * Z.of_nat n0 + z mod 32)) as result; destruct result.
    simpl.
    apply H.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_fst:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v z) ->
    HMAC v' key = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); omega).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by omega.
    rewrite Z.geb_leb.
    apply Z.leb_gt; omega.
  }
  rewrite HMAC_DRBG_generate_helper_Z_equation.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by omega.
  rewrite H.
  reflexivity.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_snd:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)) ->
    snd (HMAC_DRBG_generate_helper_Z HMAC key v z) ++ v' = snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); omega).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by omega.
    rewrite Z.geb_leb.
    apply Z.leb_gt; omega.
  }
  remember (HMAC_DRBG_generate_helper_Z HMAC key v z) as saved;
    rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by omega.
  rewrite H.
  erewrite <- HMAC_DRBG_generate_helper_Z_incremental_fst; eauto.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_fst:
  forall HMAC key v z,
    0 <= z ->
    Zlength v = 32 ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    Zlength (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)) = 32.
Proof.
  apply HMAC_DRBG_generate_helper_Z_any_prop_fst.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_snd:
  forall HMAC key v z,
    0 <= z ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    (exists n, z = n * 32) ->
    Zlength (snd (HMAC_DRBG_generate_helper_Z HMAC key v z)) = z.
Proof.
  intros HMAC key v z Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by omega.
  generalize dependent z. revert Hlength.
  induction (Z.to_nat n); intros.
  {
    change (Z.of_nat 0) with 0 in Hn.
    change (0 * 32) with 0 in Hn.
    subst.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    reflexivity.
  }
  {
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn.
    rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; omega.
    }
    rewrite Hf.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (Z.of_nat n0 * 32 + 32 - Z.of_nat 32)) as result; destruct result.
    simpl.
    rewrite Zlength_correct.
    rewrite app_length.
    rewrite Nat2Z.inj_add.
    do 2 rewrite <- Zlength_correct.
    rewrite Hlength.
    replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v
                (Z.of_nat n0 * 32 + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
    change (Z.of_nat 32) with 32.
    rewrite IHn0; auto; omega.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_equiv:
  forall HMAC key v z incr,
    0 <= z ->
    0 < incr <= 32 ->
    (exists n, z = n * 32) ->
    HMAC_DRBG_generate_helper_Z HMAC key v (z + incr) = HMAC_DRBG_generate_helper_Z HMAC key v (z + 32).
Proof.
  intros HMAC key v z incr Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by omega.
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    (* base case *)
    change ((Z.of_nat 0) * 32) with 0 in Hn.
    subst z; simpl.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; omega.
    }
    rewrite Hf.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf2: 0 >=? incr - Z.of_nat 32 = true).
    {
      change (Z.of_nat 32) with 32.
      rewrite Z.geb_leb.
      apply Z.leb_le; omega.
    }
    rewrite Hf2.
    reflexivity.
  }
  {
    (* inductive case *)
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn; rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 + incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; omega.
    }
    rewrite Hf.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + incr - 32) with (Z.of_nat n0 * 32 + incr) by omega.
    rewrite IHn0; try omega.
    remember (let (v0, rest) :=
        HMAC_DRBG_generate_helper_Z HMAC key v (Z.of_nat n0 * 32 + 32) in
    (HMAC v0 key, rest ++ HMAC v0 key)) as saved; rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
    assert (Hf2: 0 >=? Z.of_nat n0 * 32 + 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; omega.
    }
    rewrite Hf2.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + 32 - 32) with (Z.of_nat n0 * 32 + 32) by omega.
    reflexivity.
  }
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^166 - 5
Base: 55 + 1/3
***)

Definition curve : CurveParameters :=
  {|
    sz := 3%nat;
    base := 55 + 1/3;
    bitwidth := 64;
    s := 2^166;
    c := [(1, 5)];
    carry_chains := Some [seq 0 (pred 3); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.