Require Export low_mods.
Require Import Rep_Pred_FOv list_rel_compl.

(* Instantiates any of the predicates that occur in the consequent of alpha
  but not in the antecedent of alpha with "falsum". *)
Definition instant_cons_empty alpha : SecOrder :=
  replace_pred_l alpha (list_rel_compl (preds_in (calc_cons_SO alpha))
                                       (preds_in (calc_ante_SO alpha)))
       (nlist_list _ (nlist_var (length
          (list_rel_compl (preds_in (calc_cons_SO alpha))
                          (preds_in (calc_ante_SO alpha)))) (Var 1)))
       (nlist_list _ (nlist_empty (length
          (list_rel_compl (preds_in (calc_cons_SO alpha))
                          (preds_in (calc_ante_SO alpha)))))).

Definition instant_cons_empty' alpha beta : SecOrder :=
  replace_pred_l beta (list_rel_compl (preds_in beta)  (preds_in alpha))
          (nlist_list _ (nlist_var (length
              (list_rel_compl (preds_in beta) (preds_in alpha))) (Var 1)))
          (nlist_list _ (nlist_empty (length
              (list_rel_compl (preds_in beta) (preds_in alpha))))).

Lemma instant_cons_empty_predSO : forall P x,
    instant_cons_empty (predSO P x) = (predSO P x).
Proof.
  unfold instant_cons_empty. intros P x.
  simpl.  destruct (in_predicate_dec P (P :: nil)) as [H | H].
  reflexivity. simpl in *. firstorder.
Qed.

Lemma instant_cons_empty_relatSO : forall x y,
  instant_cons_empty (relatSO x y) = (relatSO x y).
Proof.
  unfold instant_cons_empty.
  intros [xn] [ym].
  reflexivity.
Qed.

Lemma instant_cons_empty_eqFO : forall x y,
  instant_cons_empty (eqFO x y) = (eqFO x y).
Proof.
  unfold instant_cons_empty.
  intros [xn] [ym].
  reflexivity.
Qed.

