Require Import TLA.Syntax.
Require Import TLA.Semantics.
Require Import TLA.ProofRules.
Require Import String.
Local Open Scope HP_scope.
Local Open Scope string_scope.
Require Import List.
Require Import Strings.String.
Import ListNotations.
Require Import Rdefinitions.
Require Import RelDec.
Require Import Coq.Reals.Rbase.
Require Import Z3.Tactic.
Require Import Abstractor.
Require Import TLA.Automation.
Require Import Coq.Classes.Morphisms.

Lemma Z3Test : forall (a : R), (a + 1 = 3)%R%type -> ((a + 2 = 3)%R /\ ((1+1)%R=2%R)%R)%type.
Proof.
  intros.
  (*z3 solve.*)
  Abort.

(* Implementation of postprocessing automation for the Abstractor,
   using the Z3 plugin to simplify the terms produced b ythe abstractor *)

(* test cases - velocity shim *)

Definition velshim : fcmd :=
  FIte (FMinus (FVar "ub") (FPlus (FMult (FVar "a") (FVar "d")) (FVar "vmax")))
       (FAsn "a" (FVar "a"))
       (FAsn "a" (FConst fzero)).

Definition velshim_ivs : list (Var * Var) :=
  [("ub", "ub"); ("a", "a"); ("d", "d"); ("vmax", "vmax")].

(* proportional controller *)

Print FMinus.

(* c is constant and goal is 0 *)
Definition proportional_controller : fcmd :=
  FAsn "a" (FMinus (FConst fzero) (FVar "x")).

Definition proportional_controller_ivs : list (Var * Var) :=
  [("a", "a"); ("x", "x")].

(* "Pushing" Embed through connectives *)
Lemma lequiv_formula_iff :
  forall (P Q : Formula),
    (forall tr, eval_formula P tr <-> eval_formula Q tr) <->
    (P -|- Q).
Proof.
  intros.
  split.
  - intros. split; breakAbstraction; intros; apply H; assumption.
  - intros. unfold lequiv in H. destruct H.
    breakAbstraction.
    split; intros; [apply H | apply H0]; assumption.
Qed.

Ltac shatterAbstraction :=
  try apply lequiv_formula_iff; unfold lequiv in *; breakAbstraction.

Lemma embed_push_TRUE :
  Embed (fun _ _ => True) -|- TRUE.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma embed_push_FALSE :
  Embed (fun _ _ => False) -|- FALSE.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma embed_push_And :
  forall (P1 P2 : _ -> _ -> Prop) (F1 F2 : Formula),
    Embed P1 -|- F1 -> Embed P2 -|- F2 ->
    Embed (fun x y => P1 x y /\ P2 x y) -|- F1 //\\ F2.
Proof.
  shatterAbstraction. intuition.
Qed.

Lemma embed_push_Or :
  forall (P1 P2 : _ -> _ -> Prop) (F1 F2 : Formula),
    Embed P1 -|- F1 -> Embed P2 -|- F2 ->
    Embed (fun x y => P1 x y \/ P2 x y) -|- F1 \\// F2.
Proof.
  shatterAbstraction. intuition.
Qed.

Lemma embed_push_Imp :
  forall (P1 P2 : _ -> _ -> Prop) (F1 F2 : Formula),
    Embed P1 -|- F1 -> Embed P2 -|- F2 ->
    Embed (fun x y => P1 x y -> P2 x y) -|- F1 -->> F2.
Proof.
  shatterAbstraction. intuition.
Qed.

Lemma embed_push_Exists :
  forall (T : Type) (P : T -> state -> state -> Prop) (F : T -> Formula),
    (forall (t : T), Embed (P t) -|- F t) ->
    Embed (fun x y => exists (t : T), (P t x y)) -|- lexists F.
Proof.
  shatterAbstraction.
  intuition.
  fwd. specialize (H x). fwd.
  eexists. eauto.
  fwd. specialize (H x). fwd.
  eexists. eauto.
Qed.

Lemma embed_push_Forall :
  forall (T : Type) (P : T -> state -> state -> Prop) (F : T -> Formula),
    (forall (t : T), Embed (P t) -|- F t) ->
    Embed (fun x y => forall (t : T), (P t x y)) -|- lforall F.
Proof.
  intros.
  shatterAbstraction. intuition.
  eapply H. apply H0.
  eapply H. apply H0.
Qed.

Lemma embed_push_Const : forall P, Embed (fun _ _ => P) -|- PropF P.
Proof.
  shatterAbstraction; tlaIntuition.
Qed.

(* Relation expressing a side-condition that must be used to push embed through arithmetic facts *)
Definition evals_to (f : Term) (f' : state -> state -> R) : Prop :=
  (eval_term f = f')%type.

Notation "f =|> g" := (evals_to f g) (at level 60).

(* comparison pushing *)
Lemma embed_push_Eq :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    Embed (fun x y => l' x y = r' x y)%type -|-
          Comp l r Eq.
Proof.
  intros.
  unfold evals_to in *.
  shatterAbstraction. subst. reflexivity.
Qed.

Lemma embed_push_Gt :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    Embed (fun x y => Rgt (l' x y) (r' x y))%type -|-
          Comp l r Gt.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma embed_push_Ge :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    Embed (fun x y => Rge (l' x y) (r' x y))%type -|-
          Comp l r Ge.
Proof.
  intros.
  unfold evals_to in *.
  shatterAbstraction. subst. reflexivity.
Qed.

Lemma embed_push_Lt :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    Embed (fun x y => Rlt (l' x y) (r' x y))%type -|-
          Comp l r Lt.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma embed_push_Le :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    Embed (fun x y => Rle (l' x y) (r' x y))%type -|-
          Comp l r Le.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

(* arithmetic pushing *)
Lemma arith_push_plus :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    PlusT l r =|> (fun x y => l' x y + r' x y)%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma arith_push_minus :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    MinusT l r =|> (fun x y => l' x y - r' x y)%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma arith_push_mult :
  forall l r l' r',
    l =|> l' ->
    r =|> r' ->
    MultT l r =|> (fun x y => l' x y * r' x y)%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma arith_push_inv :
  forall l l',
    l =|> l' ->
    InvT l =|> (fun x y => / (l' x y))%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma arith_push_cos :
  forall l l',
    l =|> l' ->
    CosT l =|> (fun x y => Rtrigo_def.cos (l' x y))%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

Lemma arith_push_sin :
  forall l l',
    l =|> l' ->
    SinT l =|> (fun x y => Rtrigo_def.sin (l' x y))%R.
Proof.
  intros. unfold evals_to in *. shatterAbstraction. subst. reflexivity.
Qed.

(* var, real *)
Lemma arith_push_VarNow :
  forall (x : Var),
    VarNowT x =|> fun st _ => st x.
Proof.
  reflexivity.
Qed.

Lemma arith_push_VarNext :
  forall (x : Var),
    VarNextT x =|> fun _ st' => st' x.
Proof.
  reflexivity.
Qed.

(* special cases for 0 and 1: want to compile these into nats,
   since nat are easier to work with *)
Lemma arith_push_Nat_zero :
    NatT 0 =|> fun _ _ => 0%R.
Proof. reflexivity. Qed.

Lemma arith_push_Nat_one :
    NatT 1 =|> fun _ _ => 1%R.
Proof. reflexivity. Qed.

Lemma arith_push_Nat :
  forall (n : nat),
    NatT n =|> fun _ _ => INR n.
Proof. reflexivity. Qed.

Lemma arith_push_Real :
  forall (r : R),
    RealT r =|> fun _ _ => r.
Proof. reflexivity. Qed.

(* for solving goals containing fupdate *)
Lemma arith_push_fupdate_eq :
  forall (t: state -> state -> R) (v : Var) (X : Term) f,
    X =|> t ->
    X =|> (fun x y : state => fupdate (f x y) v (t x y) v).
Proof.
  intros. unfold evals_to in *.
  rewrite H. unfold fupdate.
  rewrite rel_dec_eq_true; eauto with typeclass_instances.
Qed.

Lemma arith_push_fupdate_neq :
  forall (t: state -> state -> R) (v v' : Var) (X : Term) f,
    v <> v' ->
    X =|> (fun x y : state => f x y v') ->
    X =|> (fun x y : state => fupdate (f x y) v (t x y) v').
Proof.
  intros.
  unfold fupdate, evals_to in *. rewrite H0.
  rewrite rel_dec_neq_false; eauto with typeclass_instances.
Qed.

Create HintDb embed_push discriminated.
Create HintDb arith_push discriminated.

Hint Rewrite
     embed_push_TRUE embed_push_FALSE
     embed_push_And embed_push_Or embed_push_Imp
     embed_push_Exists embed_push_Forall
     embed_push_Const
  : embed_push.

Hint Rewrite
     embed_push_Eq embed_push_Gt embed_push_Ge embed_push_Lt embed_push_Le
     using solve [eauto 20 with arith_push]
                         : embed_push.

(* for the "<>" goals created by arith_push_fupdate_neq *)
Hint Extern
     0 (_ <> _) => congruence : arith_push.

(* Other miscellaneous rewriting lemmas *)
Lemma AnyOf_singleton :
  forall (P : Prop), AnyOf [P] -|- P.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma AnyOf_weaken :
  forall (P : Prop) (Ps : list Prop),
    AnyOf Ps |-- AnyOf (P :: Ps).
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma and_True_snip1 :
  forall (P : Prop),
    True //\\ P -|- P.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma and_True_snip2 :
  forall (P : Prop),
    P //\\ True -|- P.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma or_False_snip1 :
  forall (P : Prop),
    P \\// False -|- P.
Proof.
  shatterAbstraction. tauto.
Qed.

Lemma or_False_snip2 :
  forall (P : Prop),
    False \\// P -|- P.
Proof.
  shatterAbstraction. tauto.
Qed.

(* Very simple program for testing. We want to prove that x stays >0 *)
Definition float_one := source.nat_to_float 1.
Definition simple_prog : fcmd :=
  FAsn "x" (FPlus (FConst float_one) (FVar "x")).

Definition simple_prog_ivs : list (Var * Var) :=
  [("x", "x")].

Definition simpler_prog : fcmd :=
  FAsn "x" (FConst float_one).

Lemma PropF_revert :
  forall (P : Prop) (G Q : Syntax.Formula),
    (P -> G |-- Q) ->
    (G |-- PropF P -->> Q).
Proof.
  tlaIntuition.
Qed.

Lemma PropF_pull :
  forall (P : Prop) (G Q : Syntax.Formula),
    P ->
    (G |-- Q) ->
    (PropF P -->> G |-- Q).
Proof.
  tlaIntuition.
Qed.

Require Import bound.
Require Import source.
Definition FP2RP (ivs : list (Var * Var)) (P : fstate -> Prop) : state -> Prop :=
  (fun st =>
     exists (fst : fstate), vmodels ivs st fst /\ P fst).

(* Version of HoareA_embed_ex we can use for rewriting. *)
Require Import source.
(*
Lemma Hoare__embed_rw :
  forall (c : fcmd)
         (vs1 : list (Var * Var)),
    var_spec_valid' vs1 ->
    varmap_check_fcmd vs1 c ->
    oembed_fcmd vs1 vs1 c |--
                Forall Q : fstate -> Prop,
  let P := fwp c Q in
  Embed (fun st st' : state =>
           (exists fst : fstate,
             vmodels vs1 st fst /\
             P fst) -> exists fst' : fstate, vmodels vs1 st' fst' /\ Q fst').
 *)
(*
Lemma Hoare__embed_rw :
  forall (c : fcmd)
         (vs1 : list (Var * Var)),
    var_spec_valid' vs1 ->
    varmap_check_fcmd vs1 c ->
    oembed_fcmd vs1 vs1 c |--
                Forall Q : fstate -> Prop,
  let P := fwp c Q in
  Embed (fun st st' : state =>
           FP2RP vs1 P st -> FP2RP vs1 Q st').
Proof.
  intros. apply lforallR.
  intro. simpl. restoreAbstraction.
  tlaRevert.
  unfold FP2RP.
  breakAbstraction.
  intros.
  fwd.
  destruct H5.
  unfold vmodels in *.
  exists x0. split; eauto.

  intros.
  fwd.
  destruct H5.
  { inversion H5; subst; clear H5; try congruence.
    { simpl in H4.
    -
  }

  {
  split.

  apply fwp_correct in H4. fwd.
  destruct x2; try congruence.
  specialize (H7 _ H4).
  exists f.
  split; auto.
  destruct H5.
  unfold limpl.
  simpl.
  unfold tlaEntails.
  intros.
  simpl.
  shatterAbstraction.
  intros.
  eexists. intros.
  simpl.
  eapply Hoare__embed.
  Check Hoare__embed.
  (*fix this later *)
Admitted.
*)

Require Import ExtLib.Tactics.
Lemma Hoare__embed_rw :
  forall (c : fcmd)
         (vs1 : list (Var * Var)),
    var_spec_valid' vs1 ->
    varmap_check_fcmd vs1 c ->
    oembed_fcmd vs1 vs1 c |--
                Forall Q : fstate -> Prop,
  let P := fwp c Q in
  Embed (fun st st' : state =>
           (exists fst : fstate,
             vmodels vs1 st fst /\
             (P fst -> exists fst' : fstate, vmodels vs1 st' fst' /\ Q fst'))).
Proof.
  intros.
  breakAbstraction.
  intros.
  fwd.
  exists x0.
  split; auto.
  intros.
  eapply fwp_correct in H3.
  fwd.
  destruct H2; try congruence.
  fwd.
  consider x1; intros; try congruence; subst.
  exists x2.
  split; auto.
Qed.

Check fwp.
Print SEMR.

(*
Lemma HoareA_embed_ex_rw_orig :
  forall (c : fcmd) (vs1 : list (Var * Var)),
    var_spec_valid' vs1 ->
    varmap_check_fcmd vs1 c ->
    oembed_fcmd vs1 vs1 c |--
                Forall Q : fstate -> Prop,
  let P := fwp c Q in
  PropF (SEMR vs1 Q) -->> Embed (fun st st' : state => P st -> Q st').
*)

Require Import source.
Definition FP2RP' (ivs : list (Var * Var)) (P : fstate -> Prop) (Q : Prop) : state -> Prop :=
  (fun st =>
     exists (fst : fstate), vmodels ivs st fst /\ (P fst -> Q)).

Lemma Hoare__embed_rw' :
  forall (c : fcmd)
         (vs1 : list (Var * Var)),
    var_spec_valid' vs1 ->
    varmap_check_fcmd vs1 c ->
    oembed_fcmd vs1 vs1 c |--
                Forall Q : fstate -> Prop,
  let P := fwp c Q in
  Embed (fun st st' : state =>
           FP2RP' vs1 P (exists fst' : fstate, vmodels vs1 st' fst' /\ Q fst') st).
Proof.
  generalize (Hoare__embed_rw); intro HHer.
  simpl in HHer.
  simpl.
  unfold FP2RP'.
  eapply HHer.
Qed.

Axiom Always_proper : Proper (lentails ==> lentails) Syntax.Always.
Existing Instance Always_proper.

(* Used to begin rewriting in our goal. *)
Lemma lequiv_rewrite_left :
  forall (A B C : Formula),
    A -|- C -> C |-- B -> A |-- B.
Proof.
  shatterAbstraction. intuition.
Qed.

(* Convert a predicate over float states to a predicate over real states *)
Check fstate_lookup.
(*
Definition FP2RP (P : fstate -> Prop) : state -> Prop :=
  (fun st =>
     exists (fst : fstate),
       (forall (v : Var) (f : float), fstate_lookup fst v = Some f ->
                                      exists r, F2OR f = Some r /\ st v = r) /\
       P fst).
 *)

(* Here is the thing I am trying to figure out *)
(*
Lemma FP2RP_rewrite :
  forall ivs,
  _ /\ (isFloat ivs _) -|- FP2RP ivs (fun st => ... (F2R x...)).
*)

(* this theorem is not true so try something that is, like always set x to 5; need invariant that x is float
   simple_prog_ivs will be given to is_float
 *)

Check isVarValid.

(* Automation for rewriting Embeds *)
Hint Extern
     0 (_ =|> (fun _ _ => ?X)) => first [ apply arith_push_Nat_zero | apply arith_push_Nat_one
                                          | apply arith_push_Nat | apply arith_push_Real]
                                  : arith_push.

Hint Resolve
     arith_push_plus arith_push_minus arith_push_mult arith_push_inv
     arith_push_sin arith_push_cos
     arith_push_VarNow arith_push_VarNext
     arith_push_fupdate_eq arith_push_fupdate_neq
  : arith_push.

(* Automation for pushing through embed rewriting *)
Ltac crunch_embeds :=
  progress repeat
           match goal with
           | |- Embed (fun x y => vmodels _ _ _) -|- _ => reflexivity
           | |- Embed (fun x y => _ -> _) -|- _ => eapply embed_push_Imp
           | |- Embed (fun x y => _ \/ _) -|- _ => eapply embed_push_Or
           | |- Embed (fun x y => _ /\ _) -|- _ => eapply embed_push_And
           | |- Embed (fun x y => exists z, _) -|- _ => eapply embed_push_Exists; intro
           | |- Embed (fun x y => forall z, _) -|- _ => eapply embed_push_Forall; intro
           | |- Embed (fun x y => _ = _) -|- _ => eapply embed_push_Eq; eauto with arith_push
           | |- Embed (fun x y => (_ < _)%R) -|- _ => eapply embed_push_Lt; eauto with arith_push
           | |- Embed (fun x y => (_ <= _)%R) -|- _ => eapply embed_push_Le; eauto with arith_push
           | |- Embed (fun x y => (_ > _)%R) -|- _ => eapply embed_push_Gt; eauto with arith_push
           | |- Embed (fun x y => (_ >= _)%R) -|- _ => eapply embed_push_Ge; eauto with arith_push
           | |- Embed (fun x y => ?X) -|- _ => eapply embed_push_Const
           end.

(* Small logic lemmas for the subsequent theorem *)
Lemma lentail_cut1 :
  forall (A B C : Formula),
    C |-- A ->
    A -->> B |-- C -->> B.
Proof.
  intros. breakAbstraction. intuition.
Qed.

Lemma lentail_cut2 :
  forall (A B C D : Formula),
    C |-- A ->
    B |-- D ->
    (A -->> B |-- C -->> D).
Proof.
  intros. tlaIntuition.
Qed.

Lemma land_comm_left :
  forall (A B C : Formula),
    A //\\ B |-- C ->
    B //\\ A |-- C.
Proof.
  tlaIntuition.
Qed.

Lemma limpl_comm1 :
  forall (A B C D : Formula),
    A |-- B -->> C -->> D ->
    A |-- C -->> B -->> D.
Proof.
  tlaIntuition.
Qed.

(*Fact fwp_simple : |-- "x" > 0 //\\ [](oembed_fcmd simple_prog_ivs simple_prog_ivs simple_prog) -->> []("x" > 0).*)
Fact fwp_simpler : |-- "x" > 0 //\\ [](oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog) -->> []("x" > 0).
Proof.
  erewrite -> Hoare__embed_rw; [| solve [simpl; intuition] | solve [simpl; intuition; eauto]].
  charge_intros.
  eapply discr_indX.
  { red; intuition. }
  { charge_assumption. }
  { charge_assumption. }
  {
    (* rhs *)
    rewrite landforallDL. eapply lforallL.
    instantiate (1 := (fun fst => exists f, fstate_lookup fst "x" = Some f /\ exists r, F2OR f = Some r /\ (r > 0)%R)).
    tlaRevert.
    simpl fwp.
    eapply lequiv_rewrite_left.

    {
      crunch_embeds.
    }

    apply lexistsL.
    intro.

    apply land_comm_left.
    apply landAdj.
    apply limpl_comm1.
    apply lentail_cut2.

    Require Import Coq.micromega.Psatz.
    {
      breakAbstraction.
      intros.
      exists float_one.
      split; try reflexivity.
      left.
      split; auto.
      intros.
      generalize fstate_lookup_update_match; intro Hflum.
      symmetry in Hflum.
      rewrite Hflum.
      exists x0.
      split; try reflexivity.
      exists x1.
      split; auto.
      unfold F2OR, FloatToR in H0.
      destruct x0; try congruence.
      - lazy in H0. lazy in H1. (* contradiction *) psatz R.
      - lazy in H1. psatz R.
    }
    {
      breakAbstraction.
      intros.
      fwd.
      unfold fstate_lookupR in H.
      rewrite H2 in H.
      rewrite H3 in H.
      inversion H; subst; clear H.
      assumption.
    }
  }
Qed.

(*
Definition varValidPre (v : Var) : Syntax.Formula :=
  Embed (fun pre _ =>
           exists (f : float), (eq (F2OR f) (Some (pre v)))).

Definition varValidPost (v : Var) : Syntax.Formula :=
  Embed (fun _ post =>
           exists (f : float), (eq (F2OR f) (Some (post v)))).

Definition varValidBoth (v : Var) : Syntax.Formula :=
  varValidPre v //\\ varValidPost v.
 *)

(* Embed (...) can't be a state formula, so here are versions that
   do not use it. *)

(* TODO: we can't encode these definitions in the current version of RTLA, I think. *)
(*
Definition varValidPre (v : Var) : Syntax.Formula :=
  Embed (fun pre _ =>
           exists (f : float), (eq (F2OR f) (Some (pre v)))).

Definition varValidPost (v : Var) : Syntax.Formula :=
  Embed (fun _ post =>
           exists (f : float), (eq (F2OR f) (Some (post v)))).

Definition varValidBoth (v : Var) : Syntax.Formula :=
  varValidPre v //\\ varValidPost v.
 *)

(* Predicate capturing that the given variable is a float in the pre-state *)
(* todo, possibly: lift to variable maps? *)
Definition preVarIsFloat (v : Var) : Syntax.Formula :=
  Syntax.Exists float (fun (f : float) =>
                  Comp (RealT (FloatToR f)) (VarNowT v) Eq //\\
                       PropF (exists (r : R), eq (F2OR f) (Some r))).

Lemma sf_preVarIsFloat :
  forall (v : Var),
    is_st_formula (preVarIsFloat v).
Proof.
  intros.
  simpl.
  intuition.
Qed.

Lemma F2OR_FloatToR :
  forall (f : float) (r r' : R),
    F2OR f = Some r ->
    FloatToR f = r' ->
    r = r'.
Proof.
  intros.
  unfold F2OR, FloatToR in *.
  destruct f; try congruence.
Qed.

(* generalized version of Enabled_action, needed to prove
   enabledness goals *)
Lemma Enabled_action_gen
  : forall P Q : Syntax.Formula,
    (forall (st : state) (tr : trace),
        Semantics.eval_formula Q (Stream.Cons st tr) ->
        exists st' : state,
          Semantics.eval_formula P (Stream.Cons st (Stream.forever st'))) ->
    Q |-- Enabled P.
Proof.
  tlaIntuition.
  destruct tr.
  eapply H in H0.
  simpl.
  fwd.
  eauto.
Qed.

Fact fwp_simpler_full : preVarIsFloat "x" //\\ "x" > 0 //\\
                                [](oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog \\//
                                               (Enabled (oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog) -->> lfalse))
                                |-- [](preVarIsFloat "x" //\\ "x" > 0).
Proof.
  eapply discr_indX.
  { red. simpl. intuition. }
  { charge_assumption. }
  { tlaIntuition. }

  tlaRevert.

  eapply lorL.

  {

    admit. (* should be similar to last proof *)
    (*
    erewrite -> Hoare__embed_rw; [| solve [simpl; intuition] | solve [simpl; intuition; eauto]].
    eapply lforallL.
    (* rhs *)
    tlaRevert.
    simpl fwp.
    eapply lequiv_rewrite_left.

    {
      crunch_embeds.
    }
    *)
  }
  {
    (* enabledness tactic? *)
    charge_intro.
    transitivity lfalse; [| eapply lfalseL].
    charge_use.
    tlaRevert.
    eapply Lemmas.forget_prem.
    Require Import TLA.Tactics.
    charge_intro.
    eapply Enabled_action_gen.
    simpl.
    intros.
    clear tr.
    fwd.
    eapply (ex_state "x").
    eapply ex_state_any.
    simpl.
    intro st0; clear st0.
    generalize (F2OR_FloatToR _ _ _ H1 H); intro HF2OR.
    subst.

    (* finish this proof, should be semi straightforward *)
    Print Ltac enable_ex_st.

    eexists.
    exists (fstate_set nil "x" x).

    simpl.
    split.
    { split; auto. }
    { right.
      eexists.
      split.
      { econstructor. reflexivity. }
      { simpl. split; auto. } } }
Qed.

  Lemma limpl_limpl_land :
    forall (A B C : Syntax.Formula),
      |-- A //\\ B -->> C ->
      |-- A -->> B -->> C.
  Proof.
    tlaIntuition.
  Qed.

  idtac.

  eapply limpl_limpl_land.

  Print ILogic.

  Check fwp_simpler.
  Check Hoare__embed_rw.

  erewrite -> Hoare__embed_rw; [| solve [simpl; intuition] | solve [simpl; intuition; eauto]].
  charge_intros.
  eapply discr_indX.
  { red; intuition. }
  { charge_assumption. }
  { charge_assumption. }
  {
    (* rhs *)
    rewrite landforallDL. eapply lforallL.
    instantiate (1 := (fun fst => exists f, fstate_lookup fst "x" = Some f /\ exists r, F2OR f = Some r /\ (r > 0)%R)).
    tlaRevert.
    simpl fwp.
    eapply lequiv_rewrite_left.

    {
      crunch_embeds.
    }

    Lemma lentail_cut1 :
      forall (A B C : Formula),
        C |-- A ->
        A -->> B |-- C -->> B.
    Proof.
      intros. breakAbstraction. intuition.
    Qed.

    Lemma lentail_cut2 :
      forall (A B C D : Formula),
        C |-- A ->
        B |-- D ->
        (A -->> B |-- C -->> D).
    Proof.
      intros. tlaIntuition.
    Qed.

    apply lexistsL.

    intro.

    Lemma land_comm_left :
      forall (A B C : Formula),
        A //\\ B |-- C ->
        B //\\ A |-- C.
    Proof.
      tlaIntuition.
    Qed.

    idtac.

    apply land_comm_left.
    apply landAdj.

    Lemma limpl_comm1 :
      forall (A B C D : Formula),
        A |-- B -->> C -->> D ->
        A |-- C -->> B -->> D.
    Proof.
      tlaIntuition.
    Qed.

    idtac.

    apply limpl_comm1.
    apply lentail_cut2.

    Require Import Coq.micromega.Psatz.
    {
      breakAbstraction.
      intros.
      exists float_one.
      split; try reflexivity.
      left.
      split. admit. (* need computability of natToFloat *)
      intros.
      SearchAbout fstate_lookup.
      generalize fstate_lookup_update_match; intro Hflum.
      symmetry in Hflum.
      rewrite Hflum.
      exists x0.
      split; try reflexivity.
      exists x1.
      split; auto.
      admit. (* need computability of B2R *)
    }
    {
      breakAbstraction.
      intros.
      fwd.
      unfold fstate_lookupR in H.
      rewrite H2 in H.
      rewrite H3 in H.
      inversion H; subst; clear H.
      assumption.
    }
  }
Qed.

Fact simpler_enabledness : (oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog)
                             \\// Enabled (oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog -->> lfalse)
                             |-- "x" > 0 -->> next ("x" > 0).
Proof.
  Print ILogic.
  eapply lorL.
  { admit. (* use part of proof from last theorem *) }
  { breakAbstraction.
    intros.
    fwd.
    destruct H.
    eexists.
    split.
    - split; auto.

  erewrite -> Hoare__embed_rw.

  : |-- (oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog) \\// Enabled (oembed_fcmd simple_prog_ivs simple_prog_ivs simpler_prog -->> lfalse).
Proof.
  erewrite -> Hoare__embed_rw; [| solve [simpl; intuition] | solve [simpl; intuition; eauto]].
  charge_intros.
  eapply discr_indX.
  { red; intuition. }
  { charge_assumption. }
  { charge_assumption. }
  {
    (* rhs *)
    rewrite landforallDL. eapply lforallL.
    instantiate (1 := (fun fst => exists f, fstate_lookup fst "x" = Some f /\ exists r, F2OR f = Some r /\ (r > 0)%R)).
    tlaRevert.
    simpl fwp.
    eapply lequiv_rewrite_left.

    {
      crunch_embeds.
    }

rewrite H2 in H      }

      Print ILogic.

      idtac.

      eapply lentail_cut2.

      eapply lexistsL.
      (* apply lexistsL
         eliminate t0 ext because it equal t1
         need to prove exists... proves RHS of entailment
         but first we need to access it so we need to discharge its hypothesis
       *)

      (*
       Exists x, PropF (Some a = Some x) //\\ P x -|- P a

       and also

       Forall x, PropF (Some a = Some x) -->> P x -|- P a

       (may need to reorder (Some a = Some x), or prove alternate version w/ reordering)
       *)

      (* "push" the first embed to RHS of entailment:
         Embed (fun x _ : state => vmodels simple_prog_ivs x t) //\\

         ... |-- Embed (fun x _ : state => vmodels simple_prog_ivs x t) //\\ "x" > 0 -->> next ...
       *)

      (* need this lemma
        C |-- A
        B |-- D
        --------------
        A -->> B |-- C -->> D
       *)

      (* talk to Greg about Coq architecture *)

      Print ILogic.
      (* fstate_lookup of fstate set lemma is needed *)
      (* need to show x and x-next are floating point numbers *)

      shatterAbstraction.
      intros.
      split.
    - intros.
      fwd.
      inversion H1; subst; clear H1.
      destruct H2; try contradiction.
      fwd.
      eexists. split.
      + split; auto.

      idtac.
      apply lentail_cut1.
      Print bound.isVarValid.

      simpl next.

        idtac.
        eapply arith_push_fupdate.
        eauto with arith_push.

        Print evals_to.

        Print Syntax.Term.
        unfold fupdate.
        simpl.
        Print eval_term.
        eauto with arith_push.

        Print fupdate.

        repeat (first [ eapply embed_push_And (*; eauto with arith_push*) |
                        eapply embed_push_Or  (*; eauto with arith_push*) |
                        eapply embed_push_Imp (*; eauto with arith_push*) |
                        eapply embed_push_Exists; intro (*; eauto with arith_push*) |
                        eapply embed_push_Forall; intro (*; eauto with arith_push*) |
                        eapply embed_push_Const (*; eauto with arith_push*) |
                        eapply embed_push_Eq; eauto with arith_push |
                        eapply embed_push_Lt; eauto with arith_push |
                        eapply embed_push_Le; eauto with arith_push |
                        eapply embed_push_Gt; eauto with arith_push |
                        eapply embed_push_Ge; eauto with arith_push
               ]).
        simple eapply embed_push_Imp.
        eapply embed_push_And.

        idtac.
        Check embed_push_Forall.
        match goal with

        eauto with arith_push.

        Focus 7. eapply lforall_lequiv_m.
      2: eauto with arith_push.
      2: eauto with arith_push.
      setoid_rewrite embed_push_Le.

      rewrite_strat (subterm (terms (embed_push_Le))).
      rewrite_strat (topdown (repeat (old_hints embed_push))).

      rewrite_strat (topdown (repeat (terms embed_push_Imp embed_push_And embed_push_Or))).

      autorewrite with embed_push.
      rewrite
      rewrite_strat (bottomup (repeat (terms embed_push_Imp embed_push_And embed_push_Or))).
      setoid_rewrite embed_push_Imp.

      rewrite_strat bottomup embed_push_Imp.
      rewrite_strat bottomup (repeat (hints embed_push)).

      apply H.

    breakAbstraction.

  simpl. intuition. eexists. left. reflexivity.

  specialize (fwp_correct simple_prog_ivs ivs

(* sample abstractor outputs *)
Section fwp.
  Parameter st : state.
  Parameter postcond : state -> Prop.

  (* discrete invariant: controller never changes x *)
  (*Fact fwp_propcontrol : forall (P : (fwp proportional_controller postcond proportional_controller_ivs st)), False.*)
  Fact fwp_propcontrol : (fwp proportional_controller postcond proportional_controller_ivs st).
  Proof.
    intros.
    cbv beta iota delta [fwp proportional_controller].
    simpl.
    Print bound.isVarValid.

    unfold Semantics.eval_comp.
    simpl.

    (* TODO may need to bolt on continuation support *)
    Unset Ltac Debug.
    Ltac abstractor_cleanup P :=
      let rec cleanup P :=
          match P with
          | AnyOf ?P1 :: nil => apply AnyOf_singleton in P; abstractor_cleanup P
          | AnyOf ?PS => cleanup_list PS
          | ?P1 \/ ?P2 => abstractor_cleanup P1; abstractor_cleanup P2
          | True /\ ?P1 => apply and_True_snip1 in P; abstractor_cleanup P
          | _ => idtac
    end
    with cleanup_list ls :=
      match ls with
      | ?P :: ?PS => cleanup P; cleanup_list PS
      | nil => idtac
      end
      in
        let t := type of P in
        cleanup t.

    (* use entailment |-- and -|-
       also want to convert (state -> Prop) to Formula by distributing embed.
       test on "just increment x" controller, where safety is x > 0
       prove bi entailment of result formula *)

    Ltac abstractor_cleanup_goal :=
      match goal with
      | |- ?P => abstractor_cleanup P
      end.

    match goal with
    | |- _ \/ _ => idtac
    end.

    abstractor_cleanup_goal.

    Unset Ltac Debug.

              Lemma silly_AnyOf :
                AnyOf (True :: nil) -> False.
              Proof.
                intro.
                apply AnyOf_singleton in H.
                Focus 2.
                Check AnyOf_singleton.
                rewrite AnyOf_singleton; reflexivity.
                apply AnyOf_singleton.
                abstractor_cleanup H.

              abstractor_cleanup P.

              repeat (
        match P with
        |
        end
        ).
  Abort.

Fact fwp_velshim : False.
  pose (fun P => fwp velshim P velshim_ivs).
Opaque AnyOf.
cbv beta iota delta [ fwp velshim ] in P.
unfold Semantics.eval_comp in P.
simpl in P.
unfold maybe_ge0, maybe_lt0 in P.
simpl eval_term in P.
simpl bound_fexpr in P.

Abort.

(* ltac automation *)
Ltac abstractor_cleanup P :=

(*
Fact fwp_test :
  forall (st : Syntax.state),
    (st "x" = 1%R)%type ->
    (fwp simple_prog (fun (ss : Syntax.state) => (ss "x" > 0)%R)%type)
      st.
Proof.
  intros.
  simpl. destruct (bounds_to_formula
           {|
           lb := RealT
                   (Fappli_IEEE.B2R custom_prec custom_emax (nat_to_float 1));
           ub := RealT
                   (Fappli_IEEE.B2R custom_prec custom_emax (nat_to_float 1));
           premise := TRUE |} st) eqn:Hb2f.
  left.
  split.

  - apply P.
  red.
  compute.

Opaque nat_to_float.

Check fwp.

Fact fwp_test :
  forall (st : Syntax.state),
  (fwp simple_prog (fun (ss : Syntax.state) => (ss "x" > 0)%R)%type)
    st.
Proof.
  intros.
  compute.

  Print nat_to_float.
  Print Fappli_IEEE_extra.BofZ.
  Print Fappli_IEEE.binary_normalize.
  Check Fappli_IEEE.FF2B.
  About Fappli_IEEE.binary_round_correct.
  Eval vm_compute in (nat_to_float 0).

  Print custom_prec.

  simpl. left.
  generalize (bound_fexpr_sound). intro.
  SearchAbout bounds_to_formula.

Abort.


Require Import Tac.
Require Import Arith Structures.Orders Structures.OrdersFacts.

Create HintDb env discriminated.

Inductive Var :=
| mkVar : nat -> Var
.
Hint Constructors Var : env.

Lemma eq_Var_dec : forall (X Y : Var), {X = Y} + {X <> Y}.
Proof. decide equality. apply eq_nat_dec. Defined.
Hint Immediate eq_Var_dec : env.

Module VarEq <: DecidableType.
  Definition t := Var.
  Definition eq (x y : Var) := eq x y.
  Instance eq_equiv : Equivalence eq := eq_equivalence.
  Definition eq_dec := eq_Var_dec.
End VarEq.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Rsqr.
Require Import XR_Rsqr_neg.
Require Import XR_Rsqr_incr_0_var.
Require Import XR_Ropp_0.
Require Import XR_Ropp_le_contravar.

Local Open Scope R_scope.

Lemma Rsqr_le_abs_0 : forall x y:R, Rsqr x <= Rsqr y -> Rabs x <= Rabs y.
Proof.
  intros x y h.
  unfold Rabs.
  destruct (Rcase_abs x) as [ hx | hx ] ;
  destruct (Rcase_abs y) as [ hy | hy ].
  {
    apply Rsqr_incr_0_var.
    {
      rewrite <- Rsqr_neg.
      rewrite <- Rsqr_neg.
      exact h.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      left.
      exact hy.
    }
  }
  {
    apply Rsqr_incr_0_var.
    {
      rewrite <- Rsqr_neg.
      exact h.
    }
    { exact hy. }
  }
  {
  apply Rsqr_incr_0_var.
  {
    rewrite <- Rsqr_neg.
    exact h.
  }
  {
    rewrite <- Ropp_0.
    apply Ropp_le_contravar.
    left.
    exact hy.
  }
  }
  {
    apply Rsqr_incr_0_var.
    { exact h. }
    { exact hy. }
  }
Qed.


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

- Frederic Blanqui, 2009-03-25 (setoid)
- Adam Koprowski and Johannes Waldmann, 2008-01
*)

Set Implicit Arguments.

From CoLoR Require Import Matrix AMonAlg VecUtil OrdSemiRing ATrs LogicUtil
     RelUtil NatUtil AWFMInterpretation.
From Coq Require Import Max Setoid Morphisms.
From CoLoR Require ABterm ATrs.

Section MatrixLinearFunction.

  Variables (A : Type) (matrix : nat -> nat -> Type) (dim argCnt : nat).

  (* function interpretation : one [dim]x[dim] matrix per argument and
     one vector of dimension [dim] for a constant factor *)
  Record matrixInt : Type := mkMatrixInt {
    const : vector A dim;
    args : vector (matrix dim dim) argCnt }.

End MatrixLinearFunction.

Arguments mkMatrixInt [A matrix dim argCnt] _ _.

Module Type MatrixMethodConf.

  Declare Module Export OSRT : OrdSemiRingType.
  Module Export M := Matrix OSRT.

  Parameter sig : Signature.
  Parameter dim : nat.
  Parameter dim_pos : dim > 0.

  Notation vec := (vec dim).
  Notation eq_vec := (Vforall2 eqA (n:=dim)).
  Notation "x =v y" := (eq_vec x y).
  Notation mat_eqA := (@mat_eqA dim dim).
  Notation mat_eqA_st := (@mat_eqA_equiv dim dim).
  Notation matrixInt := (matrixInt A matrix).
  Notation mint := (matrixInt dim).
  Notation mat := (matrix dim dim).
  Notation eq_vec_st := (Vforall2_equiv eqA_Equivalence dim).
  Notation eq_vec_mat_eqA_st := (Vforall2_equiv mat_eqA_st).

  Parameter trsInt : forall f : sig, mint (arity f).
  Parameter vec_invariant : vec -> Prop.
  Parameter inv_id_matrix :
    vec_invariant (Vreplace (Vconst A0 dim) dim_pos A1).

End MatrixMethodConf.

Module MatrixBasedInt (Export MC : MatrixMethodConf).

  (*REMOVE?*)
  Global Instance eq_vec_eq_vec_rel k : Equivalence (Vforall2 eq_vec (n:=k)).

  Proof. class. Qed.

  Global Instance eq_vec_mat_eqA_rel k : Equivalence (Vforall2 mat_eqA (n:=k)).

  Proof. class. Qed.

  Definition eq_mint k (mi1 mi2 : mint k) :=
    let (c1, args1) := mi1 in
    let (c2, args2) := mi2 in
      c1 =v c2 /\ Vforall2 mat_eqA args1 args2.

  Notation "x =i y" := (eq_mint x y) (at level 70).

  Global Instance eq_mint_refl k : Reflexive (@eq_mint k).

  Proof. unfold eq_mint, Reflexive. destruct x. intuition. Qed.

  Global Instance eq_mint_sym k : Symmetric (@eq_mint k).

  Proof. unfold eq_mint, Symmetric. destruct x. destruct y. intuition. Qed.

  Global Instance eq_mint_trans k : Transitive (@eq_mint k).

  Proof.
    unfold eq_mint, Transitive. destruct x. destruct y. destruct z. intuition.
    trans const1; hyp. trans args1; hyp.
  Qed.

  (*REMOVE?*)
  Global Instance eq_mint_equiv k : Equivalence (@eq_mint k).

  Proof. constructor; class. Qed.

  Global Instance mkMatrix_mor k : Proper (eq_vec ==> Vforall2 mat_eqA ==> @eq_mint k)
    (@mkMatrixInt A matrix dim k).

  Proof. fo. Qed.

  Global Instance const_mor k : Proper (@eq_mint k ==> eq_vec) (@const A matrix dim k).

  Proof. intro x. destruct x. destruct y. simpl. intuition. Qed.

  Global Instance args_mor k :
    Proper (@eq_mint k ==> Vforall2 mat_eqA) (@args A matrix dim k).

  Proof. intro x. destruct x. destruct y. simpl. intuition. Qed.

  Section MBI.

    Definition vec_at0 (v : vec) := Vnth v dim_pos.

    Definition dom := { v : vec | vec_invariant v }.

    Definition dom2vec (d : dom) : vec := proj1_sig d.

    Definition add_matrices i m n (v : vector (matrix m n) i) :=
      Vfold_left_rev (@mat_plus m n) (zero_matrix m n) v.

    Notation mat_vec_prod := (@mat_vec_prod dim dim).

    Definition mi_eval_aux n (mi : mint n) (v : vector vec n) : vec :=
      add_vectors (Vmap2 mat_vec_prod (args mi) v) [+] const mi.

    Global Instance mi_eval_aux_mor n :
      Proper (@eq_mint n ==> Vforall2 eq_vec ==> eq_vec) (@mi_eval_aux n).

    Proof.
      intros I I' II' v v' vv'. unfold mi_eval_aux. apply vector_plus_mor.
      apply add_vectors_mor. apply Vforall2_intro_nth. intros.
      rewrite !Vnth_map2.
      apply mat_vec_prod_mor. apply Vforall2_elim_nth. rewrite II'. refl.
      apply Vforall2_elim_nth. hyp. rewrite II'. refl.
    Qed.

    Variable mi_eval_ok : forall f v,
      vec_invariant (mi_eval_aux (trsInt f) (Vmap dom2vec v)).

    Definition mi_eval f (v : vector dom (arity f)) : dom :=
      exist (mi_eval_ok f v).

    Lemma mi_eval_cons : forall n (mi : mint (S n)) v vs,
      mi_eval_aux mi (Vcons v vs) =v
        mat_vec_prod (Vhead (args mi)) v [+]
        mi_eval_aux (mkMatrixInt (const mi) (Vtail (args mi))) vs.

    Proof.
      intros. unfold mi_eval_aux. simpl. rewrite vector_plus_assoc.
      apply vector_plus_mor. apply vector_plus_comm. refl.
    Qed.

    Definition dom_zero : dom.

    Proof.
      exists (Vreplace (Vconst A0 dim) dim_pos A1). apply inv_id_matrix.
    Defined.

    Definition I := @mkInterpretation sig dom dom_zero mi_eval.

    Definition succeq := Rof (Vforall2 ge) dom2vec.

    Instance refl_succeq : Reflexive succeq.

    Proof. intro x. unfold succeq, Rof. refl. Qed.

    Instance trans_succeq : Transitive succeq.

    Proof. apply Rof_trans. class. Qed.

    (** Monotonicity *)

    Section VecMonotonicity.

      Variables (f : matrix dim dim -> vec -> vec)
                (f_mon : forall M v1 v2, v1 >=v v2 -> f M v1 >=v f M v2)
                (a b : vec).

      Lemma vec_add_weak_monotone_map2 : forall n1 (v1 : vector vec n1) n2
        (v2 : vector vec n2) n (M : vector (matrix dim dim) n) i_j, a >=v b ->
        add_vectors (Vmap2 f M (Vcast (Vapp v1 (Vcons a v2)) i_j)) >=v
        add_vectors (Vmap2 f M (Vcast (Vapp v1 (Vcons b v2)) i_j)).

      Proof.
        induction v1; intros; simpl.
        destruct n; try solve [lia].
        rewrite !Vcast_cons. simpl.
        unfold add_vectors, succeq. simpl. apply Vforall2_intro_nth.
        intros. unfold vector_plus. rewrite !Vnth_map2.
        assert (Vnth (f (Vhead M) a) ip >>= Vnth (f (Vhead M) b) ip).
        apply Vforall2_elim_nth. apply f_mon. hyp.
        apply plus_ge_compat. apply ge_refl. hyp.

        destruct n0; try solve [lia].
        rewrite !Vcast_cons. simpl.
        unfold add_vectors, succeq. simpl. apply Vforall2_intro_nth.
        intros. unfold vector_plus. rewrite !Vnth_map2.
        apply plus_ge_compat.
        apply Vforall2_elim_nth. unfold add_vectors in IHv1. apply IHv1.
        hyp. apply ge_refl.
      Qed.

    End VecMonotonicity.

    Lemma monotone_succeq : monotone I succeq.

    Proof.
      intros f i j i_j vi vj a b ab.
      simpl. unfold mi_eval, mi_eval_aux, succeq. simpl.
      apply (@vec_plus_ge_compat_r dim).
      rewrite !Vmap_cast, !Vmap_app. simpl.
      apply vec_add_weak_monotone_map2; trivial.
      intros. unfold succeq. apply Vforall2_intro_nth. intros.
      unfold M.mat_vec_prod. rewrite !Vnth_col_mat. apply mat_mult_mon.
      apply mat_ge_refl. intros x y xp yp.
      rewrite !vec_to_col_mat_spec.
      apply Vforall2_elim_nth. hyp.
    Qed.

    Lemma succeq_dec : rel_dec succeq.

    Proof.
      intros x y. unfold succeq. apply Vforall2_dec. intros m n. apply ge_dec.
    Defined.

    (** decidability of order on terms induced by matrix interpretations *)

    Section OrderDecidability.

      Import ABterm.

      Notation bterm := (bterm sig).

      (** symbolic computation of term interpretation *)

      Definition mat_matrixInt_prod n M (mi : mint n) : mint n :=
        mkMatrixInt (mat_vec_prod M (const mi)) (Vmap (mat_mult M) (args mi)).

      Definition combine_matrices n k (v : vector (vector mat k) n) :=
        Vbuild (fun i ip => add_matrices (Vmap (fun v => Vnth v ip) v)).

      Lemma combine_matrices_nil : forall i,
        combine_matrices Vnil = Vconst (@zero_matrix dim dim) i.

      Proof.
        intros. apply Veq_nth. intros. unfold combine_matrices.
        rewrite Vnth_const, Vbuild_nth. trivial.
      Qed.

      Lemma combine_matrices_cons :
        forall k n v (vs : vector (vector mat k) n),
          combine_matrices (Vcons v vs) =
          Vmap2 (@mat_plus _ _) (combine_matrices vs) v.

      Proof.
        intros. apply Veq_nth. intros.
        unfold combine_matrices, add_matrices. simpl.
        rewrite Vnth_map2, !Vbuild_nth. refl.
      Qed.

      Fixpoint mi_of_term k (t : bterm k) : mint (S k) :=
        match t with
          | BVar ip =>
            let zero_int := Vconst (zero_matrix dim dim) (S k) in
            let args_int := Vreplace zero_int (le_lt_S ip) (id_matrix dim) in
            mkMatrixInt (@zero_vec dim) args_int
          | BFun f v =>
            let f_int := trsInt f in
            let args_int := Vmap (@mi_of_term k) v in
            let args_int' := Vmap2 (@mat_matrixInt_prod (S k))
                                   (args f_int) args_int in
            let res_const := add_vectors (Vcons (const f_int)
              (Vmap (@const A matrix dim (S k)) args_int')) in
            let res_args := combine_matrices (Vmap (@args A matrix dim (S k))
              args_int') in
            mkMatrixInt res_const res_args
        end.

      Import ATrs.

      Definition rule_mi r :=
        let mvl := maxvar (lhs r) in
        let mvr := maxvar (rhs r) in
        let m := max mvl mvr in
        let lt := inject_term (le_max_l mvl mvr) in
        let rt := inject_term (le_max_r mvl mvr) in
          (mi_of_term lt, mi_of_term rt).

      (** order characteristic for symbolically computed interpretation and
       its decidability *)

      Notation mat_ge := (@mat_ge dim dim).
      Notation vec_ge := (@Vforall2 ge dim).

      Definition mint_ge n (l r : mint n) :=
        Vforall2 mat_ge (args l) (args r) /\ Vforall2 ge (AMatrixBasedInt.const l) (AMatrixBasedInt.const r).

      Definition term_ord (ord : forall n, relation (mint n)) l r :=
        let (li, ri) := rule_mi (mkRule l r) in ord _ li ri.

      Variable mint_gt : forall n (l r : mint n), Prop.
      Variable mint_gt_dec : forall n, rel_dec (@mint_gt n).

      Definition term_ge := term_ord mint_ge.
      Definition term_gt := term_ord mint_gt.

      Lemma mint_ge_dec : forall n, rel_dec (@mint_ge n).

      Proof.
        intros n x y. unfold mint_ge.
        destruct (Vforall2_dec (@mat_ge_dec dim dim) (args x) (args y));
          destruct (Vforall2_dec ge_dec (AMatrixBasedInt.const x) (AMatrixBasedInt.const y));
          split_all; right; tauto.
      Defined.

      Lemma term_ge_dec : rel_dec term_ge.

      Proof.
        intros l r. unfold term_ge, term_ord. simpl.
        match goal with |- {mint_ge ?l ?r} + {~mint_ge ?l ?r} =>
                        destruct (mint_ge_dec l r); auto
        end.
      Defined.

      Lemma term_gt_dec : rel_dec term_gt.

      Proof.
        intros l r. unfold term_gt, term_ord. simpl.
        match goal with |- {mint_gt ?l ?r} + {~mint_gt ?l ?r} =>
                        destruct (mint_gt_dec l r); auto
        end.
      Defined.

      Notation IR_succeq := (IR I succeq).

      Definition mint_eval (val : valuation I) k (mi : mint k) : vec :=
        let coefs := Vbuild (fun i (ip : i < k) => dom2vec (val i)) in
        add_vectors (Vcons (AMatrixBasedInt.const mi) (Vmap2 mat_vec_prod (args mi) coefs)).

      Global Instance mint_eval_mor k val :
        Proper (@eq_mint k ==> eq_vec) (@mint_eval val k).

      Proof.
        intros [c1 args1] [c2 args2]. unfold eq_mint. split_all.
        unfold mint_eval. simpl. apply add_vectors_mor.
        rewrite Vforall2_cons_eq. split_all.
        apply Vmap2_proper with (R := mat_eqA) (S := eq_vec).
        apply mat_vec_prod_mor. hyp. refl.
      Qed.

      Lemma mint_eval_split : forall val k (mi : mint k),
        let coefs := Vbuild (fun i (ip : i < k) => dom2vec (val i)) in
          mint_eval val mi =v AMatrixBasedInt.const mi [+]
          add_vectors (Vmap2 mat_vec_prod (args mi) coefs).

      Proof.
        intros. unfold mint_eval, add_vectors. simpl.
        rewrite vector_plus_comm. refl.
      Qed.

      Lemma mint_eval_var_aux : forall M i k (v : vector vec k) (ip : i < k),
        add_vectors (Vmap2 mat_vec_prod (Vreplace (Vconst
          (zero_matrix dim dim) k) ip M) v) =v
          col_mat_to_vec (M <*> (vec_to_col_mat (Vnth v ip))).

      Proof.
        induction i; intros.
        destruct k. lia.
        unfold add_vectors. simpl.
        fold (add_vectors (Vmap2 mat_vec_prod
                                 (Vconst (zero_matrix dim dim) k) (Vtail v))).
        assert (add_vectors
          (Vmap2 mat_vec_prod (Vconst (zero_matrix dim dim) k) (Vtail v))
          =v @zero_vec dim). 2:{ rewrite H, vector_plus_zero_l.
        replace (Vhead v) with (Vnth v ip). refl.
        rewrite Vhead_nth, (lt_unique (lt_O_Sn k) ip). refl. }
        apply add_vectors_zero. apply Vforall_nth_intro. intros.
        rewrite Vnth_map2, Vnth_const.
        unfold M.mat_vec_prod. rewrite zero_matrix_mult_l.
        apply Vforall2_intro_nth. intros. rewrite Vnth_col_mat.
        unfold zero_matrix, zero_vec.
        rewrite mat_build_elem, Vnth_const. refl.
        destruct k. lia.
        rewrite Vreplace_tail. simpl. rewrite add_vectors_cons.
        unfold M.mat_vec_prod at 1. rewrite zero_matrix_mult_l.
        assert (col_mat_to_vec (zero_matrix dim 1) =v zero_vec dim).
        apply Vforall2_intro_nth. intros. rewrite Vnth_col_mat.
        unfold zero_matrix, zero_vec.
        rewrite mat_build_elem, Vnth_const. refl.
        rewrite H, vector_plus_zero_l, IHi, Vnth_tail,
          (le_unique (lt_n_S (lt_S_n ip)) ip). refl.
      Qed.

      Lemma mint_eval_eq_term_int_var : forall v (val : valuation I) k
                                               (t_b : maxvar_le k (Var v)),
        dom2vec (bterm_int val (inject_term t_b)) =v
        mint_eval val (mi_of_term (inject_term t_b)).

      Proof.
        intros. rewrite mint_eval_split.
        change (const (mi_of_term (inject_term t_b))) with (zero_vec dim).
        rewrite vector_plus_zero_l.
        change (args (mi_of_term (inject_term t_b)))
          with (Vreplace (Vconst (zero_matrix dim dim) (S k))
                         (le_lt_S (maxvar_var t_b)) (id_matrix dim)).
        rewrite mint_eval_var_aux, Vbuild_nth. simpl.
        trans (col_mat_to_vec (vec_to_col_mat (dom2vec (val v)))).
        rewrite col_mat_to_vec_idem. refl. apply get_col_mor.
        rewrite mat_mult_id_l. refl. ded dim_pos. auto.
      Qed.

      Lemma mint_eval_const : forall val k (c : vec),
        mint_eval (k:=k) val (mkMatrixInt c (combine_matrices Vnil)) =v c.

      Proof.
        intros. unfold mint_eval. simpl. (*SLOW*)autorewrite with arith.
        trans (c [+] @zero_vec dim). apply vector_plus_mor. refl.
        apply add_vectors_zero. apply Vforall_nth_intro. intros.
        rewrite Vnth_map2, combine_matrices_nil, Vnth_const.
        unfold M.mat_vec_prod. apply Vforall2_intro_nth. intros.
        rewrite Vnth_col_mat.
        trans (get_elem (zero_matrix dim 1) ip0 access_0).
        apply get_elem_mor. apply zero_matrix_mult_l.
        unfold zero_matrix. rewrite mat_build_elem.
        unfold zero_vec. rewrite Vnth_const. refl.
        apply vector_plus_zero_r.
      Qed.

      Lemma mint_eval_cons : forall n k val c_hd c_tl a_hd
                                    (a_tl : vector (vector mat k) n),
        mint_eval val (mkMatrixInt (c_hd [+] c_tl)
          (combine_matrices (Vcons a_hd a_tl))) =v
        mint_eval val (mkMatrixInt c_hd a_hd) [+]
        mint_eval val (mkMatrixInt c_tl (combine_matrices a_tl)).

      Proof.
        intros. unfold mint_eval. simpl.
        set (vali := Vbuild (A := vec) (fun i (_ : i < k) => dom2vec (val i))).
        rewrite combine_matrices_cons.
        (*SLOW*)autorewrite with arith. rewrite <- !vector_plus_assoc.
        apply vector_plus_mor. refl.
        rewrite vector_plus_assoc, (vector_plus_comm _ c_tl),
          <- vector_plus_assoc.
        apply vector_plus_mor. refl. apply add_vectors_split. intros.
        rewrite !Vnth_map2, vector_plus_comm. apply mat_vec_prod_distr_mat.
      Qed.

      Lemma mint_eval_mult_factor : forall k val M (mi : mint k),
        mint_eval val (mat_matrixInt_prod M mi) =v
        mat_vec_prod M (mint_eval val mi).

      Proof.
        unfold mint_eval. intros. simpl. (*SLOW*)autorewrite with arith.
        rewrite mat_vec_prod_distr_vec. apply vector_plus_mor. refl.
        set (gen := Vbuild (A:=vec) (fun i (_ : i < k) => dom2vec (val i))).
        rewrite (mat_vec_prod_distr_add_vectors M
          (Vmap2 mat_vec_prod (args mi) gen)
          (Vmap2 mat_vec_prod (Vmap (mat_mult M) (args mi)) gen)).
        refl. intros. rewrite !Vnth_map2, Vnth_map.
        unfold M.mat_vec_prod. rewrite vec_to_col_mat_idem.
        apply get_col_mor. rewrite mat_mult_assoc. refl.
      Qed.

      Lemma mint_eval_eq_bterm_int_fapp : forall k i fi val
                                                 (v : vector (bterm k) i),
        let arg_eval := Vmap2 (@mat_matrixInt_prod (S k)) (args fi)
          (Vmap (@mi_of_term k) v) in
          mi_eval_aux fi (Vmap
            (fun t : bterm k => mint_eval val (mi_of_term t)) v) =v
          mint_eval val (mkMatrixInt
            (add_vectors (Vcons (AMatrixBasedInt.const fi) (Vmap
              (@AMatrixBasedInt.const A matrix dim (S k)) arg_eval)))
            (combine_matrices (Vmap (@args A matrix dim (S k)) arg_eval))).

      Proof.
        induction i; intros.
        (* i = 0 *)
        VOtac. simpl.
        unfold mi_eval_aux, add_vectors. simpl. (*SLOW*)autorewrite with arith.
        sym. apply mint_eval_const.
        (* i > 0 *)
        VSntac v. simpl mi_eval_aux.
        rewrite mi_eval_cons, IHi. simpl.
        (*COQ: morphisms do work here ? *)
        trans (@mint_eval val (S k)
          (@mkMatrixInt A matrix dim (S k)
            (@M.mat_vec_prod dim dim
                       (@Vhead (matrix dim dim) i
                          (@args A matrix dim (S i) fi))
                       (@AMatrixBasedInt.const A matrix dim (S k)
                          (@Vhead (mint (S k)) i
                             (@Vmap (ABterm.bterm sig k)
                                (mint (S k))
                                (@mi_of_term k) (S i) v)))
                 [+] @add_vectors dim (S i) (@Vcons (vector A dim)
                     (@AMatrixBasedInt.const A matrix dim (S i) fi) i
                    (@Vmap (mint (S k))
                       (vector A dim) (@AMatrixBasedInt.const A matrix dim (S k)) i
                       (@Vmap2 (matrix dim dim)
                          (mint (S k))
                          (mint (S k))
                          (@mat_matrixInt_prod (S k)) i
                          (@Vtail (matrix dim dim) i
                             (@args A matrix dim (S i) fi))
                          (@Vtail (mint (S k)) i
                             (@Vmap (ABterm.bterm sig k)
                                (mint (S k))
                                (@mi_of_term k) (S i) v))))))
           (@combine_matrices (S i) (S k)
              (@Vcons (vector (matrix dim dim) (S k))
                 (@Vmap (matrix dim dim) (matrix dim dim)
                    (@mat_mult dim dim dim
                       (@Vhead (matrix dim dim) i
                          (@args A matrix dim (S i) fi)))
                    (S k)
                    (@args A matrix dim (S k)
                       (@Vhead (mint (S k)) i
                          (@Vmap (ABterm.bterm sig k)
                             (mint (S k))
                             (@mi_of_term k) (S i) v)))) i
                 (@Vmap (mint (S k))
                    (vector (matrix dim dim) (S k))
                    (@args A matrix dim (S k)) i
                    (@Vmap2 (matrix dim dim)
                       (mint (S k))
                       (mint (S k))
                       (@mat_matrixInt_prod (S k)) i
                       (@Vtail (matrix dim dim) i
                          (@args A matrix dim (S i) fi))
                       (@Vtail (mint (S k)) i
                          (@Vmap (ABterm.bterm sig k)
                             (mint (S k))
                             (@mi_of_term k) (S i) v)))))))).
        2:{ apply mint_eval_mor. split. rewrite add_vectors_perm,
          (add_vectors_cons (i := S i) (mat_vec_prod (Vhead (args fi))
            (AMatrixBasedInt.const (Vhead (Vmap (mi_of_term (k:=k)) v))))). refl.
        refl. }
        rewrite mint_eval_cons. apply vector_plus_mor.
        2:{ rewrite Vmap_tail. refl. }
        rewrite H. simpl.
        fold (mat_matrixInt_prod (Vhead (args fi)) (mi_of_term (Vhead v))).
        sym. apply mint_eval_mult_factor.
      Qed.

      Lemma mint_eval_eq_bterm_int : forall (val : valuation I) t k
                                            (t_b : maxvar_le k t),
        dom2vec (bterm_int val (inject_term t_b))
        =v mint_eval val (mi_of_term (inject_term t_b)).

      Proof.
        intros val t. pattern t. apply term_ind_forall; intros.
        apply mint_eval_eq_term_int_var.
        rewrite inject_term_eq. simpl.
        rewrite Vmap_map, (@Vforall2_map_intro _ _ eq_vec
          (fun x => dom2vec (bterm_int val x))
          (fun (t : bterm k) => mint_eval val (mi_of_term t))).
        apply mint_eval_eq_bterm_int_fapp.
        apply Vforall_nth_intro. intros.
        rewrite inject_terms_nth. apply (Vforall_nth ip H).
      Qed.

      Lemma mint_eval_eq_term_int t (val: valuation I) k (t_b: maxvar_le k t) :
        dom2vec (term_int val t)
        =v mint_eval val (mi_of_term (inject_term t_b)).

      Proof.
        intros. rewrite <- (term_int_eq_bterm_int val t_b).
        apply mint_eval_eq_bterm_int.
      Qed.

      Lemma mint_eval_equiv : forall l r (val : valuation I),
        let (li, ri) := rule_mi (mkRule l r) in
        let lev := term_int val l in
        let rev := term_int val r in
        let lv := mint_eval val li in
        let rv := mint_eval val ri in
          lv =v dom2vec lev /\ rv =v dom2vec rev.

      Proof.
        intros. simpl. split.
        rewrite (mint_eval_eq_term_int val (le_max_l (maxvar l) (maxvar r))).
        refl.
        rewrite (mint_eval_eq_term_int val (le_max_r (maxvar l) (maxvar r))).
        refl.
      Qed.

      Lemma mint_eval_mon_succeq_args : forall k (val : vector vec k)
        (mi mi' : mint k), mint_ge mi mi' ->
        add_vectors (Vmap2 mat_vec_prod (args mi) val)
        >=v add_vectors (Vmap2 mat_vec_prod (args mi') val).

      Proof.
        destruct mi. gen val. clear val. induction args0. intros.
        destruct mi'. VOtac.
        unfold mint_eval, add_vectors. simpl. refl.
        intros. destruct mi' as [const1 args1]. VSntac args1.
        unfold mint_eval, add_vectors. simpl.
        destruct H. apply (@vec_plus_ge_compat dim).
        apply (IHargs0 (Vtail val) (mkMatrixInt const1 (Vtail (args1)))).
        split. simpl. change args0 with (Vtail (Vcons h args0)).
        apply Vforall2_tail. hyp. hyp.
        apply mat_vec_prod_ge_compat.
        change h with (Vhead (Vcons h args0)). rewrite !Vhead_nth.
        apply Vforall2_elim_nth. hyp. refl.
      Qed.

      Lemma mint_eval_mon_succeq (val : valuation I) k (mi mi' : mint k) :
        mint_ge mi mi' -> mint_eval val mi >=v mint_eval val mi'.

      Proof.
        intros. unfold mint_eval, add_vectors. simpl.
        apply (@vec_plus_ge_compat dim).
        exact (mint_eval_mon_succeq_args _ H).
        destruct H. hyp.
      Qed.

      Lemma term_ge_incl_succeq : term_ge << IR_succeq.

      Proof.
        intros l r lr v. destruct (mint_eval_equiv l r v). simpl in * .
        unfold succeq, Rof. rewrite <- (vec_ge_mor H H0).
        apply mint_eval_mon_succeq. hyp.
      Qed.

      Definition succeq' := term_ge.
      Definition succeq'_sub := term_ge_incl_succeq.
      Definition succeq'_dec := term_ge_dec.

    End OrderDecidability.

  End MBI.

End MatrixBasedInt.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelNC.
Require Export lemma__parallelflip.
Require Export logic.
Definition lemma__collinearparallel2 : forall A B C D E F, (euclidean__defs.Par A B C D) -> ((euclidean__axioms.Col C D E) -> ((euclidean__axioms.Col C D F) -> ((euclidean__axioms.neq E F) -> (euclidean__defs.Par A B E F)))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro H.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (euclidean__axioms.neq F E) as H3.
- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric E F H2).
- assert (* Cut *) (euclidean__axioms.nCol A C D) as H4.
-- assert (* Cut *) ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol A C D) /\ ((euclidean__axioms.nCol B C D) /\ (euclidean__axioms.nCol A B D)))) as H4.
--- apply (@lemma__parallelNC.lemma__parallelNC A B C D H).
--- destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
exact H7.
-- assert (* Cut *) (euclidean__axioms.neq C D) as H5.
--- assert (* Cut *) ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq C A) /\ ((euclidean__axioms.neq D C) /\ (euclidean__axioms.neq D A)))))) as H5.
---- apply (@lemma__NCdistinct.lemma__NCdistinct A C D H4).
---- destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H8.
--- assert (* Cut *) (euclidean__axioms.neq D C) as H6.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C D H5).
---- assert (* Cut *) (euclidean__axioms.Col D C E) as H7.
----- assert (* Cut *) ((euclidean__axioms.Col D C E) /\ ((euclidean__axioms.Col D E C) /\ ((euclidean__axioms.Col E C D) /\ ((euclidean__axioms.Col C E D) /\ (euclidean__axioms.Col E D C))))) as H7.
------ apply (@lemma__collinearorder.lemma__collinearorder C D E H0).
------ destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H8.
----- assert (* Cut *) (euclidean__axioms.Col D C F) as H8.
------ assert (* Cut *) ((euclidean__axioms.Col D C F) /\ ((euclidean__axioms.Col D F C) /\ ((euclidean__axioms.Col F C D) /\ ((euclidean__axioms.Col C F D) /\ (euclidean__axioms.Col F D C))))) as H8.
------- apply (@lemma__collinearorder.lemma__collinearorder C D F H1).
------- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H9.
------ assert (* Cut *) (euclidean__axioms.Col C E F) as H9.
------- apply (@euclidean__tactics.not__nCol__Col C E F).
--------intro H9.
apply (@euclidean__tactics.Col__nCol__False C E F H9).
---------apply (@lemma__collinear4.lemma__collinear4 D C E F H7 H8 H6).

------- assert (* Cut *) (euclidean__axioms.Col C F E) as H10.
-------- assert (* Cut *) ((euclidean__axioms.Col E C F) /\ ((euclidean__axioms.Col E F C) /\ ((euclidean__axioms.Col F C E) /\ ((euclidean__axioms.Col C F E) /\ (euclidean__axioms.Col F E C))))) as H10.
--------- apply (@lemma__collinearorder.lemma__collinearorder C E F H9).
--------- destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
exact H17.
-------- assert (* Cut *) (euclidean__defs.Par A B D C) as H11.
--------- assert (* Cut *) ((euclidean__defs.Par B A C D) /\ ((euclidean__defs.Par A B D C) /\ (euclidean__defs.Par B A D C))) as H11.
---------- apply (@lemma__parallelflip.lemma__parallelflip A B C D H).
---------- destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H14.
--------- assert (* Cut *) (euclidean__defs.Par A B E F) as H12.
---------- assert (* Cut *) ((E = D) \/ (euclidean__axioms.neq E D)) as H12.
----------- apply (@euclidean__tactics.eq__or__neq E D).
----------- assert ((E = D) \/ (euclidean__axioms.neq E D)) as H13 by exact H12.
assert ((E = D) \/ (euclidean__axioms.neq E D)) as __TmpHyp by exact H13.
destruct __TmpHyp as [H14|H14].
------------ assert (* Cut *) (euclidean__axioms.neq D F) as H15.
------------- apply (@eq__ind__r euclidean__axioms.Point D (fun E0 => (euclidean__axioms.Col C D E0) -> ((euclidean__axioms.neq E0 F) -> ((euclidean__axioms.neq F E0) -> ((euclidean__axioms.Col D C E0) -> ((euclidean__axioms.Col C E0 F) -> ((euclidean__axioms.Col C F E0) -> (euclidean__axioms.neq D F)))))))) with (x := E).
--------------intro H15.
intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
exact H16.

-------------- exact H14.
-------------- exact H0.
-------------- exact H2.
-------------- exact H3.
-------------- exact H7.
-------------- exact H9.
-------------- exact H10.
------------- assert (* Cut *) (euclidean__axioms.neq F D) as H16.
-------------- apply (@eq__ind__r euclidean__axioms.Point D (fun E0 => (euclidean__axioms.Col C D E0) -> ((euclidean__axioms.neq E0 F) -> ((euclidean__axioms.neq F E0) -> ((euclidean__axioms.Col D C E0) -> ((euclidean__axioms.Col C E0 F) -> ((euclidean__axioms.Col C F E0) -> (euclidean__axioms.neq F D)))))))) with (x := E).
---------------intro H16.
intro H17.
intro H18.
intro H19.
intro H20.
intro H21.
exact H18.

--------------- exact H14.
--------------- exact H0.
--------------- exact H2.
--------------- exact H3.
--------------- exact H7.
--------------- exact H9.
--------------- exact H10.
-------------- assert (* Cut *) (euclidean__defs.Par A B F D) as H17.
--------------- apply (@lemma__collinearparallel.lemma__collinearparallel A B F C D H H1 H16).
--------------- assert (* Cut *) (euclidean__defs.Par A B D F) as H18.
---------------- assert (* Cut *) ((euclidean__defs.Par B A F D) /\ ((euclidean__defs.Par A B D F) /\ (euclidean__defs.Par B A D F))) as H18.
----------------- apply (@lemma__parallelflip.lemma__parallelflip A B F D H17).
----------------- destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H21.
---------------- assert (* Cut *) (euclidean__axioms.Col C F D) as H19.
----------------- assert (* Cut *) ((euclidean__axioms.Col C D F) /\ ((euclidean__axioms.Col C F D) /\ ((euclidean__axioms.Col F D C) /\ ((euclidean__axioms.Col D F C) /\ (euclidean__axioms.Col F C D))))) as H19.
------------------ apply (@lemma__collinearorder.lemma__collinearorder D C F H8).
------------------ destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H22.
----------------- assert (* Cut *) (euclidean__axioms.Col C F E) as H20.
------------------ assert (* Cut *) ((euclidean__axioms.Col F C D) /\ ((euclidean__axioms.Col F D C) /\ ((euclidean__axioms.Col D C F) /\ ((euclidean__axioms.Col C D F) /\ (euclidean__axioms.Col D F C))))) as H20.
------------------- apply (@lemma__collinearorder.lemma__collinearorder C F D H19).
------------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H10.
------------------ assert (* Cut *) (euclidean__axioms.Col F D E) as H21.
------------------- assert (* Cut *) ((C = F) \/ (euclidean__axioms.neq C F)) as H21.
-------------------- apply (@euclidean__tactics.eq__or__neq C F).
-------------------- assert ((C = F) \/ (euclidean__axioms.neq C F)) as H22 by exact H21.
assert ((C = F) \/ (euclidean__axioms.neq C F)) as __TmpHyp0 by exact H22.
destruct __TmpHyp0 as [H23|H23].
--------------------- assert (* Cut *) (euclidean__axioms.Col C D E) as H24.
---------------------- assert (* Cut *) ((euclidean__axioms.Col F C E) /\ ((euclidean__axioms.Col F E C) /\ ((euclidean__axioms.Col E C F) /\ ((euclidean__axioms.Col C E F) /\ (euclidean__axioms.Col E F C))))) as H24.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder C F E H20).
----------------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H0.
---------------------- assert (* Cut *) (euclidean__axioms.Col F D E) as H25.
----------------------- apply (@eq__ind__r euclidean__axioms.Point F (fun C0 => (euclidean__defs.Par A B C0 D) -> ((euclidean__axioms.Col C0 D E) -> ((euclidean__axioms.Col C0 D F) -> ((euclidean__axioms.nCol A C0 D) -> ((euclidean__axioms.neq C0 D) -> ((euclidean__axioms.neq D C0) -> ((euclidean__axioms.Col D C0 E) -> ((euclidean__axioms.Col D C0 F) -> ((euclidean__axioms.Col C0 E F) -> ((euclidean__axioms.Col C0 F E) -> ((euclidean__defs.Par A B D C0) -> ((euclidean__axioms.Col C0 F D) -> ((euclidean__axioms.Col C0 F E) -> ((euclidean__axioms.Col C0 D E) -> (euclidean__axioms.Col F D E)))))))))))))))) with (x := C).
------------------------intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
intro H32.
intro H33.
intro H34.
intro H35.
intro H36.
intro H37.
intro H38.
apply (@eq__ind__r euclidean__axioms.Point D (fun E0 => (euclidean__axioms.Col F D E0) -> ((euclidean__axioms.neq E0 F) -> ((euclidean__axioms.neq F E0) -> ((euclidean__axioms.Col F F E0) -> ((euclidean__axioms.Col F E0 F) -> ((euclidean__axioms.Col D F E0) -> ((euclidean__axioms.Col F F E0) -> ((euclidean__axioms.Col F D E0) -> (euclidean__axioms.Col F D E0)))))))))) with (x := E).
-------------------------intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
exact H46.

------------------------- exact H14.
------------------------- exact H26.
------------------------- exact H2.
------------------------- exact H3.
------------------------- exact H34.
------------------------- exact H33.
------------------------- exact H31.
------------------------- exact H37.
------------------------- exact H38.

------------------------ exact H23.
------------------------ exact H.
------------------------ exact H0.
------------------------ exact H1.
------------------------ exact H4.
------------------------ exact H5.
------------------------ exact H6.
------------------------ exact H7.
------------------------ exact H8.
------------------------ exact H9.
------------------------ exact H10.
------------------------ exact H11.
------------------------ exact H19.
------------------------ exact H20.
------------------------ exact H24.
----------------------- exact H25.
--------------------- assert (* Cut *) (euclidean__axioms.Col F D E) as H24.
---------------------- apply (@euclidean__tactics.not__nCol__Col F D E).
-----------------------intro H24.
apply (@euclidean__tactics.Col__nCol__False F D E H24).
------------------------apply (@lemma__collinear4.lemma__collinear4 C F D E H19 H20 H23).

---------------------- exact H24.
------------------- assert (* Cut *) (euclidean__axioms.Col D F E) as H22.
-------------------- assert (* Cut *) ((euclidean__axioms.Col D F E) /\ ((euclidean__axioms.Col D E F) /\ ((euclidean__axioms.Col E F D) /\ ((euclidean__axioms.Col F E D) /\ (euclidean__axioms.Col E D F))))) as H22.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder F D E H21).
--------------------- destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
exact H23.
-------------------- assert (* Cut *) (euclidean__defs.Par A B E F) as H23.
--------------------- apply (@eq__ind__r euclidean__axioms.Point D (fun E0 => (euclidean__axioms.Col C D E0) -> ((euclidean__axioms.neq E0 F) -> ((euclidean__axioms.neq F E0) -> ((euclidean__axioms.Col D C E0) -> ((euclidean__axioms.Col C E0 F) -> ((euclidean__axioms.Col C F E0) -> ((euclidean__axioms.Col C F E0) -> ((euclidean__axioms.Col F D E0) -> ((euclidean__axioms.Col D F E0) -> (euclidean__defs.Par A B E0 F))))))))))) with (x := E).
----------------------intro H23.
intro H24.
intro H25.
intro H26.
intro H27.
intro H28.
intro H29.
intro H30.
intro H31.
exact H18.

---------------------- exact H14.
---------------------- exact H0.
---------------------- exact H2.
---------------------- exact H3.
---------------------- exact H7.
---------------------- exact H9.
---------------------- exact H10.
---------------------- exact H20.
---------------------- exact H21.
---------------------- exact H22.
--------------------- exact H23.
------------ assert (* Cut *) (euclidean__defs.Par A B E D) as H15.
------------- apply (@lemma__collinearparallel.lemma__collinearparallel A B E C D H H0 H14).
------------- assert (* Cut *) (euclidean__defs.Par A B D E) as H16.
-------------- assert (* Cut *) ((euclidean__defs.Par B A E D) /\ ((euclidean__defs.Par A B D E) /\ (euclidean__defs.Par B A D E))) as H16.
--------------- apply (@lemma__parallelflip.lemma__parallelflip A B E D H15).
--------------- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H19.
-------------- assert (* Cut *) (euclidean__axioms.Col D E F) as H17.
--------------- apply (@euclidean__tactics.not__nCol__Col D E F).
----------------intro H17.
apply (@euclidean__tactics.Col__nCol__False D E F H17).
-----------------apply (@lemma__collinear4.lemma__collinear4 C D E F H0 H1 H5).

--------------- assert (* Cut *) (euclidean__defs.Par A B F E) as H18.
---------------- apply (@lemma__collinearparallel.lemma__collinearparallel A B F D E H16 H17 H3).
---------------- assert (* Cut *) (euclidean__defs.Par A B E F) as H19.
----------------- assert (* Cut *) ((euclidean__defs.Par B A F E) /\ ((euclidean__defs.Par A B E F) /\ (euclidean__defs.Par B A E F))) as H19.
------------------ apply (@lemma__parallelflip.lemma__parallelflip A B F E H18).
------------------ destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H22.
----------------- exact H19.
---------- exact H12.
Qed.


Require Import String Omega List FunctionalExtensionality Ensembles
        Computation ADT ADTRefinement ADTNotation BuildADTRefinements
        KVEnsembles CacheSpec CacheRefinements.

Require Import String_as_OT.
Require Import FMapAVL.
Module StringIndexedMap := FMapAVL.Make String_as_OT.
Definition MapStringNat := StringIndexedMap.t nat.

Section StringKEnsembles.

(* Implementation of Ensembles of String + Value pairs using
   finite maps. *)

  Variable Value : Type.

  Definition EnsembleFMapEquivalence {A}
             (ens : Ensemble (string * A))
             (fmap : StringIndexedMap.t A) :=
    forall k,
      (forall a, StringIndexedMap.find k fmap = Some a ->
                 ens (k, a))
      /\ (forall a, ens (k, a) ->
                    StringIndexedMap.find k fmap = Some a).

  Definition FMapCommonKeys {A B}
             (values : StringIndexedMap.t A)
             (indices : StringIndexedMap.t B)
    := forall k,
         (forall a, StringIndexedMap.MapsTo k a values ->
                    exists b, StringIndexedMap.MapsTo k b indices)
         /\ (forall b, StringIndexedMap.MapsTo k b indices ->
                    exists a, StringIndexedMap.MapsTo k a values).

  Lemma decides_usedKey
  : forall (or : Ensemble (string * Value))
           (nr : StringIndexedMap.t Value)
           (k : string),
      EnsembleFMapEquivalence or nr ->
      decides (if StringIndexedMap.find k nr then
                 true else
                 false)
              (usedKey or k).
  Proof.
    unfold EnsembleFMapEquivalence, usedKey; intros;
    pose proof (H k); intuition.
    find_if_inside; simpl; eauto.
    intuition; destruct_ex.
    apply H2 in H0; discriminate.
  Qed.

  Lemma AbsR_add_EnsembleReplaceKey {A}
  : forall nr kv or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleReplaceKey kv or)
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold EnsembleReplaceKey, EnsembleRemoveKey,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    simpl in H1; congruence.
    destruct (H k).
    generalize (H4 _ H3).
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdateKey {A}
  : forall nr k f or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleUpdateKey k or f)
           (StringIndexedMap.add k (f v) nr).
  Proof.
    unfold EnsembleUpdateKey, EnsembleRemoveKey,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (f v) (refl_equal k)))
      in *; simpl in *; f_equal; injections; intuition.
    eexists; split; eauto.
    eapply H; eauto.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    destruct_ex; intuition; subst.
    apply H in H3; rewrite H0 in H3; injections.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    apply H in H3.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdateKey' {A}
  : forall nr k f or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = None
      -> EnsembleFMapEquivalence (EnsembleUpdateKey k or f) nr.
  Proof.
    unfold EnsembleUpdateKey, EnsembleRemoveKey,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    rewrite H0 in H1; discriminate.
    right; intuition; eapply H; eauto.
    subst; simpl in *.
    destruct_ex; intuition; eapply H in H3; subst.
    destruct_ex; rewrite H0 in *; discriminate.
    eapply H; eauto.
  Qed.

  Lemma AbsR_add_EnsembleInsert {A}
  : forall nr kv or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = None
      -> EnsembleFMapEquivalence
           (fun kv' => kv' = kv \/ or kv')
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right.
    pose proof (H k); intuition.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    apply H in H2.
    rewrite H0 in H2; discriminate.
    apply H in H2.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_remove_EnsembleRemoveKey {A}
  : forall nr or k,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleRemoveKey k or)
           (StringIndexedMap.remove k nr).
  Proof.
    unfold EnsembleRemoveKey, EnsembleFMapEquivalence;
    intros; intuition; simpl in *; subst.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    destruct (string_dec k0 k); subst; simpl in *.
    elimtype False.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0; eapply H;
    eauto using StringIndexedMap.find_1.
    apply StringIndexedMap.find_1.
    apply StringIndexedMap.remove_2; eauto.
    eapply H in H2.
    eauto using StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleInsertRemove {A}
  : forall nr or kv,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleInsert kv (EnsembleRemoveKey (fst kv) or))
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleRemoveKey,
    EnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k a); subst; simpl in *.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ b (refl_equal a)))
      in H0; left; f_equal; congruence.
    right; intuition;
    apply StringIndexedMap.find_2 in H0;
      apply StringIndexedMap.add_3 in H0; eauto.
    eapply H; eauto using StringIndexedMap.find_1.
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
    StringIndexedMap.MapsTo in *; simpl in *; eauto.
    injections.
    eauto using StringIndexedMap.find_1,
    StringIndexedMap.add_1.
    apply H in H2; simpl in *.
    apply StringIndexedMap.find_1;
      apply StringIndexedMap.add_2; eauto.
    eauto using StringIndexedMap.find_1,
      StringIndexedMap.add_2, StringIndexedMap.remove_2,
      StringIndexedMap.find_2.
  Qed.

  Lemma FMapCommonKeys_add {A B}
  : forall k a b
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.add k a ens)
           (StringIndexedMap.add k b ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [eexists; eapply StringIndexedMap.add_1; eauto
     |
     eapply StringIndexedMap.add_3 in H0; eauto;
     apply H in H0; destruct_ex;
     eexists; eapply StringIndexedMap.add_2; eauto]).
  Qed.

  Lemma FMapCommonKeys_remove {A B}
  : forall k
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.remove k ens)
           (StringIndexedMap.remove k ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [subst; elimtype False;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto
     |
     eapply StringIndexedMap.remove_3 in H0;
       apply H in H0; destruct_ex;
       eauto using StringIndexedMap.remove_2 ]).
  Qed.

  Definition find_minimum_Key
             (indices : StringIndexedMap.t nat)
  : option (string * nat) :=
    StringIndexedMap.fold
      (fun k idx sv =>
         Ifopt sv as sv'
                       Then
                         if (lt_dec idx (snd sv') )
                         then Some (k, idx)
                         else Some sv'
                       Else
                         Some (k, idx))
      indices None.

  Lemma fold_left_In :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l p' =
   Some kv ->
   (Some kv = p') \/
   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     kv l.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    destruct p'; simpl in H.
    destruct (lt_dec (snd a) (snd p)).
    destruct (IHl _ _ H).
    right; constructor; injections; simpl; eauto.
    right; constructor 2; eauto.
    destruct (IHl _ _ H).
    injections; eauto.
    eauto.
    right; destruct (IHl _ _ H); injections; eauto.
  Qed.

  Lemma fold_left_min_opt :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l (Some p') =
   Some kv ->
   snd kv <= snd p'.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    injections; eauto.
    destruct (lt_dec (snd a) (snd p')).
    apply le_trans with (m := snd a); eauto with arith.
    eauto.
  Qed.

  Lemma find_minimum_Key_In :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      StringIndexedMap.MapsTo (elt:=nat) (fst kv) (snd kv) indices.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    eapply StringIndexedMap.elements_2.
    destruct (@fold_left_In (StringIndexedMap.elements (elt:=nat) indices) kv None); intuition.
    unfold StringIndexedMap.key in *.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal;
    intuition.
    discriminate.
    destruct kv.
    unfold StringIndexedMap.eq_key_elt, StringIndexedMap.Raw.Proofs.PX.eqke; eauto.
  Qed.

  Lemma find_minimum_Key_correct :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      forall k v, StringIndexedMap.find k indices = Some v ->
                  snd kv <= v.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.elements_1 in H0.
    unfold StringIndexedMap.eq_key_elt in H0.
    unfold StringIndexedMap.Raw.Proofs.PX.eqke in H0.
    assert (   forall (k0 : StringIndexedMap.key) (v0 : nat) p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p)
     (StringIndexedMap.elements (elt:=nat) indices) (Some p') =
   Some kv ->

   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     (k0, v0) (StringIndexedMap.elements (elt:=nat) indices)
   -> ((snd kv <= snd p') /\( snd kv <= v0 ))).
    { clear; induction (StringIndexedMap.elements (elt:=nat) indices);
      simpl; intros; subst; eauto.
      destruct p'; simpl in H.
      inversion H0; subst; intuition; simpl in *; subst; eauto.
      destruct (lt_dec (snd a) (snd p')).
      inversion H0; subst.
      intuition; simpl in *; intros; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *.
      eauto with arith.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto with arith.
      intuition.
      destruct (IHl _ _ _ H H2); simpl in *.
      omega.
      destruct (IHl _ _ _ H H2); simpl in *; eauto.
      inversion H0; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      intuition; simpl in *; subst.
      apply not_gt.
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      eapply le_trans.
      eapply H2.
      apply not_gt; auto with arith.
      destruct (IHl _ _ _ H H2); eauto.
    }
    destruct ((StringIndexedMap.elements (elt:=nat) indices)).
    simpl in H; discriminate.
    simpl in H.
    eapply H1 with (p' := p); eauto.
    simpl.
    destruct (lt_dec (snd p) (snd p)); eauto.
    elimtype False.
    omega.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal.
    destruct x0; reflexivity.
    destruct p; eauto.
  Qed.

  Lemma refine_pick_oldest {V} :
    forall spec_indices impl_indices
           spec_values impl_values,
    EnsembleFMapEquivalence spec_indices impl_indices /\
    EnsembleFMapEquivalence spec_values impl_values /\
    FMapCommonKeys impl_values impl_indices
    ->  refine {k_opt | forall k' : string,
                          k_opt = Some k' ->
                          ((exists v' : V, spec_values (k', v'))
                           /\ (forall (idx : nat) (ki : string * nat),
                                 spec_indices (k', idx) -> spec_indices ki -> idx <= snd ki))}
               (ret (option_map fst (find_minimum_Key impl_indices))).
  Proof.
    unfold refine; intros; inversion_by computes_to_inv; subst.
    econstructor; intros.
    caseEq (find_minimum_Key impl_indices); rewrite H2 in *;
    simpl in *; try discriminate; injections.
    unfold EnsembleFMapEquivalence in *.
    pose proof (find_minimum_Key_correct _ H2).
    pose proof (find_minimum_Key_In _ H2).
    split; intros.
    unfold FMapCommonKeys in H3.
    destruct (H3 (fst p)).
    destruct (H6 (snd p)); eauto.
    destruct (H (fst p)); eexists; eauto.
    eapply H8.
    eauto using StringIndexedMap.find_1.
    apply H1 in H5; destruct ki; eapply H1 in H6. destruct_ex;
    simpl in *.
    eapply StringIndexedMap.find_1 in H4; rewrite H5 in H4.
    injection H4; intros; subst; eauto.
  Qed.

  Lemma refine_If_Then_Else'
  : forall (A : Type) (c : bool) (x x0 y y0 : Comp A),
      (c = true -> refine x y)
      -> (c = false -> refine x0 y0)
      -> refine (If c Then x Else x0) (If c Then y Else y0).
  Proof.
    unfold refine; intros; destruct c; auto.
  Qed.

  Lemma FMapCommonKeys_find_None {A B}
  : forall m m' k,
      FMapCommonKeys m m'
      -> StringIndexedMap.find (elt:=A) k m = None
      -> StringIndexedMap.find (elt:=B) k m' = None .
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=B) k m'); eauto.
    apply StringIndexedMap.find_2 in H1.
    apply H in H1.
    destruct_ex.
    apply StringIndexedMap.find_1 in H1.
    rewrite H1 in H0; discriminate.
  Qed.

  Lemma StringIndexedMap_find_None_remove {V}
  : forall k k' m,
      StringIndexedMap.find (elt:=V) k m = None
      -> StringIndexedMap.find
           (elt:=V) k
           (StringIndexedMap.remove k' m) = None.
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=V) k (StringIndexedMap.remove (elt:=V) k' m)); eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0;
      apply StringIndexedMap.find_1 in H0;
      congruence.
  Qed.

End StringKEnsembles.

Section BoundedCacheFMap.

  Variable Bound : nat.

  Definition indexBound
             (indices : StringIndexedMap.t nat)
             (indicesBound : nat)
    := forall k idx,
         StringIndexedMap.find k indices = Some idx ->
         idx <= indicesBound.

  Lemma indexBound_add
  : forall indices k n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n indices) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

  Lemma indexBound_add_remove
  : forall indices k k' n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n
                                          (StringIndexedMap.remove k' indices)) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    destruct (string_dec k' k0).
    elimtype False;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto.
    apply StringIndexedMap.remove_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

End BoundedCacheFMap.


Goal forall (A : Prop), A -> A.
Proof.
intros.
apply H.
Qed.