Lemma instant_cons_empty'_allFO : forall alpha beta y,
  instant_cons_empty' alpha (allFO y beta) =
  allFO y (instant_cons_empty' alpha beta).
Proof.
  intros.  unfold instant_cons_empty'.
  rewrite rep_pred_l_allFO. auto.
Qed.

Lemma instant_cons_empty'_exFO : forall alpha beta y,
  instant_cons_empty' alpha (exFO y beta) =
  exFO y (instant_cons_empty' alpha beta).
Proof.
  intros. destruct y.  unfold instant_cons_empty'.
  rewrite rep_pred_l_exFO. auto.
Qed.

Lemma instant_cons_empty'_negSO : forall alpha beta,
  instant_cons_empty' alpha (negSO beta) =
  negSO (instant_cons_empty' alpha beta).
Proof.
  intros.  unfold instant_cons_empty'.
  rewrite rep_pred_l_negSO. auto.
Qed.


Set Implicit Arguments.

Inductive Void : Type := .

Class Container :=
  {
    Shape   : Type;
    Pos     : Shape -> Type;
  }.

Section Ext.

  Inductive Ext (C : Container) (A : Type) :=
  | ext : forall (s : Shape), (Pos s -> A) -> Ext C A.

  Global Arguments Ext : clear implicits.
  Global Arguments ext [_] [_] s pf.

End Ext.

Class Iso (F : Type -> Type) (C : Container) :=
  {
    to              : forall (A : Type), Ext C A -> F A;
    from            : forall (A : Type), F A -> Ext C A;
    to_from_inverse : forall (A : Type) (fx : F A), to (from fx) = fx;
    from_to_inverse : forall (A : Type) (e : Ext C A), from (to e) = e
  }.

Arguments to [_] [_] [_] [_].
Arguments from [_] [_] [_] [_].


Set Implicit Arguments.

Require Import
        List
        Semantics.WellFormedness.WellFormedness
        Syntax.Syntax
        Tactics.Tactics
        Utils.ListUtils.

Definition compile_from_hypothesis
           (hyps : list research_hypothesis)
           (p : treatment * experimental_object)
          : list application
  := map (fun hyp => MkApplication (dep_instrument (hyp_variable hyp))
                                (tr_command (fst p))
                                (obj_argument (snd p))) hyps.

Definition compile_execution_script (e : experiment) : execution_script :=
  replicate (des_runs (exp_design e))
            (nodup eq_application_dec
                   (flat_map (fun p => compile_from_hypothesis (exp_hypothesis e) p)
                             (des_function (exp_design e)))).

Lemma compile_hypothesis_sound
  : forall hyps hyp p tr obj app,
    p = (tr,obj) ->
    In hyp hyps ->
    app = MkApplication (dep_instrument (hyp_variable hyp))
                        (tr_command tr)
                        (obj_argument obj) ->
    In app (compile_from_hypothesis hyps p).
Proof.
  induction hyps ; intros ; try solve [simpl in * ; contradiction].
  rewrite H. simpl in H0. destruct H0 ; substs. crush. right*.
Qed.

Hint Resolve compile_hypothesis_sound.

Lemma compile_execution_sound
  : forall fs hyps hyp tr obj app,
    In (tr,obj) fs ->
    In hyp hyps ->
    app = MkApplication (dep_instrument (hyp_variable hyp))
                        (tr_command tr)
                        (obj_argument obj) ->
    In app
    (nodup eq_application_dec
       (flat_map
          (fun p => compile_from_hypothesis hyps p) fs)).
Proof.
  induction fs ; intros ; apply nodup_In.
  +
    crush.
  +
    simpl in *.
    destruct H. rewrite H in *.
    apply in_app_iff.
    left*.
    apply in_app_iff.
    right*.
    eapply flat_map_In with (x := (tr, obj)) ; crush.
    eapply compile_hypothesis_sound ; eauto.
Qed.

Theorem compilation_sound
  : forall e, wf_experiment e ->
    forall hyp, In hyp (exp_hypothesis e) ->
           forall p tr obj, In p (des_function (exp_design e)) ->
                       p = (tr , obj) ->
                       forall app, app = MkApplication (dep_instrument (hyp_variable hyp))
                                                  (tr_command tr)
                                                  (obj_argument obj) ->
                     (count_occ
                        eq_application_dec
                        (compile_execution_script e) app) = (des_runs (exp_design e)).
Proof.
  intros ;
    unfold compile_execution_script.
  assert (Hd : NoDup (nodup eq_application_dec
                     (flat_map (fun p => compile_from_hypothesis (exp_hypothesis e)
                                                              p)
                               (des_function (exp_design e))))) by
      apply NoDup_nodup.
  eapply (replicate_count_occ eq_application_dec)
    with (x := app)(n := des_runs (exp_design e))
    in Hd ; eauto.
  inverts* H.
  inverts* H13.
  eapply compile_execution_sound ; eauto ; crush.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import Decimal Ascii String.

(** * Conversion between decimal numbers and Coq strings *)

(** Pretty straightforward, which is precisely the point of the
    [Decimal.int] datatype. The only catch is [Decimal.Nil] : we could
    choose to convert it as [""] or as ["0"]. In the first case, it is
    awkward to consider "" (or "-") as a number, while in the second case
    we don't have a perfect bijection. Since the second variant is implemented
    thanks to the first one, we provide both. *)

Local Open Scope string_scope.

(** Parsing one char *)

Definition uint_of_char (a:ascii)(d:option uint) :=
 match d with
 | None => None
 | Some d =>
   match a with
   | "0" => Some (D0 d)
   | "1" => Some (D1 d)
   | "2" => Some (D2 d)
   | "3" => Some (D3 d)
   | "4" => Some (D4 d)
   | "5" => Some (D5 d)
   | "6" => Some (D6 d)
   | "7" => Some (D7 d)
   | "8" => Some (D8 d)
   | "9" => Some (D9 d)
   | _ => None
   end
 end%char.

Lemma uint_of_char_spec c d d' :
  uint_of_char c (Some d) = Some d' ->
  (c = "0" /\ d' = D0 d \/
  c = "1" /\ d' = D1 d \/
  c = "2" /\ d' = D2 d \/
  c = "3" /\ d' = D3 d \/
  c = "4" /\ d' = D4 d \/
  c = "5" /\ d' = D5 d \/
  c = "6" /\ d' = D6 d \/
  c = "7" /\ d' = D7 d \/
  c = "8" /\ d' = D8 d \/
  c = "9" /\ d' = D9 d)%char.
Proof.
 destruct c as [[|] [|] [|] [|] [|] [|] [|] [|]];
 intros [= <-]; intuition.
Qed.

(** Decimal/String conversion where [Nil] is [""] *)

Module NilEmpty.

Fixpoint string_of_uint (d:uint) :=
 match d with
 | Nil => EmptyString
 | D0 d => String "0" (string_of_uint d)
 | D1 d => String "1" (string_of_uint d)
 | D2 d => String "2" (string_of_uint d)
 | D3 d => String "3" (string_of_uint d)
 | D4 d => String "4" (string_of_uint d)
 | D5 d => String "5" (string_of_uint d)
 | D6 d => String "6" (string_of_uint d)
 | D7 d => String "7" (string_of_uint d)
 | D8 d => String "8" (string_of_uint d)
 | D9 d => String "9" (string_of_uint d)
 end.

Fixpoint uint_of_string s :=
 match s with
 | EmptyString => Some Nil
 | String a s => uint_of_char a (uint_of_string s)
 end.

Definition string_of_int (d:int) :=
 match d with
 | Pos d => string_of_uint d
 | Neg d => String "-" (string_of_uint d)
 end.

Definition int_of_string s :=
 match s with
 | EmptyString => Some (Pos Nil)
 | String a s' =>
   if ascii_dec a "-" then option_map Neg (uint_of_string s')
   else option_map Pos (uint_of_string s)
 end.

(* NB: For the moment whitespace between - and digits are not accepted.
   And in this variant [int_of_string "-" = Some (Neg Nil)].

Compute int_of_string "-123456890123456890123456890123456890".
Compute string_of_int (-123456890123456890123456890123456890).
*)

(** Corresponding proofs *)

Lemma usu d :
  uint_of_string (string_of_uint d) = Some d.
Proof.
 induction d; simpl; rewrite ?IHd; simpl; auto.
Qed.

Lemma sus s d :
  uint_of_string s = Some d -> string_of_uint d = s.
Proof.
 revert d.
 induction s; simpl.
 - now intros d [= <-].
 - intros d.
   destruct (uint_of_string s); [intros H | intros [=]].
   apply uint_of_char_spec in H.
   intuition subst; simpl; f_equal; auto.
Qed.

Lemma isi d : int_of_string (string_of_int d) = Some d.
Proof.
 destruct d; simpl.
 - unfold int_of_string.
   destruct (string_of_uint d) eqn:Hd.
   + now destruct d.
   + destruct ascii_dec; subst.
     * now destruct d.
     * rewrite <- Hd, usu; auto.
 - rewrite usu; auto.
Qed.

Lemma sis s d :
 int_of_string s = Some d -> string_of_int d = s.
Proof.
 destruct s; [intros [= <-]| ]; simpl; trivial.
 destruct ascii_dec; subst; simpl.
 - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-].
   simpl; f_equal. now apply sus.
 - destruct d; [ | now destruct uint_of_char].
   simpl string_of_int.
   intros. apply sus; simpl.
   destruct uint_of_char; simpl in *; congruence.
Qed.

End NilEmpty.

(** Decimal/String conversions where [Nil] is ["0"] *)

Module NilZero.

Definition string_of_uint (d:uint) :=
 match d with
 | Nil => "0"
 | _ => NilEmpty.string_of_uint d
 end.

Definition uint_of_string s :=
 match s with
 | EmptyString => None
 | _ => NilEmpty.uint_of_string s
 end.

Definition string_of_int (d:int) :=
 match d with
 | Pos d => string_of_uint d
 | Neg d => String "-" (string_of_uint d)
 end.

Definition int_of_string s :=
 match s with
 | EmptyString => None
 | String a s' =>
   if ascii_dec a "-" then option_map Neg (uint_of_string s')
   else option_map Pos (uint_of_string s)
 end.

(** Corresponding proofs *)

Lemma uint_of_string_nonnil s : uint_of_string s <> Some Nil.
Proof.
 destruct s; simpl.
 - easy.
 - destruct (NilEmpty.uint_of_string s); [intros H | intros [=]].
   apply uint_of_char_spec in H.
   now intuition subst.
Qed.

Lemma sus s d :
  uint_of_string s = Some d -> string_of_uint d = s.
Proof.
 destruct s; [intros [=] | intros H].
 apply NilEmpty.sus in H. now destruct d.
Qed.

Lemma usu d :
  d<>Nil -> uint_of_string (string_of_uint d) = Some d.
Proof.
 destruct d; (now destruct 1) || (intros _; apply NilEmpty.usu).
Qed.

Lemma usu_nil :
  uint_of_string (string_of_uint Nil) = Some Decimal.zero.
Proof.
 reflexivity.
Qed.

Lemma usu_gen d :
  uint_of_string (string_of_uint d) = Some d \/
  uint_of_string (string_of_uint d) = Some Decimal.zero.
Proof.
 destruct d; (now right) || (left; now apply usu).
Qed.

Lemma isi d :
  d<>Pos Nil -> d<>Neg Nil ->
  int_of_string (string_of_int d) = Some d.
Proof.
 destruct d; simpl.
 - intros H _.
   unfold int_of_string.
   destruct (string_of_uint d) eqn:Hd.
   + now destruct d.
   + destruct ascii_dec; subst.
     * now destruct d.
     * rewrite <- Hd, usu; auto. now intros ->.
 - intros _ H.
   rewrite usu; auto. now intros ->.
Qed.

Lemma isi_posnil :
 int_of_string (string_of_int (Pos Nil)) = Some (Pos Decimal.zero).
Proof.
 reflexivity.
Qed.

(** Warning! (-0) won't parse (compatibility with the behavior of Z). *)

Lemma isi_negnil :
 int_of_string (string_of_int (Neg Nil)) = Some (Neg (D0 Nil)).
Proof.
 reflexivity.
Qed.

Lemma sis s d :
 int_of_string s = Some d -> string_of_int d = s.
Proof.
 destruct s; [intros [=]| ]; simpl.
 destruct ascii_dec; subst; simpl.
 - destruct (uint_of_string s) eqn:Hs; simpl; intros [= <-].
   simpl; f_equal. now apply sus.
 - destruct d; [ | now destruct uint_of_char].
   simpl string_of_int.
   intros. apply sus; simpl.
   destruct uint_of_char; simpl in *; congruence.
Qed.

End NilZero.


(* External import(s). *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Import         ListNotations.
(* Internal import(s). *)
Require Import Basics.Identifier.
Require Import Basics.Aux.
Require Import Basics.Map.
Require Import Languages.LC.Syntax.
Require Import Languages.LC.Semantics.

Definition path       : Type := list cfg.

Definition baseCaseSet_varsAEqual: cfg -> cfg -> Prop :=
  fun c1 c2 =>
    match (c1, c2) with
    | ([_ | e1], [_ | e2]) => find A e1 = find A e2
    end.

Definition baseCaseSet_envsEqual: cfg -> cfg -> Prop :=
  fun c1 c2 => c1 = c2.

Definition isCompletePath (p: path): Prop :=
  match p with
  | nil         => False
  | _           =>
    match (last p emptyCfg) with
    | [EmptyStack | _] => True
    | _                => False
    end
  end.

Inductive isCompletePath_R: cfg -> cfg -> Prop :=
  | CPR_BaseCase: forall P,
      runStep P = None -> isCompletePath_R P P

  | CPR_IndCase : forall P P' P'',
      runStep P = Some P' /\ isCompletePath_R P' P'' ->
        isCompletePath_R P P''.

Definition fullSimulation (P Q: cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  forall P', isCompletePath_R P P' ->
    exists Q', isCompletePath_R Q Q' /\
      baseCaseSet P' Q'.

Definition fullEquivalence (P Q:cfg) (baseCaseSet: cfg->cfg->Prop): Prop :=
  fullSimulation P Q baseCaseSet /\ fullSimulation Q P baseCaseSet.

Lemma stepLeft: forall P Q P' baseCaseSet,
  runStep P = Some P' /\ fullSimulation P' Q baseCaseSet  ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeft H] P' H'.
  inversion H'.
  - subst. rewrite HStepLeft in H0.
    inversion H0.
  - subst. destruct H0.
    rewrite HStepLeft in H0.
    injection H0.
    intro HInj.
    rewrite <- HInj in H1.
    specialize (H P').
    specialize (H H1).
    apply H.
Qed.

Lemma stepRight: forall P Q Q' baseCaseSet,
  runStep Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRight H] P' H'.
  specialize (H P').
  apply H in H'.
  destruct H', H0.
  assert (isCompletePath_R QStart x). {
    eapply CPR_IndCase.
    split.
    - apply HStepRight.
    - assumption.
  }
  exists x.
  split; assumption.
Qed.

Lemma stepLeftN (n:nat): forall P Q P' baseCaseSet,
  runNSteps n P = Some P' /\ fullSimulation P' Q baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart PNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepLeftN H] P' H'.
  inversion H'.
  - subst.
    unfold runNSteps, ret, bind in HStepLeftN.
    destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
    + Search Nat.eqb.
      apply EqNat.beq_nat_true in H_eqb_n_0.
      rewrite H_eqb_n_0 in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + apply EqNat.beq_nat_false in H_eqb_n_0.
      assert (HAux: exists n', n = S n'). {
        exists (Nat.pred n).
        Search Nat.pred.
        symmetry.
        apply PeanoNat.Nat.succ_pred.
        assumption.
      }
      destruct HAux.
      rewrite H1 in HStepLeftN.
      simpl in HStepLeftN.
      unfold bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion HStepLeftN.
  - subst. destruct H0.
    generalize dependent PStart.
    generalize dependent QStart.
    generalize dependent PNext.
    generalize dependent P'.
    generalize dependent P'0.
    induction n; intros.
    + unfold runNSteps, ret, bind in HStepLeftN.
      injection HStepLeftN as HInj.
      subst.
      apply H.
      assumption.
    + unfold runNSteps, ret, bind in HStepLeftN.
      rewrite H0 in HStepLeftN.
      inversion H1.
      * subst.
        destruct (Nat.eqb n 0) eqn:H_eqb_n_0.
        -- apply EqNat.beq_nat_true in H_eqb_n_0.
           rewrite H_eqb_n_0 in HStepLeftN.
           injection HStepLeftN as HInj.
           subst.
           apply H.
           assumption.
        -- apply EqNat.beq_nat_false in H_eqb_n_0.
           assert (HAux: exists n', n = S n'). {
            exists (Nat.pred n).
            Search Nat.pred.
            symmetry.
            apply PeanoNat.Nat.succ_pred.
            assumption.
           }
           destruct HAux.
           rewrite H3 in HStepLeftN.
           rewrite H2 in HStepLeftN.
           inversion HStepLeftN.
       * subst.
         destruct H2.
         specialize (IHn P'1).
         specialize (IHn P').
         specialize (IHn H3).
         specialize (IHn PNext).
         specialize (IHn QStart).
         specialize (IHn H).
         specialize (IHn P'0).
         specialize (IHn HStepLeftN).
         specialize (IHn H1).
         specialize (IHn H2).
         apply IHn.
Qed.

Lemma stepRightN (n:nat): forall P Q Q' baseCaseSet,
  runNSteps n Q = Some Q' /\ fullSimulation P Q' baseCaseSet ->
  fullSimulation P Q baseCaseSet.
Proof.
  intros PStart QStart QNext baseCaseSet.
  unfold fullSimulation.
  intros [HStepRightN H] P' H'.
  generalize dependent PStart.
  generalize dependent QStart.
  generalize dependent QNext.
  generalize dependent P'.
  induction n; intros.
  - unfold runNSteps, ret, bind in HStepRightN.
    injection HStepRightN as HInj.
    subst.
    apply H.
    assumption.
  - assert (H'': exists Q' : cfg, isCompletePath_R QNext Q' /\ baseCaseSet P' Q'). {
      apply H.
      apply H'.
    }
    destruct H'', H0.
    unfold runNSteps, bind in HStepRightN.
    destruct (runStep QStart) eqn:H_step_QStart.
    + specialize (IHn P').
      specialize (IHn QNext).
      specialize (IHn c).
      specialize (IHn HStepRightN).
      specialize (IHn PStart).
      specialize (IHn H).
      specialize (IHn H').
      destruct IHn.
      destruct H2.
      exists x0.
      split.
      * eapply CPR_IndCase.
        split.
        -- apply H_step_QStart.
        -- apply H2.
      * apply H3.
    + inversion HStepRightN.
Qed.

Ltac stepLN n :=
  eapply (stepLeftN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.
Ltac stepRN n :=
  eapply (stepRightN n); split;
  [reflexivity | unfold find, update, id_eqb];
  simpl.

Ltac stepLNRM n m :=
  stepLN n; stepRN m.
Ltac stepLRN n :=
  stepLNRM n n.

Ltac stepL :=
  stepLN 1.
Ltac stepR :=
  stepRN 1.
Ltac stepLR :=
  stepLRN 1.

Ltac stepLUntilDone :=
  repeat stepL.
Ltac stepRUntilDone :=
  repeat stepR.
Ltac stepLRUntilDone :=
  stepLUntilDone; stepRUntilDone.

Ltac destLinIneq_native eqName :=
  match goal with
  | [ |- context[Nat.ltb ?x ?y] ] =>
      destruct (Nat.ltb x y) eqn:eqName;
       [(* - *)
        apply PeanoNat.Nat.ltb_lt in eqName;
        try (
         assert (~ x < y) by lia;
         contradiction
        ) |
        (* - *)
        apply PeanoNat.Nat.ltb_ge in eqName;
        try (
          assert (~ y <= x) by lia;
          contradiction
        )]
  | [ |- context[Nat.eqb ?x ?y] ] =>
      destruct (Nat.eqb x y) eqn:eqName;
      [(* - *)
       apply PeanoNat.Nat.eqb_eq in eqName;
       try (
        assert (~ x = y) by lia;
        contradiction
       ) |
       (* - *)
       apply PeanoNat.Nat.eqb_neq in eqName;
       try (
        assert (~ x <> y) by lia;
        contradiction
       )]
  end.

Tactic Notation "destLinIneq" :=
  let H := fresh in destLinIneq_native H.
Tactic Notation "destLinIneq" simple_intropattern(eqName) :=
  destLinIneq_native eqName.

Ltac destAndClearLinIneq_native eqName :=
  destLinIneq eqName; clear eqName.

Tactic Notation "destAndClearLinIneq" :=
  let H := fresh in destAndClearLinIneq_native H.
Tactic Notation "destAndClearLinIneq" simple_intropattern(eqName) :=
  destAndClearLinIneq_native eqName.

Ltac stepLUntilAfterIte :=
  stepLUntilDone;
  repeat destAndClearLinIneq;
  stepL.
Ltac stepRUntilAfterIte :=
  stepRUntilDone;
  repeat destAndClearLinIneq;
  stepR.
Ltac stepLRUntilAfterIte :=
  stepLUntilAfterIte;
  stepRUntilAfterIte.

Ltac fullSim base_case_set :=
  repeat (
    stepLRUntilDone;
    repeat destAndClearLinIneq);
  unfold fullSimulation;
  intros P' H_CPR;
  (exists P'; split;
     [(* - *)
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        apply CPR_BaseCase; compute; reflexivity |
        (* + *)
        destruct contra as [contra]; inversion contra
       ] |
      (* - *)
      unfold base_case_set;
      inversion H_CPR as [| config config' config'' contra];
       [(* + *)
        unfold find; simpl; try (congruence || reflexivity) |
        (* + *)
        destruct contra as [contra]; inversion contra
       ]
     ]
  ) ||
  (eexists; split; simpl;
    [(* - *)
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       apply CPR_BaseCase; compute; reflexivity |
       (* + *)
       destruct contra as [contra]; inversion contra
      ] |
     (* - *)
     unfold base_case_set;
     inversion H_CPR as [| config config' config'' contra];
      [(* + *)
       unfold find; simpl; try (congruence || reflexivity) |
       (* + *)
       destruct contra as [contra]; inversion contra
      ]
    ]
  ).


(* PUBLIC DOMAIN *)
(* Author: Georgy Dunaev, georgedunaev@gmail.com *)
Require Export Coq.Vectors.Vector.
Require Export Coq.Lists.List.
Require Import Bool.Bool.
(*Require Import Logic.FunctionalExtensionality.*)
Require Import Coq.Program.Wf.
Require Import Lia.
Add LoadPath "/home/user/0my/COQ".
Require Export UNIV_INST.

(*Require Import Logic.ClassicalFacts.*)
(*Axiom EquivThenEqual: prop_extensionality.*)

Inductive myeq (A : Type) (x : A) : A -> Type :=
| myeq_refl : myeq A x x.

Fixpoint myvec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
myeq _ (Vector.map f (Vector.map g t0))
(Vector.map (fun x=>(f(g x))) t0).
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> myvec_comp_as.
reflexivity.
Defined.

Fixpoint vec_comp_as {A B C} (f:B->C) (g:A->B) (n:nat) (t0: Vector.t A n) :
Vector.map f (Vector.map g t0) =
Vector.map (fun x=>(f(g x))) t0.
Proof.
destruct t0.
simpl.
reflexivity.
simpl.
rewrite -> vec_comp_as.
reflexivity.
Defined.

Module VS.
Section sec0.
Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.
Check MPSV 0 0.
Notation A1Type:=Set.
Unset Elimination Schemes.
Inductive Terms : A1Type :=
| FVC :> SetVars -> Terms
| FSC (f:FSV) : (Vector.t Terms (fsv f)) -> Terms.
Set Elimination Schemes.

Definition Terms_rect (T : Terms -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

Definition Terms_ind (T : Terms -> Prop)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.

(*Formulas*)
(*Unset Elimination Schemes.*)
Inductive Fo :=
|Atom (p:PSV) : (Vector.t Terms (psv p)) ->  Fo
|Bot :Fo
|Conj:Fo->Fo->Fo
|Disj:Fo->Fo->Fo
|Impl:Fo->Fo->Fo
|Fora(x:SetVars)(f:Fo): Fo
|Exis(x:SetVars)(f:Fo): Fo
.
(*Set Elimination Schemes.
Section Fo_rect_section.
Definition Fo_rect (T : Fo -> Type)
                      (H_FVC : forall sv, T (FVC sv))
                      (H_FSC : forall f v, (forall n, T (Vector.nth v n)) -> T (FSC f v)) :=
  fix loopt (t : Terms) : T t :=
    match t with
    | FVC sv  => H_FVC sv
    | FSC f v =>
      let fix loopv s (v : Vector.t Terms s) : forall n, T (Vector.nth v n) :=
        match v with
        | @Vector.nil _ => Fin.case0 _
        | @Vector.cons _ t _ v => fun n => Fin.caseS' n (fun n => T (Vector.nth (Vector.cons _ t _ v) n))
                                                      (loopt t)
                                                      (loopv _ v)
        end in
      H_FSC f v (loopv _ v)
    end.
End Fo_rect_section.*)

(* Substitution *)

Fixpoint substT (t:Terms) (xi: SetVars) (u:Terms): Terms.
Proof.
destruct u.
2 : { refine (FSC _ _).
Check @Vector.map.
Check @Vector.map _ _ (substT t xi) _ t0.
exact ( @Vector.map _ _ (substT t xi) _ t0 ). }

{
(*Check my.beq_natP s xi.*)
destruct (PeanoNat.Nat.eqb s xi).
Print bool.
exact t.
exact s. }
(*Show Proof.*)
Defined.

Fixpoint isParamT (xi : SetVars) (t : Terms) {struct t} : bool :=
   match t with
   | FVC s => PeanoNat.Nat.eqb s xi
   | FSC f t0 => Vector.fold_left orb false (Vector.map (isParamT xi) t0)
   end.

Fixpoint isParamF (xi:SetVars) (f:Fo): bool.
Proof.
(*elim f; intros. *)
destruct f.
Show Proof.
Search "Exists".
exact (Vector.fold_left orb false (Vector.map (isParamT xi) t)).
exact false.
Show Proof.
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
exact (orb (isParamF xi f1) (isParamF xi f2)).
Show Proof.
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
exact (match (PeanoNat.Nat.eqb x xi) with
       | true => false
       | false => (isParamF xi f)
       end).
Show Proof.
Defined.

Fixpoint substF (t:Terms) (xi: SetVars) (u : Fo): option Fo.
Proof.
pose(g := substT t xi).
pose(f := substF t xi).
destruct u.
refine (Some (Atom p _)).
exact (Vector.map g t0).
exact (Some Bot).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Conj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Disj f0 f1))
 | _,_ => None
 end).
 exact (
 match (f u1),(f u2) with
 | Some f0,Some f1 => (Some (Impl f0 f1))
 | _,_ => None
 end).
(*destruct (isParamF xi (Fora x0 u)).*)
refine (match (isParamF xi (Fora x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Fora x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Fora x u) end).
refine (match (isParamF xi (Exis x u)) with
| true => match (isParamT x t) with
          | false => match substF t xi u with
                    | Some q => Some (Exis x q)
                    | None => None
                    end
          | true => None
          end
| false => Some (Exis x u) end).
Defined.

Definition Top:Fo := Impl Bot Bot.

Notation " x --> y ":=(Impl x y) (at level 80).
(*
Notation " u '[' t >> xi ] ":=(substT t xi u ) (at level 10).
Set Warnings "-notation-overridden".
Notation " ph [ t | xi ] ":=(substF t xi ph ) (at level 10).
(*Set Warnings "default".*)
Check fun (t:Terms) (x:SetVars) => ( t [ t >> x ]).
Check fun (t:Terms) (x:SetVars) (ph:Fo) => ( ph [ t | x ] ).
*)

Open Scope list_scope.
Print List.In.
Locate "+".
Print sum.
Definition InL { A : Type } :=
fix InL (a : A) (l : list A) {struct l} : Type :=
  match l with
  | Datatypes.nil => False
  | b :: m => (sum (b = a) (InL a m))
  end.

Inductive PR (axi:list Fo) : Fo -> Type :=
| hyp (A : Fo): (InL A axi)-> @PR axi A
| a1 (A B: Fo) : @PR axi (Impl A (Impl B A))
| a2 (A B C: Fo) : @PR axi ((A-->(B-->C))-->((A-->B)-->(A-->C)))
| a12 (ph: Fo) (t:Terms) (xi:SetVars)
: @PR axi (match (substF t xi ph) with
      | Some q => (Impl (Fora xi ph) q)
      | None => Top
      end)
| b1 (ps ph: Fo) (xi:SetVars) (H:isParamF xi ps = false):
@PR axi (Impl (Fora xi (Impl ps ph)) (Impl ps (Fora xi ph)) )
| MP (A B: Fo) : (@PR axi A)->(@PR axi (Impl A B))->(@PR axi B)
| GEN (A : Fo) (xi:SetVars): (@PR axi A)->(@PR axi (Fora xi A))
.

Check @PR.
Definition AtoA (A:Fo) : PR (List.nil) (A-->A).
Proof.
apply (MP nil (A-->(A-->A)) _).
apply a1.
apply (MP nil (A-->((A-->A)-->A)) _).
apply a1.
apply a2.
Defined.

Definition B1 (ps ph:Fo) (xi:SetVars) (H:isParamF xi ps = false):
 PR nil (ps --> ph) -> PR nil (ps --> Fora xi ph).
Proof.
intro q.
apply (MP nil (Fora xi (ps --> ph))).
+ apply GEN.
  exact q.
+ apply (b1 _).
  exact H.
Defined.

Definition gen (A:Fo) (xi:SetVars) (*Generalization from Bernay's rule*)
: PR nil (A) -> PR nil (Fora xi A).
Proof.
intro q.
apply (MP nil Top).
unfold Top.
exact (AtoA Bot).
apply (MP nil (Fora xi (Top --> A))).
* apply GEN.
  apply (MP nil A).
  + exact q.
  + apply a1.
* apply b1.
  trivial.
Defined.

Definition neg (f:Fo):= (Impl f Bot).

Definition a1i (A B : Fo)(l : list Fo):(PR l B)->(PR l (Impl A B)).
Proof.
intros x.
apply (MP l B).
exact x.
apply a1.
Defined.

Fixpoint weak (A F:Fo) (l :list Fo) (x: (PR l F)) : (PR (A::l) F).
Proof.
destruct x.
apply hyp.
apply inr. (*or_intror *)
exact i.
apply a1.
apply a2.
apply a12.
apply b1.
assumption.
apply (@MP _ A0).
apply weak.
exact x1.
apply weak.
exact x2.
apply GEN. (* Order is not important! *)
apply weak. (* Order is not important! *)
exact x.
Defined.

Fixpoint weaken (F:Fo) (li l :list Fo) (x: (PR l F)) {struct li}: (PR (li ++ l) F).
Proof.
destruct li.
simpl.
exact x.
simpl.
simple refine (@weak f F (li ++ l) _).
apply weaken.
exact x.
Defined.

(*Export List Notations.*)
Fixpoint notGenWith (xi:SetVars)(l:list Fo)(B:Fo)(m:(PR l B)){struct m}:bool.
Proof.
destruct m.
exact true.
exact true.
exact true.
exact true.
exact true.
exact (andb (notGenWith xi l _ m1) (notGenWith xi l _ m2)).
exact (andb (negb (PeanoNat.Nat.eqb xi xi0)) (notGenWith xi l _ m) ).
Defined.
Check isParamF.
(*Check fun A B=> forall xi:SetVars, (true = isParamF xi A)->(notGenWith xi m).*)
Fixpoint HA xi : true = PeanoNat.Nat.eqb (xi) (xi).
Proof.
destruct xi.
reflexivity.
simpl.
exact (HA xi).
Defined.

Fixpoint ZX (xi:SetVars) :true = negb (PeanoNat.Nat.eqb xi xi) -> False.
Proof.
intro q.
destruct xi.
compute in q.
inversion q.
rewrite <- HA in q.
inversion q.
Defined.

Theorem lm (a b :bool)(G:true = (a && b) ): true = a.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem lm2 (a b :bool)(G:true = (a && b) ): true = b.
Proof.
destruct a.
trivial.
inversion G.
Defined.

Theorem N (rr:bool): (true=rr \/ rr=false).
Proof.
destruct rr; firstorder.
Defined.

Fixpoint Ded (A B:Fo)(il:list Fo)(m:(PR (cons A il) B))
(H:forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m))
{struct m}:(PR il (A-->B)).
Proof.
destruct m. (*as [i|i|i|i|i|i|i].*)
+ unfold In in i.
  simpl in i .
  destruct i .
  * rewrite <- e.
    pose (J:=weaken _ il nil (AtoA A )).
    rewrite app_nil_r in J.
    exact J.
(*exact (weaken _ il nil (AtoA A )).
apply weak.
exact (AtoA A ).
exfalso.*)
  * simpl in H.
    apply a1i.
    exact (hyp il _ i).
+ apply a1i.
  apply a1.
+ apply a1i.
  apply a2.
+ apply a1i.
  apply a12.
+ apply a1i.
  apply b1.
  trivial.
+ apply (MP _ (A-->A0)).
- simple refine (@Ded _ _ _ _ _).
  exact m1.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  pose (J:=notGenWith xi (A :: il) A0 m1).
  try reflexivity.
  fold J.
  fold J in W.
  apply (lm _ _ W).
-
apply (MP _ (A-->(A0-->B))).
simple refine (@Ded _ _ _ _ _).
  exact m2.
  intros xi H0.
  pose (W:=H xi H0).
  simpl in W.
  apply (lm2 _ _ W).
(*Last part about GEN*)
apply a2.
+
apply (MP _ (Fora xi (A-->A0))).
apply GEN.
simple refine (@Ded _ _ _ _ _).
  exact m.
  intros xi0 H0.
  pose (W:=H xi0 H0).
  simpl in W.
* exact (lm2 _ _ W).
* simpl.
apply b1.
pose (r := isParamF xi A).
pose (U := H xi).
fold r in U |- *.
simpl in U.

destruct (N r).
pose (C:= lm _ _(U H0)).
exfalso.
exact (ZX _ C).
exact H0.
Show Proof.
Defined.

(*Fixpoint Ded (A B:Fo)(m:(PR (cons A nil) B)) *)

Definition lm3 (a b :bool)(A: true = a)(B: true = b):true = (a && b)
:=
 (if a as a0 return (true = a0 -> true = a0 && b)
  then
   fun _ : true = true =>
   (if b as b0 return (true = b0 -> true = true && b0)
    then fun _ : true = true => eq_refl
    else fun B0 : true = false => B0) B
  else
   fun A0 : true = false =>
   (if b as b0 return (true = b0 -> true = false && b0)
    then fun _ : true = true => A0
    else fun _ : true = false => A0) B) A.
(*destruct a,b.
reflexivity.
simpl.
exact B.
simpl.
exact A.
simpl.
exact A.
Show Proof.
Defined.*)

Fixpoint forClosed (A B:Fo)(m:(PR (cons A nil) B)):
(forall xi:SetVars, (false = isParamF xi A))
->
(forall xi:SetVars, (true = isParamF xi A)->(true=notGenWith xi _ _ m)).
Proof.
intros H xi Q.
destruct m; simpl; try reflexivity.
+ apply lm3.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
  simple refine (@forClosed _ _ _ _ _ _); assumption.
+ apply lm3.
  2 : simple refine (@forClosed _ _ _ _ _ _); assumption.
  pose (U:=H xi).
  rewrite <- Q in U.
  exfalso.
  inversion U.
Show Proof.
Defined.

Fixpoint SimplDed (A B:Fo) (il: list Fo)(m:(PR (cons A il) B))
(NP:forall xi:SetVars, (false = isParamF xi A))
{struct m}:(PR il (A-->B)).
Proof.
simple refine (Ded _ _ _ _ _).
exact m.
intros xi H.
rewrite <- NP in H.
inversion H.
Defined.
End sec0.

Module ModProp.
Definition Omega := Prop.
Definition OFalse := False.
Definition OAnd := and.
Definition OOr := or.
Definition OImp := (fun x y:Omega => x->y).
End ModProp.

Module ModBool.
Definition Omega := bool.
Definition OFalse := false.
Definition OAnd := andb.
Definition OOr := orb.
Definition OImp := implb.
End ModBool.

(* Here we choose an interpretation. *)
(*Export ModBool.*)
Export ModProp. (* + classical axioms *)

(** Correctness theorem **)
(** for two-valued logic **)
Section cor.
 (* Truth values*)
Context (X:Type).
(*Context (val:SetVars->X).*)
Context (fsI:forall(q:FSV),(Vector.t X (fsv q))->X).
Context (prI:forall(q:PSV),(Vector.t X (psv q))->Omega).
(*Context (prI:forall(q:PSV),(Vector.t X (psv q))->Prop).*)

Fixpoint teI (val:SetVars->X) (t:Terms): X.
Proof.
destruct t.
exact (val s).
refine (fsI f _).
simple refine (@Vector.map _ _ _ _ _).
2 : apply teI.
exact val.
exact t.
Show Proof.
Defined.
(*
Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
+ refine (prI p _).
  apply (Vector.map  (teI val)).
  exact t.
+ exact false.
+ exact ( andb (foI val f1) (foI val f2)).
+ exact (  orb (foI val f1) (foI val f2)).
+ exact (implb (foI val f1) (foI val f2)).
+  (*Infinite conjunction!!!*)
 Show Proof.
*)

(** (\pi + (\xi \mapsto ?) ) **)
Definition cng (val:SetVars -> X) (xi:SetVars) (m:X) :=
(fun r:SetVars =>
match PeanoNat.Nat.eqb r xi with
| true => m
| false => (val r)
end).

(*Inductive foI (val:SetVars->X) (f:Fo): Prop
:=
   | cAtom p t0 => ?Goal0@{t:=t0}
.
   | cBot => ?Goal
   | cConj f1 f2 => ?Goal1
   | cDisj f1 f2 => ?Goal2
   | cImpl f1 f2 => ?Goal3
   | cFora x f0 => ?Goal4@{f:=f0}
   | cExis x f0 => ?Goal5@{f:=f0}
.*)

Fixpoint foI (val:SetVars->X) (f:Fo): Omega.
Proof.
destruct f.
Show Proof.
+ refine (prI p _).
  apply (@Vector.map Terms X (teI val)).
  exact t.
+ exact OFalse.
+ exact ( OAnd (foI val f1) (foI val f2)).
+ exact (  OOr (foI val f1) (foI val f2)).
+ exact ( OImp (foI val f1) (foI val f2)).
Show Proof.
+ exact (forall m:X, foI (cng val x m) f).
(*forall m:X, foI (fun r:SetVars =>
match Nat.eqb r x with
| true => m
| false => (val r)
end
) f*)
+ exact (exists m:X, foI (fun r:SetVars =>
match PeanoNat.Nat.eqb r x with
| true => m
| false => (val r)
end
) f
).
Defined.

Definition ap {A B}{a0 a1:A} (f:A->B) (h:a0=a1):((f a0)=(f a1))
:= match h in (_ = y) return (f a0 = f y) with
   | eq_refl => eq_refl
   end.

Section Lem1.
(*Context (t : Terms).*)

(* page 136 of the book *)
Definition lem1 (t : Terms) : forall (u :Terms) (xi : SetVars) (pi : SetVars->X) ,
(teI pi (substT t xi u))=(teI (cng pi xi (teI pi t)) u).
Proof.
fix lem1 1.
intros.
induction u as [s|f].
(*destruct u as [s|f] .*)
+ simpl.
  unfold cng.
  destruct (Nat.eqb s xi) eqn:ek. (* fsI as [H1|H2].*)
  * reflexivity.
  * simpl.
    reflexivity.
Show Proof.
+
  simpl. (* fsI teI *)
  destruct f.
  simpl.
  apply ap.
 simpl in * |- *.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.
Defined.

(*Theorem additi pi xi n (v:Vector.t _ n) :
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v.
apply (*Check *)
(proj1 (
eq_nth_iff X fsv0
(Vector.map (teI pi) (Vector.map (substT t xi) v))
(Vector.map (teI (cng pi xi (teI pi t))) v)
)).
intros.
(*rewrite H0.*)
 simpl in * |- *.
(* now I need to show that .nth and .map commute *)
Check nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0.
rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
Check nth_map (teI (cng pi xi (teI pi t))) v.
rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
Check nth_map (substT t xi) v p2 p2 eq_refl.
rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
exact (H p2).
reflexivity.*)

End Lem1.

Theorem SomeInj {foo} :forall (a b : foo), Some a = Some b -> a = b.
Proof.
  intros a b H.
  inversion H.
  reflexivity.
Defined.

Theorem eq_equ (A B:Prop) : A=B -> (A <-> B).
Proof.
intro p.
destruct p.
firstorder.
Defined. (* rewrite p. firstorder. *)

Theorem conj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 /\ B0) = (A1 /\ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem disj_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 \/ B0) = (A1 \/ B1).
Proof. destruct pA, pB; reflexivity. Defined.
Theorem impl_eq (A0 B0 A1 B1:Prop)(pA:A0=A1)(pB:B0=B1): (A0 -> B0) = (A1 -> B1).
Proof. destruct pA, pB; reflexivity. Defined.
Lemma dbl_cng pi xi m1 m2: forall q,(cng (cng pi xi m1) xi m2) q = (cng pi xi m2) q.
Proof. intro q. unfold cng. destruct (Nat.eqb q xi); reflexivity. Defined.

Theorem l01 h n v :
Vector.fold_left orb false (Vector.cons bool h n v) = Vector.fold_left orb (orb false h) v.
Proof.
simpl. reflexivity.
Defined.

Check all_then_someV.

Lemma all_then_someP (A:Type)(n:nat)(p:Fin.t (n)) (v:Vector.t A (n)) (P:A->bool)
(H : Vector.fold_left orb false (Vector.map P v) = false)
 : (P (Vector.nth v p)) = false.
Proof.
Check nth_map P v p p eq_refl.
rewrite <- (nth_map P v p p eq_refl).
apply all_then_someV. trivial.
Defined.

(* Not a parameter then not changed afted substitution (for Terms) *)
Lemma NPthenNCAST (u:Terms)(xi:SetVars)(t:Terms) (H:(isParamT xi u=false))
: (substT t xi u) = u.
Proof. induction u.
+ simpl in * |- *.
  rewrite H. reflexivity.
+ simpl in * |- *.
  apply ap.
apply eq_nth_iff.
intros p1 p2 ppe.
Check nth_map _ _ _ p2 ppe.
rewrite (nth_map _ _ _ p2 ppe).
apply H0.
simpl.
apply all_then_someP.
trivial.
Defined.

Lemma NPthenNCAST_vec:forall p xi t ts (H:(isParamF xi (Atom p ts)=false)),
  (Vector.map (substT t xi) ts) = ts.
Proof.
  intros p xi t1 ts H.
  apply eq_nth_iff.
  intros p1 p2 H0.
  Check nth_map (substT t1 xi) ts p1 p2 H0.
  rewrite -> (nth_map (substT t1 xi) ts p1 p2 H0).
  apply NPthenNCAST.
  apply all_then_someP.
  simpl in H.
  exact H.
Defined.

(* Not a parameter then not changed afted substitution (for Formulas) *)
Fixpoint NPthenNCASF (mu:Fo) : forall (xi:SetVars)(t:Terms) (H:(isParamF xi mu=false))
   , substF t xi mu = Some mu .
Proof. (*induction mu eqn:u0.*)
destruct mu eqn:u0.
Check t.
* intros xi t0 H.
  simpl.
  rewrite -> NPthenNCAST_vec; (trivial || assumption).
* intros xi t H.
  simpl; trivial.
* intros xi t H.
  simpl.
  simpl in H.
  (*pose (Q:=A1 _ _ H).*)
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHf1 with xi t.
  rewrite -> IHf2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  (*rewrite -> IHmu1 with xi t.
  rewrite -> IHmu2 with xi t.*)
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (A1 _ _ H) as [H0 H1].
  rewrite -> NPthenNCASF .
  rewrite -> NPthenNCASF .
  trivial.
  trivial.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
* simpl.
  intros xi t H.
  destruct (PeanoNat.Nat.eqb x xi) eqn:u2.
  trivial.
  destruct (isParamF xi f) eqn:u1.
  inversion H.
  trivial.
Defined.

(* p.137 *)
Section Lem2.
Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
option_map (foI pi ) (substF t xi fi) = Some (foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1. intros.
destruct (substF t xi fi).
2 : { simpl.
Abort.

Definition lem2 : forall (t : Terms) (fi : Fo) (xi : SetVars) (pi : SetVars->X),
match (substF t xi fi) with
| Some r => (foI pi r)=(foI (cng pi xi (teI pi t)) fi)
| None => True
end.
Proof. fix lem2 1. intros. destruct (substF t xi fi). 2 : exact I.
destruct f eqn:u0.
simpl in * |- *.
Fail  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
Abort.
Lemma mqd x t pi m (H:isParamT x t = false): (teI (cng pi x m) t) = (teI pi t).
Proof.
induction t.
 simpl.
simpl in H.
unfold cng.
rewrite -> H.
reflexivity.
 simpl.
simpl in H.
apply ap.
apply eq_nth_iff.
intros.
Check nth_map (teI (cng pi x m)) v p1 p1 eq_refl.
rewrite -> (nth_map (teI (cng pi x m)) v p1 p1 eq_refl).
rewrite -> (nth_map (teI pi) v p2 p2 eq_refl).
rewrite <- H1.
apply H0.
exact (all_then_someP _ _ p1 _ (isParamT x) H).
Defined.

Lemma IOF xi : PeanoNat.Nat.eqb xi xi = true.
induction xi.
simpl. trivial.
simpl. exact IHxi.
Defined.

Lemma cng_commT  x xi m0 m1 pi t :
PeanoNat.Nat.eqb x xi = false ->
teI (cng (cng pi x m0) xi m1) t = teI (cng (cng pi xi m1) x m0) t.
Proof. intro i.
revert pi.
induction t; intro pi.
simpl.
unfold cng.
(*destruct (Nat.eqb x xi) eqn:j.
inversion i. NO*)
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
pose (n3:= proj1 (not_iff_compat (PeanoNat.Nat.eqb_eq x xi)) ).
Check proj2 (not_true_iff_false (PeanoNat.Nat.eqb x xi)).
pose (n4:= n3 (proj2 (not_true_iff_false (PeanoNat.Nat.eqb x xi)) i)).
Require Import Arith.Peano_dec.
Check eq_nat_dec.
destruct (PeanoNat.Nat.eq_dec sv xi).
rewrite -> e.
rewrite -> IOF.
destruct (PeanoNat.Nat.eq_dec x xi).
destruct (n4 e0).
pose (hi := (not_eq_sym n)).

Check not_true_iff_false .
pose (ih:= not_true_is_false _ (proj2 (not_iff_compat (PeanoNat.Nat.eqb_eq xi x)) hi)).
rewrite ih.
reflexivity.
pose (ih:= not_true_is_false _ (proj2 (not_iff_compat (PeanoNat.Nat.eqb_eq sv xi)) n)).
rewrite -> ih.
reflexivity.
simpl.
apply ap.
apply eq_nth_iff.
intros p1 p2 HU.

Check nth_map (teI (cng (cng pi x m0) xi m1)) v p1 p2 HU.
rewrite -> (nth_map (teI (cng (cng pi x m0) xi m1)) v p1 p2 HU).
Check nth_map.
rewrite -> (nth_map (teI (cng (cng pi xi m1) x m0)) v p2 p2 eq_refl).
apply H.
Defined.

Lemma EqualThenEquiv A B: A=B -> (A<->B). intro H. rewrite H. exact (iff_refl B). Defined.

Lemma ix W (P Q:W->Prop) (H: P = Q):(forall x, P x) =(forall y, Q y).
rewrite H.
reflexivity.
Defined.

Lemma cng_commF  xe xi m0 m1 pi fi : (*with equality*)
PeanoNat.Nat.eqb xe xi = false ->
(foI (cng (cng pi xe m0) xi m1) fi = foI (cng (cng pi xi m1) xe m0) fi).
Proof. intro i. revert pi m0 m1 xe xi i.
induction fi; intros pi m0 m1 xe xi i.
+ simpl.
  apply ap.
  apply eq_nth_iff.
  intros p1 p2 HU.
  rewrite -> (nth_map (teI (cng (cng pi xe m0) xi m1)) t p1 p2 HU).
  rewrite -> (nth_map (teI (cng (cng pi xi m1) xe m0)) t p2 p2 eq_refl).
  apply cng_commT.
  exact i.
+ simpl. reflexivity.
+ simpl. rewrite -> IHfi1.  rewrite -> IHfi2. reflexivity. exact i. exact i.
+ simpl. rewrite -> IHfi1.  rewrite -> IHfi2. reflexivity. exact i. exact i.
+ simpl. rewrite -> IHfi1.  rewrite -> IHfi2. reflexivity. exact i. exact i.
+ simpl.
apply ix.
Check IHfi (cng pi xi m1) m0 m1 xe x.
(* assert (ii : PeanoNat.Nat.eqb xe x = false ). admit.
rewrite (fun y => (IHfi (cng pi xi m1) m0 y xe x ii)).
apply EquivThenEqual. split. intros. *)
Abort.

Lemma weafunT pi mu (q: forall z, pi z = mu z) t : teI pi t = teI mu t.
Proof.
induction t.
+ simpl. exact (q sv).
+ simpl. apply ap.
  apply eq_nth_iff.
  intros p1 p2 HU.
  rewrite -> (nth_map (teI pi) v p1 p2 HU).
  rewrite -> (nth_map (teI mu) v p2 p2 eq_refl).
  apply H.
Defined.

Lemma weafunF pi mu (q: forall z, pi z = mu z) fi : foI pi fi <-> foI mu fi.
Proof.
revert pi mu q.
induction fi.
intros pi mu q.
+ simpl.
  apply EqualThenEquiv.
  apply ap.
  apply eq_nth_iff.
  intros p1 p2 HU.
  rewrite -> (nth_map (teI pi) t p1 p2 HU).
  rewrite -> (nth_map (teI mu) t p2 p2 eq_refl).
  apply weafunT.
  apply q.
+ simpl. reflexivity.
+ simpl. intros.
  rewrite -> (IHfi1 pi mu q) (*weafunF pi mu q fi1*).
  rewrite -> (IHfi2 pi mu q) (*weafunF pi mu q fi2*).
  reflexivity.
+ simpl. intros.
  rewrite -> (IHfi1 pi mu q) (*weafunF pi mu q fi1*).
  rewrite -> (IHfi2 pi mu q) (*weafunF pi mu q fi2*).
  reflexivity.
+ simpl.
  unfold OImp.
  split;
  intros;
  apply (IHfi2 pi mu q (*pi m0 m1 xe xi i*));
  apply H;
  apply (IHfi1 pi mu q (*pi m0 m1 xe xi i*));
  apply H0. (*twice*)
+ simpl.
  split.
  * intros.
    rewrite IHfi. (*weafunF.*)
    apply H.
    intro z.
    unfold cng.
    destruct (Nat.eqb z x).
    reflexivity.
    symmetry.
    apply q.
  * intros.
    rewrite IHfi.
    apply H.
    intro z.
    unfold cng.
    destruct (Nat.eqb z x).
    reflexivity.
    apply q.
+ simpl.
  split.
  * intros.
destruct H as [m H].
exists m.
    rewrite IHfi. (*weafunF.*)
    apply H.
    intro z.
    unfold cng.
    destruct (Nat.eqb z x).
    reflexivity.
    symmetry.
    apply q.
  * intros.
destruct H as [m H].
exists m.
    rewrite IHfi.
    apply H.
    intro z.
    unfold cng.
    destruct (Nat.eqb z x).
    reflexivity.
    apply q.
Defined.

Lemma cng_commF_EQV  xe xi m0 m1 pi fi :
PeanoNat.Nat.eqb xe xi = false ->
(foI (cng (cng pi xe m0) xi m1) fi <-> foI (cng (cng pi xi m1) xe m0) fi).
Proof.
intros H.
apply weafunF.
intros z.
unfold cng.
destruct (PeanoNat.Nat.eqb z xi) eqn:e0, (PeanoNat.Nat.eqb z xe) eqn:e1.
pose (U0:= proj1 (PeanoNat.Nat.eqb_eq z xi) e0).
rewrite U0 in e1.
pose (U1:= proj1 (PeanoNat.Nat.eqb_eq xi xe) e1).
symmetry in U1.
pose (U2:= proj2 (PeanoNat.Nat.eqb_eq xe xi) U1).
rewrite U2 in H.
inversion H.
reflexivity. reflexivity. reflexivity.
Defined.

(* TODO replace cng_commEXT with cng_commF and cng_commT DONE! *)
(** IT'S GOOD, BUT IT REQUIRES A FUNCTIONAL_EXTENSIONALITY
Lemma cng_commEXT  x xi m0 m1 pi :
PeanoNat.Nat.eqb x xi = false ->
(cng (cng pi x m0) xi m1) = (cng (cng pi xi m1) x m0).
Proof. intro i.
apply functional_extensionality.
intro b.
unfold cng.
destruct (Nat.eqb b xi) eqn:e1, (Nat.eqb b x) eqn:e2.
rewrite -> (proj1 (PeanoNat.Nat.eqb_eq b x) e2) in e1.
rewrite e1 in i.
inversion i.
reflexivity.
reflexivity.
reflexivity.
Defined.
**)

Lemma AND_EQV : forall A0 B0 A1 B1 : Prop,
(A0 <-> A1) -> (B0 <-> B1) -> ((A0 /\ B0) <-> (A1 /\ B1)).
Proof.
intros A0 B0 A1 B1 H0 H1.
rewrite H0.
rewrite H1.
reflexivity.
Defined.
Lemma OR_EQV : forall A0 B0 A1 B1 : Prop,
(A0 <-> A1) -> (B0 <-> B1) -> ((A0 \/ B0) <-> (A1 \/ B1)).
Proof.
intros A0 B0 A1 B1 H0 H1.
rewrite H0.
rewrite H1.
reflexivity.
Defined.
Lemma IMP_EQV : forall A0 B0 A1 B1 : Prop,
(A0 <-> A1) -> (B0 <-> B1) -> ((A0 -> B0) <-> (A1 -> B1)).
Proof.
intros A0 B0 A1 B1 H0 H1.
rewrite H0.
rewrite H1.
reflexivity.
Defined.

Context (t : Terms).
Definition lem2 : forall (fi : Fo) (xi : SetVars) (pi : SetVars->X)
(r:Fo) (H:(substF t xi fi) = Some r), (*(SH:sig (fun(r:Fo)=>(substF t xi fi) = Some r)),*)
(foI pi r)<->(foI (cng pi xi (teI pi t)) fi).
Proof.
fix lem2 1.
(*H depends on t xi fi r *)
(*H depends on t xi fi r *)
intros fi xi pi r H.
revert pi r H.
(* intros fi  xi pi *)
(*destruct (substF t xi fi) eqn: j.*)
(**)
induction fi;
intros pi r H.
+  (*simpl in *|-*; intros r H.*)
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl.
apply EqualThenEquiv.
  (*apply eq_equ.*)
  apply ap.
  apply
    (proj1 (
      eq_nth_iff X (psv p)
      (Vector.map (teI pi) (Vector.map (substT t xi) t0))
      (Vector.map (teI (cng pi xi (teI pi t))) t0)
    )).
  rename t0 into v.
  intros p1 p2 H0.
  rewrite -> (nth_map (teI pi) (Vector.map (substT t xi) v) p1 p2 H0).
  rewrite -> (nth_map (teI (cng pi xi (teI pi t))) v p2 p2 ).
  rewrite -> (nth_map (substT t xi) v p2 p2 eq_refl).
  apply lem1. reflexivity.
+  (*simpl in *|-*; intros r H.*)
   inversion H. simpl. reflexivity.
+  simpl in *|-*; (*intros r H.*)
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
(* here! *)
Check conj_eq.
simpl.
unfold OAnd.
apply AND_EQV.

(*apply and_iff_compat_l.
apply EqualThenEquiv.
  apply conj_eq ;   fold foI.*)
  simpl in * |- *.
  (*Check IHfi1 xi pi f1 .*)
  * apply (IHfi1 pi f1 eq_refl).
(* apply lem2.
unshelve eapply (IHfi1 xi pi f1 ).*)
  * apply (IHfi2 pi f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*. (*; intros r H.*)
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
apply OR_EQV.
  (*apply disj_eq ;   fold foI.*)
  * apply (IHfi1 pi f1 eq_refl).
  * apply (IHfi2 pi f2 eq_refl).
  * inversion H.
  * inversion H.
+ simpl in *|-*. (*; intros r H.*)
  destruct (substF t xi fi1) as [f1|].
  destruct (substF t xi fi2) as [f2|].
  pose (Q:=SomeInj _ _ H).
  rewrite <- Q.
  simpl in * |- *.
  apply IMP_EQV. (*apply impl_eq ;   fold foI.*)
  * apply (IHfi1 pi f1 eq_refl).
  * apply (IHfi2 pi f2 eq_refl).
  * inversion H.
  * inversion H.
+ (*intros r H.*)
  (*simpl in * |- *.
  destruct (PeanoNat.Nat.eqb x xi) eqn:j0.
  * destruct (isParamF xi (Fora x fi) ) eqn:tuc.
    -
  simpl.*)
 destruct (isParamF xi (Fora x fi) ) eqn:tuc.
2 : {
Check NPthenNCASF.
rewrite NPthenNCASF in H.
 pose (Q:=SomeInj _ _ H).
rewrite <- Q.
  simpl. split. intros.
Check lem2.
Check IHfi.
apply <- IHfi.

apply lem2.
pose (J:=(PeanoNat.Nat.eqb x xi)).
simpl.
simpl in tuc.
destruct (PeanoNat.Nat.eqb x xi) (*as [J0|J1]*).
reflexivity.
destruct (isParamF xi fi).
inversion tuc.
reflexivity.
assumption.
}
simpl in tuc.
simpl in H.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
rewrite tuc in H.
destruct (isParamT x t) eqn:k2.
inversion H.
destruct (substF t xi fi) eqn:k3.
2 : inversion H.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
assert (AS0 : exists ro:Fo, (substF t xi fi) = Some ro).
 exists f.
 exact k3. clear AS0.
(*apply EquivThenEqual.*)
split.
intros.
pose (K:=H0 m).
rewrite -> lem2 with (fi:=fi) (xi:=xi) in K .
2 : exact k3.
(* foI (cng YN xi (teI YN t)) fi*)
rewrite -> mqd in K.
2 : exact k2. (* x and xi are different so they are interchangeable *)
simpl.
Check cng_commF_EQV.
rewrite cng_commF_EQV in K. (*rewrite cng_commEXT in K.*)
exact K.
exact k1.

intros.
pose (K:=H0 m).
rewrite cng_commF_EQV in K. (*rewrite cng_commEXT in K.*)

rewrite <- mqd with (x:=x) (t:=t)(m:=m) in K.

Check lem2 fi xi (cng pi x m) f k3.
rewrite <- lem2 with (fi:=fi) (xi:=xi) (r:=f) in K .
exact K.
exact k3.
exact k2.
Check reflect.

destruct (PeanoNat.Nat.eq_dec x xi) eqn:w.
rewrite e in k1.
Check not_iff_compat.
Check PeanoNat.Nat.eqb_eq x xi.
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
rewrite -> (IOF xi) in k1.
inversion k1.
pose (n2:= not_eq_sym n).
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
pose (n3:= proj2 (not_iff_compat (PeanoNat.Nat.eqb_eq xi x)) n2).
apply not_true_is_false.
exact n3.
(* FORALL case is proved. *)
+ intros r H.
  (*simpl in * |- *.
  destruct (PeanoNat.Nat.eqb x xi) eqn:j0.
  * destruct (isParamF xi (Fora x fi) ) eqn:tuc.
    -
  simpl.*)
 destruct (isParamF xi (Fora x fi) ) eqn:tuc.
2 : {
Check NPthenNCASF.
rewrite NPthenNCASF in H.
 pose (Q:=SomeInj _ _ H).
rewrite <- Q.
apply lem2.
pose (J:=(PeanoNat.Nat.eqb x xi)).
simpl.
simpl in tuc.
destruct (PeanoNat.Nat.eqb x xi) (*as [J0|J1]*).
reflexivity.
destruct (isParamF xi fi).
inversion tuc.
reflexivity.
assumption.
}
simpl in tuc.
simpl in H.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
rewrite tuc in H.
destruct (isParamT x t) eqn:k2.
inversion H.
destruct (substF t xi fi) eqn:k3.
2 : inversion H.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
assert (AS0 : exists ro:Fo, (substF t xi fi) = Some ro).
 exists f.
 exact k3. clear AS0.
(*apply EquivThenEqual.*)

split.
intros.
destruct H0 as [m K].
(*pose (K:=H0 m).*)
rewrite -> lem2 with (fi:=fi) (xi:=xi) in K .
2 : exact k3.
(* TODO: adapt this part from FORALL case to EXISTS case. *)
(* exists (pi xi).  togda nado dok (foI pi fi)? *)
simpl.
exists m.
fold (cng pi x m) in K.
fold (cng (cng pi xi (teI pi t)) x m) .
(*pose (YN := (fun r : SetVars => if PeanoNat.Nat.eqb r x then m else pi r)).
fold YN in K.*)
Print cng.
(*cng =
fun (val : SetVars -> X) (xi : SetVars) (m : X) (r : SetVars) =>
if PeanoNat.Nat.eqb r xi then m else val r *)
Check mqd.
(*Check mqd _ _ YN.*) (* LABEL2 *)
(*rewrite <- mqd.*)

rewrite -> mqd in K.
2 : exact k2. (* x and xi are different so they are interchangeable *)
simpl.
rewrite cng_commF_EQV in K.
(*rewrite cng_commEXT in K.*)
exact K.
exact k1.

intros.
destruct H0 as [m K].
(*pose (K:=H0 m).*)
(*rewrite cng_commEXT in K.*)
exists m.
fold (cng pi x m) .
fold (cng (cng pi xi (teI pi t)) x m) in K.
rewrite cng_commF_EQV in K.

rewrite <- mqd with (x:=x) (t:=t)(m:=m) in K.

Check lem2 fi xi (cng pi x m) f k3.
rewrite <- lem2 with (fi:=fi) (xi:=xi) (r:=f) in K .
exact K.
exact k3.
exact k2.
Check reflect.

destruct (PeanoNat.Nat.eq_dec x xi) eqn:w.
rewrite e in k1.
Check not_iff_compat.
Check PeanoNat.Nat.eqb_eq x xi.
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
rewrite -> (IOF xi) in k1.
inversion k1.
pose (n2:= not_eq_sym n).
Check not_iff_compat (PeanoNat.Nat.eqb_eq x xi).
pose (n3:= proj2 (not_iff_compat (PeanoNat.Nat.eqb_eq xi x)) n2).
apply not_true_is_false.
exact n3.
(* EXISTS case is proved *)
Defined. (*TODO: fix ill-formedness *)
Admitted.

auto with arith.
compute in k1.
Check PeanoNat.Nat.compare_eq_iff.
Print Eq.
simpl in k1.
inversion k1.
simpl in H2.
inversion H2.
destruct (PeanoNat.Nat.eqb xi x) eqn: s.

assert (ASSE: reflect (x=xi) (PeanoNat.Nat.eqb x xi)).
admit.
destruct ASSE eqn:j.
inversion k1.
Check reflect_iff _ _ ASSE.
admit.
(*rewrite e in .
Check iff_reflect.
Check eqb_eq _ _ k1.
exact k1.*)

+ admit.
Admitted.

simpl in K.
rewrite -> lem2 with (fi:=fi) (xi:=xi) in K .
2 : exact k3.
rewrite -> mqd in K.
2 : exact k2. (* x and xi are different so they are interchangeable *)
simpl.
rewrite cng_commEXT in K.
exact K.
exact k1.

(**** HERE IS THE DEVELOPMENT ****)

simpl.
Check functional_extensionality.

exact K.
Abort.
End Lem2. (*temporary*)

Check equal_f.

(* rewrite IHfi in H0. ne pomozhet *)
assert (AS1 :
simpl in *|-*.
(*
Abort.
End Lem2. (*temporary*)
Fixpoint lmi t xi x psi r : substF t xi (Fora x psi) = Some r ->
        exists ro:Fo, (substF t xi psi) = Some ro.
Proof.
intros H.
simpl in H.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
destruct r eqn:ln.
inversion H.
inversion H.
inversion H.
inversion H.
inversion H.
exists psi.
reflexivity.

simpl in *|-*.
simpl .

(SomeInj _ _ H).
simpl in *|-*.

(*unfold substF in H.*)
(*cbv delta in H.*)
simpl in H.
destruct (substF t xi (Fora x psi)) eqn:k2.

pose(Y:=(substF t xi (Fora x psi))).
destruct (substF t xi (psi)) eqn:k0.
exists f0.
reflexivity.
simpl in k2, Y.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
induction r.
inversion H.
inversion H.
inversion H.
inversion H.
inversion H.

*)

fold substF in H.
induction (substF t xi (psi)) eqn:e1.
exists a; reflexivity.
induction (substF t xi (Fora x psi)) eqn:e1.

simpl in *|-*.
destruct (PeanoNat.Nat.eqb x xi) eqn:k1.
inversion tuc.
destruct (isParamF xi fi) eqn:k2.
destruct (isParamT x t) eqn:k3.
inversion H.
destruct (substF t xi fi) eqn:k4.
simpl in *|-*.
pose(Q:=SomeInj _ _ H).
rewrite <- Q.
simpl in *|-*.
(*p.137.*)
assert (AS0 : exists ro:Fo, (substF t xi f) = Some ro).

apply EquivThenEqual.
split.
intros.
assert (U : forall m :X, (foI (cng pi x m) f) = (foI (cng (cng pi xi (teI pi t)) x m) fi)).
intro m.

admit.
rewrite U.
apply ap.

ENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDENDEND

apply IHfi.
symmetry.
simpl.
rewrite <- IHfi.

HJJHJHJH

simpl.
destruct (PeanoNat.Nat.eqb x xi) eqn:xxi.
admit.
admit.
admit.
  simpl in *|-*.

  pose (Q:=SomeInj _ _ H).
  pose (E:=proj1 (@PeanoNat.Nat.eqb_eq x xi) xxi).
  rewrite -> E.
  rewrite <- Q.
  simpl in * |- *.
Check fun m=>(cng (cng pi xi (teI pi t)) xi m).
Check fun m1 m2 =>(functional_extensionality _ _ (dbl_cng pi xi m1 m2)).
(*rewrite -> (fun m=> (dbl_cng  pi xi (teI pi t) m)) .*)
 (*to be continued... *)
  *
(*rewrite -> IHfi.*)
(*destruct fi; simpl.*)
  admit.
  * destruct (isParamF xi fi) eqn: yu.
    destruct (isParamT x t) eqn: os.
simpl.
Abort.
(*
Vector.map (teI pi) (Vector.map (substT t xi) v) =
Vector.map (teI (cng pi xi (teI pi t))) v
*)
End Lem2.

(* lem2  is not proven yet! *)

Fixpoint correct (f:Fo) (l:list Fo) (val:SetVars->X) (m:PR l f)
(lfi : forall h:Fo, (InL h l)->(foI val h)) {struct m}: foI val f.
Proof.
destruct m (* eqn: meq *).
+ exact (lfi A i).
+ simpl.
  intros a b.
  exact a.
+ simpl.
  intros a b c.
  exact (a c (b c)).
+ destruct (substF t xi ph) eqn: j.
  2 : {simpl. trivial. }
  apply (correct _ l).
  2 : {assumption. }
  simpl.
pose (Z:=(@Ded (Fora xi ph) f l )).
simple refine (Z _ _ ).
(*
  pose (W:= lfi f).
  destruct (Nat.eqb r xi).
  simpl in H.
  exact H.
  unfold foI.
  simpl.
*)
Abort.

End cor.
(* Definition ACK : list Fo := . *)

End VS.

(*Theorem AA (a:nat):nat.
elim a;
[> revert a | idtac 1].
elim a;
[> idtac 1 | idtac 1].
destruct a.
(*Unfocus.*)
[> idtac 1 | idtac 1].*)


Require Import Coq.ZArith.ZArith.
Require Import riscv.Spec.Decode.
Require Import riscv.Utility.Encode.
Require Import riscv.Utility.Utility.

(* same verification functions as in Encode, but computable: *)

Require Import Coq.derive.Derive.

Lemma andb_spec: forall P Q p q,
    Bool.reflect P p ->
    Bool.reflect Q q ->
    Bool.reflect (P /\ Q) (p && q).
Proof.
  intros. destruct H; destruct H0; constructor; intuition idtac.
Qed.

Lemma orb_spec: forall P Q p q,
    Bool.reflect P p ->
    Bool.reflect Q q ->
    Bool.reflect (P \/ Q) (p || q).
Proof.
  intros. destruct H; destruct H0; constructor; intuition idtac.
Qed.

Lemma negb_spec: forall P p,
    Bool.reflect P p ->
    Bool.reflect (~ P) (negb p).
Proof.
  intros. destruct H; constructor; intuition idtac.
Qed.

Lemma true_spec: Bool.reflect True true. Proof. constructor. constructor. Qed.

Lemma false_spec: Bool.reflect False false. Proof. constructor. auto. Qed.

Local Ltac t :=
  intros;
  repeat match goal with
    | x := _ |- _ => subst x
    end;
  repeat first
    [ eapply andb_spec
    | eapply orb_spec
    | eapply Z.leb_spec0
    | eapply Z.ltb_spec0
    | eapply Z.eqb_spec
    | eapply true_spec
    | eapply false_spec ].

Derive bverify_Invalid SuchThat
  (forall i: Z, Bool.reflect (verify_Invalid i) (bverify_Invalid i))
As bverify_Invalid_spec.
  subst bverify_Invalid.
  intros. unfold verify_Invalid. eapply Bool.ReflectF. auto.
Defined.

Derive bverify_R SuchThat
  (forall (opcode: MachineInt)(rd rs1 rs2: Register)(funct3 funct7: MachineInt),
      Bool.reflect (verify_R opcode rd rs1 rs2 funct3 funct7)
                  (bverify_R opcode rd rs1 rs2 funct3 funct7))
As bverify_R_spec. t. Defined.

Derive bverify_R_atomic SuchThat
  (forall (opcode: MachineInt)(rd rs1 rs2: Register)(funct3 aqrl funct5: MachineInt),
      Bool.reflect (verify_R_atomic opcode rd rs1 rs2 funct3 aqrl funct5)
                  (bverify_R_atomic opcode rd rs1 rs2 funct3 aqrl funct5))
As bverify_R_atomic_spec. t. Defined.

Derive bverify_I SuchThat
  (forall (opcode: MachineInt)(rd rs1: Register)(funct3: MachineInt)(oimm12: Z),
      Bool.reflect (verify_I opcode rd rs1 funct3 oimm12)
                  (bverify_I opcode rd rs1 funct3 oimm12))
As bverify_I_spec. t. Defined.

Derive bverify_I_shift_57 SuchThat
  (forall (opcode: MachineInt)(rd rs1: Register)(shamt5 funct3 funct7: MachineInt),
      Bool.reflect (verify_I_shift_57 opcode rd rs1 shamt5 funct3 funct7)
                  (bverify_I_shift_57 opcode rd rs1 shamt5 funct3 funct7))
As bverify_I_shift_57_spec. t. Defined.

Derive bverify_I_shift_66 SuchThat
  (forall (bitwidth: Z)(opcode: MachineInt)(rd rs1: Register)(shamt6 funct3 funct6: MachineInt),
      Bool.reflect (verify_I_shift_66 bitwidth opcode rd rs1 shamt6 funct3 funct6)
                  (bverify_I_shift_66 bitwidth opcode rd rs1 shamt6 funct3 funct6))
As bverify_I_shift_66_spec. t. Defined.

Derive bverify_I_system SuchThat
  (forall (opcode: MachineInt)(rd rs1: Register)(funct3 funct12: MachineInt),
      Bool.reflect (verify_I_system opcode rd rs1 funct3 funct12)
                  (bverify_I_system opcode rd rs1 funct3 funct12))
As bverify_I_system_spec. t. Defined.

Derive bverify_S SuchThat
  (forall (opcode: MachineInt)(rs1 rs2: Register)(funct3: MachineInt)(simm12: Z),
      Bool.reflect (verify_S opcode rs1 rs2 funct3 simm12)
                  (bverify_S opcode rs1 rs2 funct3 simm12))
As bverify_S_spec. t. Defined.

Derive bverify_SB SuchThat
  (forall (opcode: MachineInt)(rs1 rs2: Register)(funct3: MachineInt)(sbimm12: Z),
      Bool.reflect (verify_SB opcode rs1 rs2 funct3 sbimm12)
                  (bverify_SB opcode rs1 rs2 funct3 sbimm12))
As bverify_SB_spec. t. Defined.

Derive bverify_U SuchThat
  (forall (opcode: MachineInt)(rd: Register)(imm20: Z),
      Bool.reflect (verify_U opcode rd imm20)
                  (bverify_U opcode rd imm20))
As bverify_U_spec. t. Defined.

Derive bverify_UJ SuchThat
  (forall (opcode: MachineInt)(rd: Register)(jimm20: Z),
      Bool.reflect (verify_UJ opcode rd jimm20)
                  (bverify_UJ opcode rd jimm20))
As bverify_UJ_spec. t. Defined.

Derive bverify_Fence SuchThat
  (forall (opcode: MachineInt)(rd rs1: Register)(funct3 prd scc msb4: MachineInt),
      Bool.reflect (verify_Fence opcode rd rs1 funct3 prd scc msb4)
                  (bverify_Fence opcode rd rs1 funct3 prd scc msb4))
As bverify_Fence_spec. t. Defined.

Derive bverify_FenceI SuchThat
  (forall (opcode: MachineInt)(rd rs1: Register)(funct3 imm12: MachineInt),
      Bool.reflect (verify_FenceI opcode rd rs1 funct3 imm12)
                  (bverify_FenceI opcode rd rs1 funct3 imm12))
As bverify_FenceI_spec. t. Defined.

Definition bVerifier(bitwidth: Z): InstructionMapper bool := {|
  map_Invalid := bverify_Invalid;
  map_R := bverify_R;
  map_R_atomic := bverify_R_atomic;
  map_I := bverify_I;
  map_I_shift_57 := bverify_I_shift_57;
  map_I_shift_66 := bverify_I_shift_66 bitwidth;
  map_I_system := bverify_I_system;
  map_S := bverify_S;
  map_SB := bverify_SB;
  map_U := bverify_U;
  map_UJ := bverify_UJ;
  map_Fence := bverify_Fence;
  map_FenceI := bverify_FenceI;
|}.

Definition brespects_bounds(bitwidth: Z): Instruction -> bool :=
  apply_InstructionMapper (bVerifier bitwidth).

Lemma brespects_bounds_spec: forall bitwidth i,
    Bool.reflect (respects_bounds bitwidth i) (brespects_bounds bitwidth i).
Proof.
  intros. unfold respects_bounds, brespects_bounds.
  destruct i as [i | i | i | i | i | i | i | i | i | i ]; destruct i; simpl;
    eauto using bverify_Invalid_spec,
                bverify_R_spec,
                bverify_R_atomic_spec,
                bverify_I_spec,
                bverify_I_shift_57_spec,
                bverify_I_shift_66_spec,
                bverify_I_system_spec,
                bverify_S_spec,
                bverify_SB_spec,
                bverify_U_spec,
                bverify_UJ_spec,
                bverify_Fence_spec,
                bverify_FenceI_spec.
Qed.

Derive iset_eqb SuchThat
  (forall iset1 iset2: InstructionSet, Bool.reflect (iset1 = iset2) (iset_eqb iset1 iset2))
As iset_eqb_spec.
  Unshelve. 2: { intros iset1 iset2. destruct iset1; destruct iset2; shelve. }
  subst iset_eqb.
  destruct iset1; destruct iset2;
    first [ eapply Bool.ReflectT; reflexivity
          | eapply Bool.ReflectF; intro C; discriminate C ].
Defined.

Derive bverify_iset SuchThat
  (forall (inst: Instruction)(iset: InstructionSet),
      Bool.reflect (verify_iset inst iset) (bverify_iset inst iset))
As bverify_iset_spec.
  intros.
  let f := open_constr:(ltac:(intro inst'; destruct inst'; shelve):
                         Instruction -> InstructionSet -> bool) in
  unify bverify_iset f.
  destruct inst; simpl; t; eapply iset_eqb_spec.
Defined.

Definition bverify(inst: Instruction)(iset: InstructionSet): bool :=
  andb (brespects_bounds (bitwidth iset) inst) (bverify_iset inst iset).

Lemma bverify_spec: forall inst iset, Bool.reflect (verify inst iset) (bverify inst iset).
Proof. t; [eapply brespects_bounds_spec | eapply bverify_iset_spec]. Qed.

Definition valid_InvalidInstruction(instr: Decode.Instruction): Prop :=
  exists n, (0 <= n < 2 ^ 32)%Z /\ instr = InvalidInstruction n.

Definition bvalid_InvalidInstruction(instr: Decode.Instruction): bool :=
  match instr with
  | InvalidInstruction n => andb (0 <=? n)%Z (n <? 2 ^ 32)%Z
  | _ => false
  end.

Lemma bvalid_InvalidInstruction_spec: forall instr,
    Bool.reflect (valid_InvalidInstruction instr) (bvalid_InvalidInstruction instr).
Proof.
  destruct instr; cbn -[Z.pow]; cycle -1.
  1: destruct (0 <=? inst)%Z eqn: E1; [|simpl].
  1: destruct (inst <? 2 ^ 32)%Z eqn: E2; simpl.
  all: unfold valid_InvalidInstruction.
  { eapply Bool.ReflectT. eapply Z.leb_le in E1. eapply Z.ltb_lt in E2. eauto. }
  all: eapply Bool.ReflectF; intros (n & (A1 & A2) & B); inversion B; subst; clear B.
  { eapply Z.ltb_lt in A2. congruence. }
  { eapply Z.leb_le in A1. congruence. }
Qed.

Definition validInstruction(iset: InstructionSet)(i: Instruction): Prop :=
  verify i iset \/ valid_InvalidInstruction i.

Definition bvalidInstruction(iset: InstructionSet)(i: Instruction): bool :=
  orb (bverify i iset) (bvalid_InvalidInstruction i).

Lemma bvalidInstruction_spec: forall iset i,
    Bool.reflect (validInstruction iset i) (bvalidInstruction iset i).
Proof.
  intros. eapply orb_spec. 1: eapply bverify_spec. 1: eapply bvalid_InvalidInstruction_spec.
Qed.

Definition validInstructions(iset: InstructionSet): list Instruction -> Prop :=
  List.Forall (validInstruction iset).

Definition bvalidInstructions(iset: InstructionSet): list Instruction -> bool :=
  List.forallb (bvalidInstruction iset).

Lemma bvalidInstructions_spec: forall iset instrs,
    Bool.reflect (validInstructions iset instrs) (bvalidInstructions iset instrs).
Proof.
  intros. destruct (bvalidInstructions iset instrs) eqn: E;
    unfold bvalidInstructions, validInstructions in *.
  - eapply Bool.ReflectT.
    eapply List.Forall_forall.
    intros.
    eapply List.forallb_forall in E. 2: eassumption.
    eapply Bool.reflect_iff. 1: eapply bvalidInstruction_spec. assumption.
  - eapply Bool.ReflectF.
    intro C.
    pose proof (proj1 (List.Forall_forall _ _) C) as D.
    assert (forall i, List.In i instrs -> bvalidInstruction iset i = true) as F. {
      intros. eapply (proj1 (Bool.reflect_iff _ _ (bvalidInstruction_spec iset i))).
      eapply D. assumption.
    }
    eapply List.forallb_forall in F.
    congruence.
Qed.

Lemma bvalidInstructions_valid: forall iset instrs,
    bvalidInstructions iset instrs = true -> validInstructions iset instrs.
Proof. intros. eapply Bool.reflect_iff. 1: eapply bvalidInstructions_spec. assumption. Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sidi Ould-Biha, 2010-04-27

Definitions and proofs about the min of a non empty set of natural
numbers, using classical logic and the axiom of indefinite
description. *)

From Coq Require Import Classical_Prop IndefiniteDescription Wf_nat Relations.

Set Implicit Arguments.

(***********************************************************************)
(** unary predicate *)

Section P1.

  Variables (P : nat -> Prop) (exP : exists n, P n).

  Lemma ch_min_proof : has_unique_least_element le P.

  Proof.
    apply dec_inh_nat_subset_has_unique_least_element; auto.
    intros. apply classic.
  Qed.

  Definition ch_min := constructive_indefinite_description _ ch_min_proof.

  Lemma ch_minP : P (proj1_sig ch_min).

  Proof. destruct (proj2_sig ch_min) as [H _]. destruct H. auto. Qed.

  Lemma is_min_ch : forall n, P n -> proj1_sig ch_min <= n.

  Proof.
    destruct (proj2_sig ch_min) as [H _]. destruct H. intros. apply H0. auto.
  Qed.

End P1.

Arguments ch_min [P] _.

(***********************************************************************)
(** binary predicate *)

Section P2.

  Variables (P2 : relation nat) (exP2 : forall m, exists n, P2 m n).

  Fixpoint rec_ch_min n : nat :=
    match n with
      | S n' => proj1_sig (ch_min (exP2 (S (rec_ch_min n'))))
      | 0 => proj1_sig (ch_min (exP2 0))
    end.

  Lemma rec_ch_minP : forall i, P2 (S (rec_ch_min i)) (rec_ch_min (S i)).

  Proof. intros. simpl. apply ch_minP. Qed.

  Lemma is_min_rec_ch : forall i n,
    P2 (S (rec_ch_min i)) n -> (rec_ch_min (S i)) <= n.

  Proof. intros. simpl. apply is_min_ch. auto. Qed.

End P2.


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

(** Multi-way branches (``switch'' statements) and their compilation
    to comparison trees. *)

Require Import EqNat.
Require Import Coqlib.
Require Import Maps.
Require Import Integers.

Module IntIndexed <: INDEXED_TYPE.

  Definition t := int.

  Definition index (n: int) : positive :=
    match Int.unsigned n with
    | Z0 => xH
    | Zpos p => xO p
    | Zneg p => xI p  (**r never happens *)
    end.

  Lemma index_inj: forall n m, index n = index m -> n = m.
  Proof.
    unfold index; intros.
    rewrite <- (Int.repr_unsigned n). rewrite <- (Int.repr_unsigned m).
    f_equal.
    destruct (Int.unsigned n); destruct (Int.unsigned m); congruence.
  Qed.

  Definition eq := Int.eq_dec.

End IntIndexed.

Module IntMap := IMap(IntIndexed).

(** A multi-way branch is composed of a list of (key, action) pairs,
  plus a default action.  *)

Definition table : Type := list (int * nat).

Fixpoint switch_target (n: int) (dfl: nat) (cases: table)
                       {struct cases} : nat :=
  match cases with
  | nil => dfl
  | (key, action) :: rem =>
      if Int.eq n key then action else switch_target n dfl rem
  end.

(** Multi-way branches are translated to comparison trees.
    Each node of the tree performs either
- an equality against one of the keys;
- or a "less than" test against one of the keys;
- or a computed branch (jump table) against a range of key values. *)

Inductive comptree : Type :=
  | CTaction: nat -> comptree
  | CTifeq: int -> nat -> comptree -> comptree
  | CTiflt: int -> comptree -> comptree -> comptree
  | CTjumptable: int -> int -> list nat -> comptree -> comptree.

Fixpoint comptree_match (n: int) (t: comptree) {struct t}: option nat :=
  match t with
  | CTaction act => Some act
  | CTifeq key act t' =>
      if Int.eq n key then Some act else comptree_match n t'
  | CTiflt key t1 t2 =>
      if Int.ltu n key then comptree_match n t1 else comptree_match n t2
  | CTjumptable ofs sz tbl t' =>
      if Int.ltu (Int.sub n ofs) sz
      then list_nth_z tbl (Int.unsigned (Int.sub n ofs))
      else comptree_match n t'
  end.

(** The translation from a table to a comparison tree is performed
  by untrusted Caml code (function [compile_switch] in
  file [RTLgenaux.ml]).  In Coq, we validate a posteriori the
  result of this function.  In other terms, we now develop
  and prove correct Coq functions that take a table and a comparison
  tree, and check that their semantics are equivalent. *)

Fixpoint split_lt (pivot: int) (cases: table)
                  {struct cases} : table * table :=
  match cases with
  | nil => (nil, nil)
  | (key, act) :: rem =>
      let (l, r) := split_lt pivot rem in
      if Int.ltu key pivot
      then ((key, act) :: l, r)
      else (l, (key, act) :: r)
  end.

Fixpoint split_eq (pivot: int) (cases: table)
                  {struct cases} : option nat * table :=
  match cases with
  | nil => (None, nil)
  | (key, act) :: rem =>
      let (same, others) := split_eq pivot rem in
      if Int.eq key pivot
      then (Some act, others)
      else (same, (key, act) :: others)
  end.

Fixpoint split_between (dfl: nat) (ofs sz: int) (cases: table)
                       {struct cases} : IntMap.t nat * table :=
  match cases with
  | nil => (IntMap.init dfl, nil)
  | (key, act) :: rem =>
      let (inside, outside) := split_between dfl ofs sz rem in
      if Int.ltu (Int.sub key ofs) sz
      then (IntMap.set key act inside, outside)
      else (inside, (key, act) :: outside)
  end.

Definition refine_low_bound (v lo: Z) :=
  if zeq v lo then lo + 1 else lo.

Definition refine_high_bound (v hi: Z) :=
  if zeq v hi then hi - 1 else hi.

Fixpoint validate_jumptable (cases: IntMap.t nat)
                            (tbl: list nat) (n: int) {struct tbl} : bool :=
  match tbl with
  | nil => true
  | act :: rem =>
      beq_nat act (IntMap.get n cases)
      && validate_jumptable cases rem (Int.add n Int.one)
  end.

Fixpoint validate (default: nat) (cases: table) (t: comptree)
                  (lo hi: Z) {struct t} : bool :=
  match t with
  | CTaction act =>
      match cases with
      | nil =>
          beq_nat act default
      | (key1, act1) :: _ =>
          zeq (Int.unsigned key1) lo && zeq lo hi && beq_nat act act1
      end
  | CTifeq pivot act t' =>
      match split_eq pivot cases with
      | (None, _) =>
          false
      | (Some act', others) =>
          beq_nat act act'
          && validate default others t'
                      (refine_low_bound (Int.unsigned pivot) lo)
                      (refine_high_bound (Int.unsigned pivot) hi)
      end
  | CTiflt pivot t1 t2 =>
      match split_lt pivot cases with
      | (lcases, rcases) =>
          validate default lcases t1 lo (Int.unsigned pivot - 1)
          && validate default rcases t2 (Int.unsigned pivot) hi
      end
  | CTjumptable ofs sz tbl t' =>
      let tbl_len := list_length_z tbl in
      match split_between default ofs sz cases with
      | (inside, outside) =>
          zle (Int.unsigned sz) tbl_len
          && zle tbl_len Int.max_signed
          && validate_jumptable inside tbl ofs
          && validate default outside t' lo hi
     end
  end.

Definition validate_switch (default: nat) (cases: table) (t: comptree) :=
  validate default cases t 0 Int.max_unsigned.

(** Correctness proof for validation. *)

Lemma split_eq_prop:
  forall v default n cases optact cases',
  split_eq n cases = (optact, cases') ->
  switch_target v default cases =
   (if Int.eq v n
    then match optact with Some act => act | None => default end
    else switch_target v default cases').
Proof.
  induction cases; simpl; intros until cases'.
  intros. inversion H; subst. simpl.
  destruct (Int.eq v n); auto.
  destruct a as [key act].
  case_eq (split_eq n cases). intros same other SEQ.
  rewrite (IHcases _ _ SEQ).
  predSpec Int.eq Int.eq_spec key n; intro EQ; inversion EQ; simpl.
  subst n. destruct (Int.eq v key). auto. auto.
  predSpec Int.eq Int.eq_spec v key.
  subst v. predSpec Int.eq Int.eq_spec key n. congruence. auto.
  auto.
Qed.

Lemma split_lt_prop:
  forall v default n cases lcases rcases,
  split_lt n cases = (lcases, rcases) ->
  switch_target v default cases =
    (if Int.ltu v n
     then switch_target v default lcases
     else switch_target v default rcases).
Proof.
  induction cases; intros until rcases; simpl.
  intro. inversion H; subst. simpl.
  destruct (Int.ltu v n); auto.
  destruct a as [key act].
  case_eq (split_lt n cases). intros lc rc SEQ.
  rewrite (IHcases _ _ SEQ).
  case_eq (Int.ltu key n); intros; inv H0; simpl.
  predSpec Int.eq Int.eq_spec v key.
  subst v. rewrite H. auto.
  auto.
  predSpec Int.eq Int.eq_spec v key.
  subst v. rewrite H. auto.
  auto.
Qed.

Lemma split_between_prop:
  forall v default ofs sz cases inside outside,
  split_between default ofs sz cases = (inside, outside) ->
  switch_target v default cases =
    (if Int.ltu (Int.sub v ofs) sz
     then IntMap.get v inside
     else switch_target v default outside).
Proof.
  induction cases; intros until outside; simpl; intros SEQ.
- inv SEQ. destruct (Int.ltu (Int.sub v ofs) sz); auto. rewrite IntMap.gi. auto.
- destruct a as [key act].
  destruct (split_between default ofs sz cases) as [ins outs].
  erewrite IHcases; eauto.
  destruct (Int.ltu (Int.sub key ofs) sz) eqn:LT; inv SEQ.
  + predSpec Int.eq Int.eq_spec v key.
    subst v. rewrite LT. rewrite IntMap.gss. auto.
    destruct (Int.ltu (Int.sub v ofs) sz).
    rewrite IntMap.gso; auto.
    auto.
  + simpl. destruct (Int.ltu (Int.sub v ofs) sz) eqn:LT'.
    rewrite Int.eq_false. auto. congruence.
    auto.
Qed.

Lemma validate_jumptable_correct_rec:
  forall cases tbl base v,
  validate_jumptable cases tbl base = true ->
  0 <= Int.unsigned v < list_length_z tbl ->
  list_nth_z tbl (Int.unsigned v) = Some(IntMap.get (Int.add base v) cases).
Proof.
  induction tbl; intros until v; simpl.
  unfold list_length_z; simpl. intros. omegaContradiction.
  rewrite list_length_z_cons. intros. destruct (andb_prop _ _ H). clear H.
  generalize (beq_nat_eq _ _ (sym_equal H1)). clear H1. intro. subst a.
  destruct (zeq (Int.unsigned v) 0).
  unfold Int.add. rewrite e. rewrite Zplus_0_r. rewrite Int.repr_unsigned. auto.
  assert (Int.unsigned (Int.sub v Int.one) = Int.unsigned v - 1).
    unfold Int.sub. change (Int.unsigned Int.one) with 1.
    apply Int.unsigned_repr. split. omega.
    generalize (Int.unsigned_range_2 v). omega.
  replace (Int.add base v) with (Int.add (Int.add base Int.one) (Int.sub v Int.one)).
  rewrite <- IHtbl. rewrite H. auto. auto. rewrite H. omega.
  rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite Int.add_assoc.
  replace (Int.add Int.one (Int.neg Int.one)) with Int.zero.
  rewrite Int.add_zero. apply Int.add_commut.
  rewrite Int.add_neg_zero; auto.
Qed.

Lemma validate_jumptable_correct:
  forall cases tbl ofs v sz,
  validate_jumptable cases tbl ofs = true ->
  Int.ltu (Int.sub v ofs) sz = true ->
  Int.unsigned sz <= list_length_z tbl ->
  list_nth_z tbl (Int.unsigned (Int.sub v ofs)) = Some(IntMap.get v cases).
Proof.
  intros.
  exploit Int.ltu_inv; eauto. intros.
  rewrite (validate_jumptable_correct_rec cases tbl ofs).
  rewrite Int.sub_add_opp. rewrite Int.add_permut. rewrite <- Int.sub_add_opp.
  rewrite Int.sub_idem. rewrite Int.add_zero. auto.
  auto.
  omega.
Qed.

Lemma validate_correct_rec:
  forall default v t cases lo hi,
  validate default cases t lo hi = true ->
  lo <= Int.unsigned v <= hi ->
  comptree_match v t = Some (switch_target v default cases).
Proof.
Opaque Int.sub.
  induction t; simpl; intros until hi.
  (* base case *)
  destruct cases as [ | [key1 act1] cases1]; intros.
  replace n with default. reflexivity.
  symmetry. apply beq_nat_eq. auto.
  destruct (andb_prop _ _ H). destruct (andb_prop _ _ H1). clear H H1.
  assert (Int.unsigned key1 = lo). eapply proj_sumbool_true; eauto.
  assert (lo = hi). eapply proj_sumbool_true; eauto.
  assert (Int.unsigned v = Int.unsigned key1). omega.
  replace n with act1.
  simpl. unfold Int.eq. rewrite H5. rewrite zeq_true. auto.
  symmetry. apply beq_nat_eq. auto.
  (* eq node *)
  case_eq (split_eq i cases). intros optact cases' EQ.
  destruct optact as [ act | ]. 2: congruence.
  intros. destruct (andb_prop _ _ H). clear H.
  rewrite (split_eq_prop v default _ _ _ _ EQ).
  predSpec Int.eq Int.eq_spec v i.
  f_equal. apply beq_nat_eq; auto.
  eapply IHt. eauto.
  assert (Int.unsigned v <> Int.unsigned i).
    rewrite <- (Int.repr_unsigned v) in H.
    rewrite <- (Int.repr_unsigned i) in H.
    congruence.
  split.
  unfold refine_low_bound. destruct (zeq (Int.unsigned i) lo); omega.
  unfold refine_high_bound. destruct (zeq (Int.unsigned i) hi); omega.
  (* lt node *)
  case_eq (split_lt i cases). intros lcases rcases EQ V RANGE.
  destruct (andb_prop _ _ V). clear V.
  rewrite (split_lt_prop v default _ _ _ _ EQ).
  unfold Int.ltu. destruct (zlt (Int.unsigned v) (Int.unsigned i)).
  eapply IHt1. eauto. omega.
  eapply IHt2. eauto. omega.
  (* jumptable node *)
  case_eq (split_between default i i0 cases). intros ins outs EQ V RANGE.
  destruct (andb_prop _ _ V). clear V.
  destruct (andb_prop _ _ H). clear H.
  destruct (andb_prop _ _ H1). clear H1.
  rewrite (split_between_prop v _ _ _ _ _ _ EQ).
  case_eq (Int.ltu (Int.sub v i) i0); intros.
  eapply validate_jumptable_correct; eauto.
  eapply proj_sumbool_true; eauto.
  eapply IHt; eauto.
Qed.

Definition table_tree_agree
    (default: nat) (cases: table) (t: comptree) : Prop :=
  forall v, comptree_match v t = Some(switch_target v default cases).

Theorem validate_switch_correct:
  forall default t cases,
  validate_switch default cases t = true ->
  table_tree_agree default cases t.
Proof.
  unfold validate_switch, table_tree_agree; intros.
  eapply validate_correct_rec; eauto.
  apply Int.unsigned_range_2.
Qed.